#!/pro/bin/perl

package Config::Perl::V;

use strict;
use warnings;

use Config;
use Exporter;
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
$VERSION = "0.17";
@ISA = ("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 1661 S_Internals_V ()
# perl.h line 4664 (second block),
my %BTD = map { $_ => 0 } qw(

DEBUGGING
NO_MATHOMS
PERL_DISABLE_PMC
PERL_DONT_CREATE_GVSV
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_PRESERVE_IVUV
PERL_RELOCATABLE_INCPUSH
PERL_USE_DEVEL
PERL_USE_SAFE_PUTENV
UNLINK_ALL_VERSIONS
USE_ATTRIBUTES_FOR_PERLIO
USE_FAST_STDIO
USE_LOCALE
USE_PERL_ATOF
USE_SITECUSTOMIZE

DEBUG_LEAKING_SCALARS
DEBUG_LEAKING_SCALARS_FORK_DUMP
DECCRTL_SOCKETS
FAKE_THREADS
FCRYPT
HAS_TIMES
MULTIPLICITY
MYMALLOC
PERLIO_LAYERS
PERL_DEBUG_READONLY_OPS
PERL_GLOBAL_STRUCT
PERL_IMPLICIT_CONTEXT
PERL_IMPLICIT_SYS
PERL_MAD
PERL_MICRO
PERL_NEED_APPCTX
PERL_NEED_TIMESBASE
PERL_OLD_COPY_ON_WRITE
PERL_NEW_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_LONG_DOUBLE
USE_PERLIO
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 (first block)
# 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 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;
} # _make_derived

sub plv2hash
{
my %config;
for (split m/\n+/ => join "\n", @_) {

if (s/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)//) {
$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";
next;
}

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

my %kv = m/\G,?\s*([^=]+)=('[^']+?'|\S+)/gc;

while (my ($k, $v) = each %kv) {
$k =~ s/\s+$//;
$v =~ s/,$//;
$v =~ m/^'(.*)'$/ and $v = $1;
$v =~ s/^\s+//;
$v =~ s/\s+$//;
$config{$k} = $v;
}
}
my $build = { %empty_build };
$build->{osname} = $config{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} 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
);
$info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}};

return \%info;
} # summary

sub signature
{
eval { require Digest::MD5 };
$@ and return "00000000000000000000000000000000";

my $conf = shift || summary ();
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 $pv = qx[$^X -V];
$pv =~ s{.*?\n\n}{}s;
$pv =~ s{\n(?: \s+|\t\s*)}{\0}g;

# print STDERR $pv;

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

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

1;

__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
.

or

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 <[email protected]>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009-2013 H.Merijn Brand

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

=cut