V.pm

   1 #!/pro/bin/perl
   2
   3 package Config::Perl::V;
   4
   5 use strict;
   6 use warnings;
   7
   8 use Config;
   9 use Exporter;
  10 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
  11 $VERSION     = "0.10";
  12 @ISA         = ("Exporter");
  13 @EXPORT_OK   = qw( plv2hash summary myconfig signature );
  14 %EXPORT_TAGS = (
  15     all => [ @EXPORT_OK  ],
  16     sig => [ "signature" ],
  17     );
  18
  19 #  Characteristics of this binary (from libperl):
  20 #    Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
  21 #                          USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
  22
  23 # The list are as the perl binary has stored it in PL_bincompat_options
  24 #  search for it in
  25 #   perl.c line 1768 (first  block)
  26 #   perl.h line 4454 (second block),
  27 my %BTD = map { $_ => 0 } qw(
  28
  29     DEBUGGING
  30     NO_MATHOMS
  31     PERL_DISABLE_PMC
  32     PERL_DONT_CREATE_GVSV
  33     PERL_MALLOC_WRAP
  34     PERL_MEM_LOG
  35     PERL_MEM_LOG_ENV
  36     PERL_MEM_LOG_ENV_FD
  37     PERL_MEM_LOG_STDERR
  38     PERL_MEM_LOG_TIMESTAMP
  39     PERL_USE_DEVEL
  40     PERL_USE_SAFE_PUTENV
  41     USE_FAST_STDIO
  42     USE_SITECUSTOMIZE
  43
  44     DEBUG_LEAKING_SCALARS
  45     DEBUG_LEAKING_SCALARS_FORK_DUMP
  46     DECCRTL_SOCKETS
  47     FAKE_THREADS
  48     MULTIPLICITY
  49     MYMALLOC
  50     PERL_DEBUG_READONLY_OPS
  51     PERL_GLOBAL_STRUCT
  52     PERL_IMPLICIT_CONTEXT
  53     PERL_IMPLICIT_SYS
  54     PERL_MAD
  55     PERL_NEED_APPCTX
  56     PERL_NEED_TIMESBASE
  57     PERL_OLD_COPY_ON_WRITE
  58     PERL_POISON
  59     PERL_TRACK_MEMPOOL
  60     PERL_USES_PL_PIDSTATUS
  61     PL_OP_SLAB_ALLOC
  62     THREADS_HAVE_PIDS
  63     USE_64_BIT_ALL
  64     USE_64_BIT_INT
  65     USE_IEEE
  66     USE_ITHREADS
  67     USE_LARGE_FILES
  68     USE_LONG_DOUBLE
  69     USE_PERLIO
  70     USE_REENTRANT_API
  71     USE_SFIO
  72     USE_SOCKS
  73     VMS_DO_SOCKETS
  74     VMS_SYMBOL_CASE_AS_IS
  75     );
  76
  77 # These are all the keys that are
  78 # 1. Always present in %Config (first block)
  79 # 2. Reported by 'perl -V' (the rest)
  80 my @config_vars = qw(
  81
  82     api_subversion
  83     api_version
  84     api_versionstring
  85     archlibexp
  86     dont_use_nlink
  87     d_readlink
  88     d_symlink
  89     exe_ext
  90     inc_version_list
  91     ldlibpthname
  92     patchlevel
  93     path_sep
  94     perl_patchlevel
  95     privlibexp
  96     scriptdir
  97     sitearchexp
  98     sitelibexp
  99     subversion
 100     usevendorprefix
 101     version
 102
 103     git_commit_id
 104     git_describe
 105     git_branch
 106     git_uncommitted_changes
 107     git_commit_id_title
 108     git_snapshot_date
 109
 110     package revision version_patchlevel_string
 111
 112     osname osvers archname
 113     myuname
 114     config_args
 115     hint useposix d_sigaction
 116     useithreads usemultiplicity
 117     useperlio d_sfio uselargefiles usesocks
 118     use64bitint use64bitall uselongdouble
 119     usemymalloc bincompat5005
 120
 121     cc ccflags
 122     optimize
 123     cppflags
 124     ccversion gccversion gccosandvers
 125     intsize longsize ptrsize doublesize byteorder
 126     d_longlong longlongsize d_longdbl longdblsize
 127     ivtype ivsize nvtype nvsize lseektype lseeksize
 128     alignbytes prototype
 129
 130     ld ldflags
 131     libpth
 132     libs
 133     perllibs
 134     libc so useshrplib libperl
 135     gnulibc_version
 136
 137     dlsrc dlext d_dlsymun ccdlflags
 138     cccdlflags lddlflags
 139     );
 140
 141 my %empty_build = (
 142     osname  => "",
 143     stamp   => 0,
 144     options => { %BTD },
 145     patches => [],
 146     );
 147
 148 sub _make_derived
 149 {
 150     my $conf = shift;
 151
 152     for ( [ lseektype           => "Off_t"      ],
 153           [ myuname             => "uname"      ],
 154           [ perl_patchlevel     => "patch"      ],
 155           ) {
 156         my ($official, $derived) = @$_;
 157         $conf->{config}{$derived}  ||= $conf->{config}{$official};
 158         $conf->{config}{$official} ||= $conf->{config}{$derived};
 159         $conf->{derived}{$derived} = delete $conf->{config}{$derived};
 160         }
 161
 162     if (exists $conf->{config}{version_patchlevel_string} &&
 163        !exists $conf->{config}{api_version}) {
 164         my $vps = $conf->{config}{version_patchlevel_string};
 165         $vps =~ s{\b revision   \s+ (\S+) }{}x and
 166             $conf->{config}{revision}        ||= $1;
 167
 168         $vps =~ s{\b version    \s+ (\S+) }{}x and
 169             $conf->{config}{api_version}     ||= $1;
 170         $vps =~ s{\b subversion \s+ (\S+) }{}x and
 171             $conf->{config}{subversion}      ||= $1;
 172         $vps =~ s{\b patch      \s+ (\S+) }{}x and
 173             $conf->{config}{perl_patchlevel} ||= $1;
 174         }
 175
 176     ($conf->{config}{version_patchlevel_string} ||= join " ",
 177         map  { ($_, $conf->{config}{$_} ) }
 178         grep {      $conf->{config}{$_}   }
 179         qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//;
 180
 181     $conf->{config}{perl_patchlevel}  ||= "";   # 0 is not a valid patchlevel
 182
 183     if ($conf->{config}{perl_patchlevel} =~ m{^git\w*-([^-]+)}i) {
 184         $conf->{config}{git_branch}   ||= $1;
 185         $conf->{config}{git_describe} ||= $conf->{config}{perl_patchlevel};
 186         }
 187
 188     $conf;
 189     } # _make_derived
 190
 191 sub plv2hash
 192 {
 193     my %config;
 194     for (split m/\n+/ => join "\n", @_) {
 195
 196         if (s/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)//) {
 197             $config{"package"} = $1;
 198             my $rev = $2;
 199             $rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1;
 200             $rev and $config{version_patchlevel_string} = $rev;
 201             my ($rel) = $config{package} =~ m{perl(\d)};
 202             my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
 203             defined $vers && defined $subvers && defined $rel and
 204                 $config{version} = "$rel.$vers.$subvers";
 205             next;
 206             }
 207
 208         if (s/^\s+(Snapshot of:)\s+(\S+)//) {
 209             $config{git_commit_id_title} = $1;
 210             $config{git_commit_id}       = $2;
 211             next;
 212             }
 213
 214         my %kv = m/\G,?\s*([^=]+)=('[^']+?'|\S+)/gc;
 215
 216         while (my ($k, $v) = each %kv) {
 217             $k =~ s/\s+$//;
 218             $v =~ s/,$//;
 219             $v =~ m/^'(.*)'$/ and $v = $1;
 220             $v =~ s/^\s+//;
 221             $v =~ s/\s+$//;
 222             $config{$k} = $v;
 223             }
 224         }
 225     my $build = { %empty_build };
 226     $build->{osname} = $config{osname};
 227     return _make_derived ({
 228         build           => $build,
 229         environment     => {},
 230         config          => \%config,
 231         derived         => {},
 232         inc             => [],
 233         });
 234     } # plv2hash
 235
 236 sub summary
 237 {
 238     my $conf = shift || myconfig ();
 239     ref $conf eq "HASH" &&
 240         exists $conf->{config} && exists $conf->{build} or return;
 241
 242     my %info = map {
 243         exists $conf->{config}{$_} ? ( $_ => $conf->{config}{$_} ) : () }
 244         qw( archname osname osvers revision patchlevel subversion version
 245             cc ccversion gccversion config_args inc_version_list
 246             d_longdbl d_longlong use64bitall use64bitint useithreads
 247             uselongdouble usemultiplicity usemymalloc useperlio useshrplib
 248             doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
 249             );
 250     $info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}};
 251
 252     return \%info;
 253     } # summary
 254
 255 sub signature
 256 {
 257     eval { require Digest::MD5 };
 258     $@ and return "00000000000000000000000000000000";
 259
 260     my $conf = shift || summary ();
 261     delete $conf->{config_args};
 262     return Digest::MD5::md5_hex (join "\xFF" => map {
 263         "$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
 264         } sort keys %$conf);
 265     } # signature
 266
 267 sub myconfig
 268 {
 269     my $args = shift;
 270     my %args = ref $args eq "HASH"  ? %$args :
 271                ref $args eq "ARRAY" ? @$args : ();
 272
 273     #y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
 274     my $pv = qx[$^X -V];
 275        $pv =~ s{.*?\n\n}{}s;
 276        $pv =~ s{\n(?:  \s+|\t\s*)}{ }g;
 277
 278     #print $pv;
 279
 280     my $build = { %empty_build };
 281     $pv =~ m{^\s+Built under (.*)}m                and $build->{osname} = $1;
 282     $pv =~ m{^\s+Compiled at (.*)}m                and $build->{stamp}  = $1;
 283     $pv =~ m{^\s+Locally applied patches:\s+(.*)}m and $build->{patches} = [ split m/\s+/, $1 ];
 284     $pv =~ m{^\s+Compile-time options:\s+(.*)}m    and map { $build->{options}{$_} = 1 } split m/\s+/, $1;
 285
 286     my @KEYS = keys %ENV;
 287     my %env  =
 288         map {      $_ => $ENV{$_} } grep m/^PERL/      => @KEYS;
 289     $args{env} and
 290         map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS;
 291
 292     my %config = map { $_ => $Config{$_} } @config_vars;
 293
 294     return _make_derived ({
 295         build           => $build,
 296         environment     => \%env,
 297         config          => \%config,
 298         derived         => {},
 299         inc             => \@INC,
 300         });
 301     } # myconfig
 302
 303 1;
 304
 305 __END__
 306
 307 =head1 NAME
 308
 309 Config::Perl::V - Structured data retreival of perl -V output
 310
 311 =head1 SYNOPSIS
 312
 313  use Config::Perl::V;
 314
 315  my $local_config = Config::Perl::V::myconfig ();
 316  print $local_config->{config}{osname};
 317
 318 =head1 DESCRIPTION
 319
 320 =head2 $conf = myconfig ()
 321
 322 This function will collect the data described in L<the hash structure> below,
 323 and return that as a hash reference. It optionally accepts an option to
 324 include more entries from %ENV. See L<environment> below.
 325
 326 Note that this will not work on uninstalled perls when called with
 327 C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
 328 C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
 329 known when the C<-V> information is collected.
 330
 331 =head2 $conf = plv2hash ($text [, ...])
 332
 333 Convert a sole 'perl -V' text block, or list of lines, to a complete
 334 myconfig hash.  All unknown entries are defaulted.
 335
 336 =head2 $info = summary ([$conf])
 337
 338 Return an arbitrary selection of the information. If no C<$conf> is
 339 given, C<myconfig ()> is used instead.
 340
 341 =head2 $md5 = signature ([$conf])
 342
 343 Return the MD5 of the info returned by C<summary ()> without the
 344 C<config_args> entry.
 345
 346 If C<Digest::MD5> is not available, it return a string with only C<0>'s.
 347
 348 =head2 The hash structure
 349
 350 The returned hash consists of 4 parts:
 351
 352 =over 4
 353
 354 =item build
 355
 356 This information is extracted from the second block that is emitted by
 357 C<perl -V>, and usually looks something like
 358
 359  Characteristics of this binary (from libperl):
 360    Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
 361    Locally applied patches:
 362          defined-or
 363          MAINT24637
 364    Built under linux
 365    Compiled at Jun 13 2005 10:44:20
 366    @INC:
 367      /usr/lib/perl5/5.8.7/i686-linux-64int
 368      /usr/lib/perl5/5.8.7
 369      /usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
 370      /usr/lib/perl5/site_perl/5.8.7
 371      /usr/lib/perl5/site_perl
 372      .
 373
 374 or
 375
 376  Characteristics of this binary (from libperl):
 377    Compile-time options: DEBUGGING MULTIPLICITY
 378                          PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
 379                          PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
 380                          PERL_USE_SAFE_PUTENV USE_ITHREADS
 381                          USE_LARGE_FILES USE_PERLIO
 382                          USE_REENTRANT_API
 383    Built under linux
 384    Compiled at Jan 28 2009 15:26:59
 385
 386 This information is not available anywhere else, including C<%Config>,
 387 but it is the information that is only known to the perl binary.
 388
 389 The extracted information is stored in 5 entries in the C<build> hash:
 390
 391 =over 4
 392
 393 =item osname
 394
 395 This is most likely the same as C$Config{osname}>, and was the name
 396 known when perl was built. It might be different if perl was cross-compiled.
 397
 398 The default for this field, if it cannot be extracted, is to copy C<$Config{osname}>.
 399 `
 400 =item stamp
 401
 402 This is the time string for which the perl binary was compiled. The default
 403 value is 0.
 404
 405 =item options
 406
 407 This is a hash with all the known defines as keys. The value is either 0,
 408 which means unknown or unset, or 1, which means defined.
 409
 410 =item derived
 411
 412 As some verables are reported by a different name in the output of C<perl -V>
 413 than their actual name in C<%Config>, I decided to leave the C<config> entry
 414 as close to reality as possible, and put in the entries that might have been
 415 guessed by the printed output in a seperate block.
 416
 417 =item patches
 418
 419 This is a list of optionally locally applied patches. Default is an empty list.
 420
 421 =back
 422
 423 =item environment
 424
 425 By default this hash is only filled with the environment variables
 426 out of %ENV that start with C<PERL>, but you can pass the C<env> option
 427 to myconfig to get more
 428
 429  my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
 430  my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);
 431
 432 =item config
 433
 434 This hash is filled with the variables that C<perl -V> fills its report
 435 with, and it has the same variables that C<Config::myconfig> returns
 436 from C<%Config>.
 437
 438 =item inc
 439
 440 This is the list of default @INC.
 441
 442 =back
 443
 444 =head1 REASONING
 445
 446 This module was written to be able to return the configuration for the
 447 currently used perl as deeply as needed for the CPANTESTERS framework.
 448 Up until now they used the output of myconfig as a single text blob,
 449 and so it was missing the vital binary characteristics of the running
 450 perl and the optional applied patches.
 451
 452 =head1 BUGS
 453
 454 Please feedback what is wrong
 455
 456 =head1 TODO
 457
 458 * Implement retrieval functions/methods
 459 * Documentation
 460 * Error checking
 461 * Tests
 462
 463 =head1 AUTHOR
 464
 465 H.Merijn Brand <h.m.brand@xs4all.nl>
 466
 467 =head1 COPYRIGHT AND LICENSE
 468
 469 Copyright (C) 2009 H.Merijn Brand
 470
 471 This library is free software; you can redistribute it and/or modify
 472 it under the same terms as Perl itself.
 473
 474 =cut