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