V.pm

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