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