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