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