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_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     #y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
 277     my $pv = qx[$^X -V];
 278        $pv =~ s{.*?\n\n}{}s;
 279        $pv =~ s{\n(?:  \s+|\t\s*)}{ }g;
 280
 281     #print $pv;
 282
 283     my $build = { %empty_build };
 284     $pv =~ m{^\s+Built under (.*)}m                and $build->{osname} = $1;
 285     $pv =~ m{^\s+Compiled at (.*)}m                and $build->{stamp}  = $1;
 286     $pv =~ m{^\s+Locally applied patches:\s+(.*)}m and $build->{patches} = [ split m/\s+/, $1 ];
 287     $pv =~ m{^\s+Compile-time options:\s+(.*)}m    and map { $build->{options}{$_} = 1 } split m/\s+/, $1;
 288
 289     my @KEYS = keys %ENV;
 290     my %env  =
 291         map {      $_ => $ENV{$_} } grep m/^PERL/      => @KEYS;
 292     $args{env} and
 293         map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS;
 294
 295     my %config = map { $_ => $Config{$_} } @config_vars;
 296
 297     return _make_derived ({
 298         build           => $build,
 299         environment     => \%env,
 300         config          => \%config,
 301         derived         => {},
 302         inc             => \@INC,
 303         });
 304     } # myconfig
 305
 306 1;
 307
 308 __END__
 309
 310 =head1 NAME
 311
 312 Config::Perl::V - Structured data retreival of perl -V output
 313
 314 =head1 SYNOPSIS
 315
 316  use Config::Perl::V;
 317
 318  my $local_config = Config::Perl::V::myconfig ();
 319  print $local_config->{config}{osname};
 320
 321 =head1 DESCRIPTION
 322
 323 =head2 $conf = myconfig ()
 324
 325 This function will collect the data described in L<the hash structure> below,
 326 and return that as a hash reference. It optionally accepts an option to
 327 include more entries from %ENV. See L<environment> below.
 328
 329 Note that this will not work on uninstalled perls when called with
 330 C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
 331 C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
 332 known when the C<-V> information is collected.
 333
 334 =head2 $conf = plv2hash ($text [, ...])
 335
 336 Convert a sole 'perl -V' text block, or list of lines, to a complete
 337 myconfig hash.  All unknown entries are defaulted.
 338
 339 =head2 $info = summary ([$conf])
 340
 341 Return an arbitrary selection of the information. If no C<$conf> is
 342 given, C<myconfig ()> is used instead.
 343
 344 =head2 $md5 = signature ([$conf])
 345
 346 Return the MD5 of the info returned by C<summary ()> without the
 347 C<config_args> entry.
 348
 349 If C<Digest::MD5> is not available, it return a string with only C<0>'s.
 350
 351 =head2 The hash structure
 352
 353 The returned hash consists of 4 parts:
 354
 355 =over 4
 356
 357 =item build
 358
 359 This information is extracted from the second block that is emitted by
 360 C<perl -V>, and usually looks something like
 361
 362  Characteristics of this binary (from libperl):
 363    Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
 364    Locally applied patches:
 365          defined-or
 366          MAINT24637
 367    Built under linux
 368    Compiled at Jun 13 2005 10:44:20
 369    @INC:
 370      /usr/lib/perl5/5.8.7/i686-linux-64int
 371      /usr/lib/perl5/5.8.7
 372      /usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
 373      /usr/lib/perl5/site_perl/5.8.7
 374      /usr/lib/perl5/site_perl
 375      .
 376
 377 or
 378
 379  Characteristics of this binary (from libperl):
 380    Compile-time options: DEBUGGING MULTIPLICITY
 381                          PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
 382                          PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
 383                          PERL_USE_SAFE_PUTENV USE_ITHREADS
 384                          USE_LARGE_FILES USE_PERLIO
 385                          USE_REENTRANT_API
 386    Built under linux
 387    Compiled at Jan 28 2009 15:26:59
 388
 389 This information is not available anywhere else, including C<%Config>,
 390 but it is the information that is only known to the perl binary.
 391
 392 The extracted information is stored in 5 entries in the C<build> hash:
 393
 394 =over 4
 395
 396 =item osname
 397
 398 This is most likely the same as C<$Config{osname}>, and was the name
 399 known when perl was built. It might be different if perl was cross-compiled.
 400
 401 The default for this field, if it cannot be extracted, is to copy
 402 C<$Config{osname}>. The two may be differing in casing (OpenBSD vs openbsd).
 403
 404 =item stamp
 405
 406 This is the time string for which the perl binary was compiled. The default
 407 value is 0.
 408
 409 =item options
 410
 411 This is a hash with all the known defines as keys. The value is either 0,
 412 which means unknown or unset, or 1, which means defined.
 413
 414 =item derived
 415
 416 As some verables are reported by a different name in the output of C<perl -V>
 417 than their actual name in C<%Config>, I decided to leave the C<config> entry
 418 as close to reality as possible, and put in the entries that might have been
 419 guessed by the printed output in a seperate block.
 420
 421 =item patches
 422
 423 This is a list of optionally locally applied patches. Default is an empty list.
 424
 425 =back
 426
 427 =item environment
 428
 429 By default this hash is only filled with the environment variables
 430 out of %ENV that start with C<PERL>, but you can pass the C<env> option
 431 to myconfig to get more
 432
 433  my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
 434  my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);
 435
 436 =item config
 437
 438 This hash is filled with the variables that C<perl -V> fills its report
 439 with, and it has the same variables that C<Config::myconfig> returns
 440 from C<%Config>.
 441
 442 =item inc
 443
 444 This is the list of default @INC.
 445
 446 =back
 447
 448 =head1 REASONING
 449
 450 This module was written to be able to return the configuration for the
 451 currently used perl as deeply as needed for the CPANTESTERS framework.
 452 Up until now they used the output of myconfig as a single text blob,
 453 and so it was missing the vital binary characteristics of the running
 454 perl and the optional applied patches.
 455
 456 =head1 BUGS
 457
 458 Please feedback what is wrong
 459
 460 =head1 TODO
 461
 462  * Implement retrieval functions/methods
 463  * Documentation
 464  * Error checking
 465  * Tests
 466
 467 =head1 AUTHOR
 468
 469 H.Merijn Brand <h.m.brand@xs4all.nl>
 470
 471 =head1 COPYRIGHT AND LICENSE
 472
 473 Copyright (C) 2009-2010 H.Merijn Brand
 474
 475 This library is free software; you can redistribute it and/or modify
 476 it under the same terms as Perl itself.
 477
 478 =cut