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