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