22

✏️ Editing: V.pm

package Config::Perl::V;

use strict;
use warnings;

use Config;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
$VERSION     = "0.30";
@ISA         = qw( Exporter );
@EXPORT_OK   = qw( plv2hash summary myconfig signature );
%EXPORT_TAGS = (
    all => [ @EXPORT_OK  ],
    sig => [ "signature" ],
    );

#  Characteristics of this binary (from libperl):
#    Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
#                          USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO

# The list are as the perl binary has stored it in PL_bincompat_options
#  search for it in
#   perl.c line 1643 S_Internals_V ()
#     perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c
#   perl.h line 4566 PL_bincompat_options
#     perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h
my %BTD = map { $_ => 0 } qw(

DEBUGGING
    NO_HASH_SEED
    NO_MATHOMS
    NO_TAINT_SUPPORT
    PERL_BOOL_AS_CHAR
    PERL_COPY_ON_WRITE
    PERL_DISABLE_PMC
    PERL_DONT_CREATE_GVSV
    PERL_EXTERNAL_GLOB
    PERL_HASH_FUNC_DJB2
    PERL_HASH_FUNC_MURMUR3
    PERL_HASH_FUNC_ONE_AT_A_TIME
    PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
    PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
    PERL_HASH_FUNC_SDBM
    PERL_HASH_FUNC_SIPHASH
    PERL_HASH_FUNC_SUPERFAST
    PERL_IS_MINIPERL
    PERL_MALLOC_WRAP
    PERL_MEM_LOG
    PERL_MEM_LOG_ENV
    PERL_MEM_LOG_ENV_FD
    PERL_MEM_LOG_NOIMPL
    PERL_MEM_LOG_STDERR
    PERL_MEM_LOG_TIMESTAMP
    PERL_NEW_COPY_ON_WRITE
    PERL_OP_PARENT
    PERL_PERTURB_KEYS_DETERMINISTIC
    PERL_PERTURB_KEYS_DISABLED
    PERL_PERTURB_KEYS_RANDOM
    PERL_PRESERVE_IVUV
    PERL_RELOCATABLE_INCPUSH
    PERL_USE_DEVEL
    PERL_USE_SAFE_PUTENV
    SILENT_NO_TAINT_SUPPORT
    UNLINK_ALL_VERSIONS
    USE_ATTRIBUTES_FOR_PERLIO
    USE_FAST_STDIO
    USE_HASH_SEED_EXPLICIT
    USE_LOCALE
    USE_LOCALE_CTYPE
    USE_NO_REGISTRY
    USE_PERL_ATOF
    USE_SITECUSTOMIZE

DEBUG_LEAKING_SCALARS
    DEBUG_LEAKING_SCALARS_FORK_DUMP
    DECCRTL_SOCKETS
    FAKE_THREADS
    FCRYPT
    HAS_TIMES
    HAVE_INTERP_INTERN
    MULTIPLICITY
    MYMALLOC
    PERL_DEBUG_READONLY_COW
    PERL_DEBUG_READONLY_OPS
    PERL_GLOBAL_STRUCT
    PERL_GLOBAL_STRUCT_PRIVATE
    PERL_IMPLICIT_CONTEXT
    PERL_IMPLICIT_SYS
    PERLIO_LAYERS
    PERL_MAD
    PERL_MICRO
    PERL_NEED_APPCTX
    PERL_NEED_TIMESBASE
    PERL_OLD_COPY_ON_WRITE
    PERL_POISON
    PERL_SAWAMPERSAND
    PERL_TRACK_MEMPOOL
    PERL_USES_PL_PIDSTATUS
    PL_OP_SLAB_ALLOC
    THREADS_HAVE_PIDS
    USE_64_BIT_ALL
    USE_64_BIT_INT
    USE_IEEE
    USE_ITHREADS
    USE_LARGE_FILES
    USE_LOCALE_COLLATE
    USE_LOCALE_NUMERIC
    USE_LOCALE_TIME
    USE_LONG_DOUBLE
    USE_PERLIO
    USE_QUADMATH
    USE_REENTRANT_API
    USE_SFIO
    USE_SOCKS
    VMS_DO_SOCKETS
    VMS_SHORTEN_LONG_SYMBOLS
    VMS_SYMBOL_CASE_AS_IS
    );

