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