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