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(\w+)\s*=\s*('[^']+?'|\S+)/g)) {
 254
 255         while (my ($k, $v) = each %kv) {
 256             $k =~ s/\s+$//;
 257             $v =~ s/,$//;
 258             $v =~ m/^'(.*)'$/ and $v = $1;
 259             $v =~ s/^\s+//;
 260             $v =~ s/\s+$//;
 261             $config{$k} = $v;
 262             }
 263         }
 264
 265     my $build = { %empty_build };
 266
 267     $pv =~ m{^\s+Compiled at\s+(.*)}m
 268         and $build->{stamp}   = $1;
 269     $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*)}m
 270         and $build->{patches} = [ split m/\n+/, $1 ];
 271     $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*)}m
 272         and map { $build->{options}{$_} = 1 } split m/\s+|\n/ => $1;
 273
 274     $build->{osname} = $config{osname};
 275     $pv =~ m{^\s+Built under\s+(.*)}m
 276         and $build->{osname}  = $1;
 277     $config{osname} ||= $build->{osname};
 278
 279     return _make_derived ({
 280         build           => $build,
 281         environment     => {},
 282         config          => \%config,
 283         derived         => {},
 284         inc             => [],
 285         });
 286     } # plv2hash
 287
 288 sub summary
 289 {
 290     my $conf = shift || myconfig ();
 291     ref $conf eq "HASH" &&
 292         exists $conf->{config} && exists $conf->{build} or return;
 293
 294     my %info = map {
 295         exists $conf->{config}{$_} ? ( $_ => $conf->{config}{$_} ) : () }
 296         qw( archname osname osvers revision patchlevel subversion version
 297             cc ccversion gccversion config_args inc_version_list
 298             d_longdbl d_longlong use64bitall use64bitint useithreads
 299             uselongdouble usemultiplicity usemymalloc useperlio useshrplib
 300             doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
 301             );
 302     $info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}};
 303
 304     return \%info;
 305     } # summary
 306
 307 sub signature
 308 {
 309     eval { require Digest::MD5 };
 310     $@ and return "00000000000000000000000000000000";
 311
 312     my $conf = shift || summary ();
 313     delete $conf->{config_args};
 314     return Digest::MD5::md5_hex (join "\xFF" => map {
 315         "$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
 316         } sort keys %$conf);
 317     } # signature
 318
 319 sub myconfig
 320 {
 321     my $args = shift;
 322     my %args = ref $args eq "HASH"  ? %$args :
 323                ref $args eq "ARRAY" ? @$args : ();
 324
 325     my $build = { %empty_build };
 326
 327     # 5.14.0 and later provide all the information without shelling out
 328     my $stamp = eval { Config::compile_date () };
 329     if (defined $stamp) {
 330         $stamp =~ s/^Compiled at //;
 331         $build->{osname}      = $^O;
 332         $build->{stamp}       = $stamp;
 333         $build->{patches}     =     [ Config::local_patches () ];
 334         $build->{options}{$_} = 1 for Config::bincompat_options (),
 335                                       Config::non_bincompat_options ();
 336         }
 337     else {
 338         #y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
 339         my $cnf = plv2hash (qx[$^X -V]);
 340
 341         $build->{$_} = $cnf->{build}{$_} for qw( osname stamp patches options );
 342         }
 343
 344     my @KEYS = keys %ENV;
 345     my %env  =
 346         map {      $_ => $ENV{$_} } grep m/^PERL/      => @KEYS;
 347     $args{env} and
 348         map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS;
 349
 350     my %config = map { $_ => $Config{$_} } @config_vars;
 351
 352     return _make_derived ({
 353         build           => $build,
 354         environment     => \%env,
 355         config          => \%config,
 356         derived         => {},
 357         inc             => \@INC,
 358         });
 359     } # myconfig
 360
 361 1;
 362
 363 __END__
 364
 365 =head1 NAME
 366
 367 Config::Perl::V - Structured data retrieval of perl -V output
 368
 369 =head1 SYNOPSIS
 370
 371  use Config::Perl::V;
 372
 373  my $local_config = Config::Perl::V::myconfig ();
 374  print $local_config->{config}{osname};
 375
 376 =head1 DESCRIPTION
 377
 378 =head2 $conf = myconfig ()
 379
 380 This function will collect the data described in L<the hash structure> below,
 381 and return that as a hash reference. It optionally accepts an option to
 382 include more entries from %ENV. See L<environment> below.
 383
 384 Note that this will not work on uninstalled perls when called with
 385 C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
 386 C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
 387 known when the C<-V> information is collected.
 388
 389 =head2 $conf = plv2hash ($text [, ...])
 390
 391 Convert a sole 'perl -V' text block, or list of lines, to a complete
 392 myconfig hash.  All unknown entries are defaulted.
 393
 394 =head2 $info = summary ([$conf])
 395
 396 Return an arbitrary selection of the information. If no C<$conf> is
 397 given, C<myconfig ()> is used instead.
 398
 399 =head2 $md5 = signature ([$conf])
 400
 401 Return the MD5 of the info returned by C<summary ()> without the
 402 C<config_args> entry.
 403
 404 If C<Digest::MD5> is not available, it return a string with only C<0>'s.
 405
 406 =head2 The hash structure
 407
 408 The returned hash consists of 4 parts:
 409
 410 =over 4
 411
 412 =item build
 413
 414 This information is extracted from the second block that is emitted by
 415 C<perl -V>, and usually looks something like
 416
 417  Characteristics of this binary (from libperl):
 418    Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
 419    Locally applied patches:
 420          defined-or
 421          MAINT24637
 422    Built under linux
 423    Compiled at Jun 13 2005 10:44:20
 424    @INC:
 425      /usr/lib/perl5/5.8.7/i686-linux-64int
 426      /usr/lib/perl5/5.8.7
 427      /usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
 428      /usr/lib/perl5/site_perl/5.8.7
 429      /usr/lib/perl5/site_perl
 430      .
 431
 432 or
 433
 434  Characteristics of this binary (from libperl):
 435    Compile-time options: DEBUGGING MULTIPLICITY
 436                          PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
 437                          PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
 438                          PERL_USE_SAFE_PUTENV USE_ITHREADS
 439                          USE_LARGE_FILES USE_PERLIO
 440                          USE_REENTRANT_API
 441    Built under linux
 442    Compiled at Jan 28 2009 15:26:59
 443
 444 This information is not available anywhere else, including C<%Config>,
 445 but it is the information that is only known to the perl binary.
 446
 447 The extracted information is stored in 5 entries in the C<build> hash:
 448
 449 =over 4
 450
 451 =item osname
 452
 453 This is most likely the same as C<$Config{osname}>, and was the name
 454 known when perl was built. It might be different if perl was cross-compiled.
 455
 456 The default for this field, if it cannot be extracted, is to copy
 457 C<$Config{osname}>. The two may be differing in casing (OpenBSD vs openbsd).
 458
 459 =item stamp
 460
 461 This is the time string for which the perl binary was compiled. The default
 462 value is 0.
 463
 464 =item options
 465
 466 This is a hash with all the known defines as keys. The value is either 0,
 467 which means unknown or unset, or 1, which means defined.
 468
 469 =item derived
 470
 471 As some variables are reported by a different name in the output of C<perl -V>
 472 than their actual name in C<%Config>, I decided to leave the C<config> entry
 473 as close to reality as possible, and put in the entries that might have been
 474 guessed by the printed output in a separate block.
 475
 476 =item patches
 477
 478 This is a list of optionally locally applied patches. Default is an empty list.
 479
 480 =back
 481
 482 =item environment
 483
 484 By default this hash is only filled with the environment variables
 485 out of %ENV that start with C<PERL>, but you can pass the C<env> option
 486 to myconfig to get more
 487
 488  my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
 489  my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);
 490
 491 =item config
 492
 493 This hash is filled with the variables that C<perl -V> fills its report
 494 with, and it has the same variables that C<Config::myconfig> returns
 495 from C<%Config>.
 496
 497 =item inc
 498
 499 This is the list of default @INC.
 500
 501 =back
 502
 503 =head1 REASONING
 504
 505 This module was written to be able to return the configuration for the
 506 currently used perl as deeply as needed for the CPANTESTERS framework.
 507 Up until now they used the output of myconfig as a single text blob,
 508 and so it was missing the vital binary characteristics of the running
 509 perl and the optional applied patches.
 510
 511 =head1 BUGS
 512
 513 Please feedback what is wrong
 514
 515 =head1 TODO
 516
 517  * Implement retrieval functions/methods
 518  * Documentation
 519  * Error checking
 520  * Tests
 521
 522 =head1 AUTHOR
 523
 524 H.Merijn Brand <h.m.brand@xs4all.nl>
 525
 526 =head1 COPYRIGHT AND LICENSE
 527
 528 Copyright (C) 2009-2014 H.Merijn Brand
 529
 530 This library is free software; you can redistribute it and/or modify
 531 it under the same terms as Perl itself.
 532
 533 =cut