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