# These are all the keys that are
# 1. Always present in %Config - lib/Config.pm #87 tie %Config
# 2. Reported by 'perl -V' (the rest)
my @config_vars = qw(

api_subversion
    api_version
    api_versionstring
    archlibexp
    dont_use_nlink
    d_readlink
    d_symlink
    exe_ext
    inc_version_list
    ldlibpthname
    patchlevel
    path_sep
    perl_patchlevel
    privlibexp
    scriptdir
    sitearchexp
    sitelibexp
    subversion
    usevendorprefix
    version

git_commit_id
    git_describe
    git_branch
    git_uncommitted_changes
    git_commit_id_title
    git_snapshot_date

package revision version_patchlevel_string

osname osvers archname
    myuname
    config_args
    hint useposix d_sigaction
    useithreads usemultiplicity
    useperlio d_sfio uselargefiles usesocks
    use64bitint use64bitall uselongdouble
    usemymalloc default_inc_excludes_dot bincompat5005

cc ccflags
    optimize
    cppflags
    ccversion gccversion gccosandvers
    intsize longsize ptrsize doublesize byteorder
    d_longlong longlongsize d_longdbl longdblsize
    ivtype ivsize nvtype nvsize lseektype lseeksize
    alignbytes prototype

ld ldflags
    libpth
    libs
    perllibs
    libc so useshrplib libperl
    gnulibc_version

dlsrc dlext d_dlsymun ccdlflags
    cccdlflags lddlflags
    );

my %empty_build = (
    osname  => "",
    stamp   => 0,
    options => { %BTD },
    patches => [],
    );

