583 lines
15 KiB
Perl
583 lines
15 KiB
Perl
package Config::Perl::V;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Config;
|
|
use Exporter;
|
|
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
|
|
$VERSION = "0.36";
|
|
@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_PERL_INTERNAL_RAND_SEED
|
|
NO_PERL_RAND_SEED
|
|
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_RC_STACK
|
|
PERL_RELOCATABLE_INCPUSH
|
|
PERL_USE_DEVEL
|
|
PERL_USE_SAFE_PUTENV
|
|
PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES
|
|
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
|
|
USE_THREAD_SAFE_LOCALE
|
|
|
|
DEBUG_LEAKING_SCALARS
|
|
DEBUG_LEAKING_SCALARS_FORK_DUMP
|
|
DECCRTL_SOCKETS
|
|
FAKE_THREADS
|
|
FCRYPT
|
|
HAS_TIMES
|
|
HAVE_INTERP_INTERN
|
|
MULTIPLICITY
|
|
MYMALLOC
|
|
NO_HASH_SEED
|
|
PERL_DEBUG_READONLY_COW
|
|
PERL_DEBUG_READONLY_OPS
|
|
PERL_GLOBAL_STRUCT
|
|
PERL_GLOBAL_STRUCT_PRIVATE
|
|
PERL_HASH_NO_SBOX32
|
|
PERL_HASH_USE_SBOX32
|
|
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;
|
|
}
|
|
|
|
my %kv;
|
|
if ($pv =~ m{\S,? (?:osvers|archname)=}) { # attr is not the first on the line
|
|
# up to and including 5.24, a line could have multiple kv pairs
|
|
%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)? # optional separator (5.8.x reports did
|
|
}gx); # not have a ',' between every kv pair)
|
|
}
|
|
else {
|
|
# as of 5.25, each kv pair is listed on its own line
|
|
%kv = ($pv =~ m{^
|
|
\s+
|
|
(\w+) # key
|
|
\s*=\s* # assign
|
|
(.*?) # value
|
|
\s*,?\s*$
|
|
}gmx);
|
|
}
|
|
|
|
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;
|
|
if ($args{'env'}) {
|
|
$env{$_} = $ENV{$_} for 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 <h.m.brand@xs4all.nl>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Copyright (C) 2009-2023 H.Merijn Brand
|
|
|
|
This library is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself.
|
|
|
|
=cut
|