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