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