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