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