sub _make_derived {
    my $conf = shift;

for ( [ lseektype		=> "Off_t"	],
	  [ myuname		=> "uname"	],
	  [ perl_patchlevel	=> "patch"	],
	  ) {
	my ($official, $derived) = @$_;
	$conf->{config}{$derived}  ||= $conf->{config}{$official};
	$conf->{config}{$official} ||= $conf->{config}{$derived};
	$conf->{derived}{$derived} = delete $conf->{config}{$derived};
	}

if (exists $conf->{config}{version_patchlevel_string} &&
       !exists $conf->{config}{api_version}) {
	my $vps = $conf->{config}{version_patchlevel_string};
	$vps =~ s{\b revision   \s+ (\S+) }{}x and
	    $conf->{config}{revision}        ||= $1;

$vps =~ s{\b version    \s+ (\S+) }{}x and
	    $conf->{config}{api_version}     ||= $1;
	$vps =~ s{\b subversion \s+ (\S+) }{}x and
	    $conf->{config}{subversion}      ||= $1;
	$vps =~ s{\b patch      \s+ (\S+) }{}x and
	    $conf->{config}{perl_patchlevel} ||= $1;
	}

($conf->{config}{version_patchlevel_string} ||= join " ",
	map  { ($_, $conf->{config}{$_} ) }
	grep {      $conf->{config}{$_}   }
	qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//;

$conf->{config}{perl_patchlevel}  ||= "";	# 0 is not a valid patchlevel

if ($conf->{config}{perl_patchlevel} =~ m{^git\w*-([^-]+)}i) {
	$conf->{config}{git_branch}   ||= $1;
	$conf->{config}{git_describe} ||= $conf->{config}{perl_patchlevel};
	}

$conf->{config}{$_} ||= "undef" for grep m/^(?:use|def)/ => @config_vars;

$conf;
    } # _make_derived

sub plv2hash {
    my %config;

my $pv = join "\n" => @_;

if ($pv =~ m/^Summary of my\s+(\S+)\s+$\s*(.*?)\s*$/m) {
	$config{"package"} = $1;
	my $rev = $2;
	$rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1;
	$rev and $config{version_patchlevel_string} = $rev;
	my ($rel) = $config{"package"} =~ m{perl(\d)};
	my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
	defined $vers && defined $subvers && defined $rel and
	    $config{version} = "$rel.$vers.$subvers";
	}

if ($pv =~ m/^\s+(Snapshot of:)\s+(\S+)/) {
	$config{git_commit_id_title} = $1;
	$config{git_commit_id}       = $2;
	}

# these are always last on line and can have multiple quotation styles
    for my $k (qw( ccflags ldflags lddlflags )) {
	$pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next;
	my $v = $1;
	$v =~ s/\s*,\s*$//;
	$v =~ s/^(['"])(.*)\1$/$2/;
	$config{$k} = $v;
	}

if (my %kv = ($pv =~ m{\b
	    (\w+)		# key
	    \s*=		# assign
	    ( '\s*[^']*?\s*'	# quoted value
	    | \S+[^=]*?\s*\n	# unquoted running till end of line
	    | \S+		# unquoted value
	    | \s*\n		# empty
	    )
	    (?:,?\s+|\s*\n)?	# separator (5.8.x reports did not have a ','
	    }gx)) {		# between every kv pair

while (my ($k, $v) = each %kv) {
	    $k =~ s/\s+$//;
	    $v =~ s/\s*\n\z//;
	    $v =~ s/,$//;
	    $v =~ m/^'(.*)'$/ and $v = $1;
	    $v =~ s/\s+$//;
	    $config{$k} = $v;
	    }
	}

my $build = { %empty_build };

$pv =~ m{^\s+Compiled at\s+(.*)}m
	and $build->{stamp}   = $1;
    $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms
	and $build->{patches} = [ split m/\n+\s*/, $1 ];
    $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms
	and map { $build->{options}{$_} = 1 } split m/\s+|\n/ => $1;

$build->{osname} = $config{osname};
    $pv =~ m{^\s+Built under\s+(.*)}m
	and $build->{osname}  = $1;
    $config{osname} ||= $build->{osname};

return _make_derived ({
	build		=> $build,
	environment	=> {},
	config		=> \%config,
	derived		=> {},
	inc		=> [],
	});
    } # plv2hash

sub summary {
    my $conf = shift || myconfig ();
    ref $conf eq "HASH"
    && exists $conf->{config}
    && exists $conf->{build}
    && ref $conf->{config} eq "HASH"
    && ref $conf->{build}  eq "HASH" or return;

my %info = map {
	exists $conf->{config}{$_} ? ( $_ => $conf->{config}{$_} ) : () }
	qw( archname osname osvers revision patchlevel subversion version
	    cc ccversion gccversion config_args inc_version_list
	    d_longdbl d_longlong use64bitall use64bitint useithreads
	    uselongdouble usemultiplicity usemymalloc useperlio useshrplib 
	    doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
	    default_inc_excludes_dot
	    );
    $info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}};

return \%info;
    } # summary

sub signature {
    my $no_md5 = "0" x 32;
    my $conf = summary (shift) or return $no_md5;

eval { require Digest::MD5 };
    $@ and return $no_md5;

$conf->{cc} =~ s{.*\bccache\s+}{};
    $conf->{cc} =~ s{.*[/\\]}{};

delete $conf->{config_args};
    return Digest::MD5::md5_hex (join "\xFF" => map {
	"$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
	} sort keys %$conf);
    } # signature

sub myconfig {
    my $args = shift;
    my %args = ref $args eq "HASH"  ? %$args :
               ref $args eq "ARRAY" ? @$args : ();

my $build = { %empty_build };

# 5.14.0 and later provide all the information without shelling out
    my $stamp = eval { Config::compile_date () };
    if (defined $stamp) {
	$stamp =~ s/^Compiled at //;
	$build->{osname}      = $^O;
	$build->{stamp}       = $stamp;
	$build->{patches}     =     [ Config::local_patches () ];
	$build->{options}{$_} = 1 for Config::bincompat_options (),
				      Config::non_bincompat_options ();
	}
    else {
	#y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
	my $cnf = plv2hash (qx[$^X -V]);

$build->{$_} = $cnf->{build}{$_} for qw( osname stamp patches options );
	}

my @KEYS = keys %ENV;
    my %env  =
	map {      $_ => $ENV{$_} } grep m/^PERL/      => @KEYS;
    $args{env} and
	map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS;

my %config = map { $_ => $Config{$_} } @config_vars;

return _make_derived ({
	build		=> $build,
	environment	=> \%env,
	config		=> \%config,
	derived		=> {},
	inc		=> \@INC,
	});
    } # myconfig

__END__

=head1 NAME

Config::Perl::V - Structured data retrieval of perl -V output

=head1 SYNOPSIS

use Config::Perl::V;

my $local_config = Config::Perl::V::myconfig ();
 print $local_config->{config}{osname};

=head1 DESCRIPTION

=head2 $conf = myconfig ()

This function will collect the data described in L<the hash structure> below,
and return that as a hash reference. It optionally accepts an option to
include more entries from %ENV. See L<environment> below.

Note that this will not work on uninstalled perls when called with
C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
known when the C<-V> information is collected.

=head2 $conf = plv2hash ($text [, ...])

Convert a sole 'perl -V' text block, or list of lines, to a complete
myconfig hash.  All unknown entries are defaulted.

=head2 $info = summary ([$conf])

Return an arbitrary selection of the information. If no C<$conf> is
given, C<myconfig ()> is used instead.

=head2 $md5 = signature ([$conf])

Return the MD5 of the info returned by C<summary ()> without the
C<config_args> entry.

If C<Digest::MD5> is not available, it return a string with only C<0>'s.

=head2 The hash structure

The returned hash consists of 4 parts:

=over 4

=item build

This information is extracted from the second block that is emitted by
C<perl -V>, and usually looks something like

Characteristics of this binary (from libperl):
   Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
   Locally applied patches:
	 defined-or
	 MAINT24637
   Built under linux
   Compiled at Jun 13 2005 10:44:20
   @INC:
     /usr/lib/perl5/5.8.7/i686-linux-64int
     /usr/lib/perl5/5.8.7
     /usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
     /usr/lib/perl5/site_perl/5.8.7
     /usr/lib/perl5/site_perl
     .

Characteristics of this binary (from libperl):
   Compile-time options: DEBUGGING MULTIPLICITY
			 PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
			 PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
			 PERL_USE_SAFE_PUTENV USE_ITHREADS
			 USE_LARGE_FILES USE_PERLIO
			 USE_REENTRANT_API
   Built under linux
   Compiled at Jan 28 2009 15:26:59

This information is not available anywhere else, including C<%Config>,
but it is the information that is only known to the perl binary.

The extracted information is stored in 5 entries in the C<build> hash:

=over 4

=item osname

This is most likely the same as C<$Config{osname}>, and was the name
known when perl was built. It might be different if perl was cross-compiled.

The default for this field, if it cannot be extracted, is to copy
C<$Config{osname}>. The two may be differing in casing (OpenBSD vs openbsd).

=item stamp

This is the time string for which the perl binary was compiled. The default
value is 0.

=item options

This is a hash with all the known defines as keys. The value is either 0,
which means unknown or unset, or 1, which means defined.

=item derived

As some variables are reported by a different name in the output of C<perl -V>
than their actual name in C<%Config>, I decided to leave the C<config> entry
as close to reality as possible, and put in the entries that might have been
guessed by the printed output in a separate block.

=item patches

This is a list of optionally locally applied patches. Default is an empty list.

=back

=item environment

By default this hash is only filled with the environment variables
out of %ENV that start with C<PERL>, but you can pass the C<env> option
to myconfig to get more

my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
 my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);

=item config

This hash is filled with the variables that C<perl -V> fills its report
with, and it has the same variables that C<Config::myconfig> returns
from C<%Config>.

=item inc

This is the list of default @INC.

=back

=head1 REASONING

This module was written to be able to return the configuration for the
currently used perl as deeply as needed for the CPANTESTERS framework.
Up until now they used the output of myconfig as a single text blob,
and so it was missing the vital binary characteristics of the running
perl and the optional applied patches.

=head1 BUGS

Please feedback what is wrong

=head1 TODO

* Implement retrieval functions/methods
 * Documentation
 * Error checking
 * Tests

=head1 AUTHOR

H.Merijn Brand <h.m.brand@xs4all.nl>

=head1 COPYRIGHT AND LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

MR SKB