xref: /openbsd/gnu/usr.bin/perl/cpan/Config-Perl-V/V.pm (revision 4cfece93) 
1package Config::Perl::V;
2
3use strict;
4use warnings;
5
6use Config;
7use Exporter;
8use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
9$VERSION     = "0.32";
10@ISA         = qw( Exporter );
11@EXPORT_OK   = qw( plv2hash summary myconfig signature );
12%EXPORT_TAGS = (
13    all => [ @EXPORT_OK  ],
14    sig => [ "signature" ],
15    );
16
17#  Characteristics of this binary (from libperl):
18#    Compile-time options: DEBUGGING PERL_DONT_CREATE_GVSV PERL_MALLOC_WRAP
19#                          USE_64_BIT_INT USE_LARGE_FILES USE_PERLIO
20
21# The list are as the perl binary has stored it in PL_bincompat_options
22#  search for it in
23#   perl.c line 1643 S_Internals_V ()
24#     perl -ne'(/^S_Internals_V/../^}/)&&s/^\s+"( .*)"/$1/ and print' perl.c
25#   perl.h line 4566 PL_bincompat_options
26#     perl -ne'(/^\w.*PL_bincompat/../^\w}/)&&s/^\s+"( .*)"/$1/ and print' perl.h
27my %BTD = map { $_ => 0 } qw(
28
29    DEBUGGING
30    NO_HASH_SEED
31    NO_MATHOMS
32    NO_TAINT_SUPPORT
33    PERL_BOOL_AS_CHAR
34    PERL_COPY_ON_WRITE
35    PERL_DISABLE_PMC
36    PERL_DONT_CREATE_GVSV
37    PERL_EXTERNAL_GLOB
38    PERL_HASH_FUNC_DJB2
39    PERL_HASH_FUNC_MURMUR3
40    PERL_HASH_FUNC_ONE_AT_A_TIME
41    PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
42    PERL_HASH_FUNC_ONE_AT_A_TIME_OLD
43    PERL_HASH_FUNC_SDBM
44    PERL_HASH_FUNC_SIPHASH
45    PERL_HASH_FUNC_SUPERFAST
46    PERL_IS_MINIPERL
47    PERL_MALLOC_WRAP
48    PERL_MEM_LOG
49    PERL_MEM_LOG_ENV
50    PERL_MEM_LOG_ENV_FD
51    PERL_MEM_LOG_NOIMPL
52    PERL_MEM_LOG_STDERR
53    PERL_MEM_LOG_TIMESTAMP
54    PERL_NEW_COPY_ON_WRITE
55    PERL_OP_PARENT
56    PERL_PERTURB_KEYS_DETERMINISTIC
57    PERL_PERTURB_KEYS_DISABLED
58    PERL_PERTURB_KEYS_RANDOM
59    PERL_PRESERVE_IVUV
60    PERL_RELOCATABLE_INCPUSH
61    PERL_USE_DEVEL
62    PERL_USE_SAFE_PUTENV
63    SILENT_NO_TAINT_SUPPORT
64    UNLINK_ALL_VERSIONS
65    USE_ATTRIBUTES_FOR_PERLIO
66    USE_FAST_STDIO
67    USE_HASH_SEED_EXPLICIT
68    USE_LOCALE
69    USE_LOCALE_CTYPE
70    USE_NO_REGISTRY
71    USE_PERL_ATOF
72    USE_SITECUSTOMIZE
73    USE_THREAD_SAFE_LOCALE
74
75    DEBUG_LEAKING_SCALARS
76    DEBUG_LEAKING_SCALARS_FORK_DUMP
77    DECCRTL_SOCKETS
78    FAKE_THREADS
79    FCRYPT
80    HAS_TIMES
81    HAVE_INTERP_INTERN
82    MULTIPLICITY
83    MYMALLOC
84    PERL_DEBUG_READONLY_COW
85    PERL_DEBUG_READONLY_OPS
86    PERL_GLOBAL_STRUCT
87    PERL_GLOBAL_STRUCT_PRIVATE
88    PERL_IMPLICIT_CONTEXT
89    PERL_IMPLICIT_SYS
90    PERLIO_LAYERS
91    PERL_MAD
92    PERL_MICRO
93    PERL_NEED_APPCTX
94    PERL_NEED_TIMESBASE
95    PERL_OLD_COPY_ON_WRITE
96    PERL_POISON
97    PERL_SAWAMPERSAND
98    PERL_TRACK_MEMPOOL
99    PERL_USES_PL_PIDSTATUS
100    PL_OP_SLAB_ALLOC
101    THREADS_HAVE_PIDS
102    USE_64_BIT_ALL
103    USE_64_BIT_INT
104    USE_IEEE
105    USE_ITHREADS
106    USE_LARGE_FILES
107    USE_LOCALE_COLLATE
108    USE_LOCALE_NUMERIC
109    USE_LOCALE_TIME
110    USE_LONG_DOUBLE
111    USE_PERLIO
112    USE_QUADMATH
113    USE_REENTRANT_API
114    USE_SFIO
115    USE_SOCKS
116    VMS_DO_SOCKETS
117    VMS_SHORTEN_LONG_SYMBOLS
118    VMS_SYMBOL_CASE_AS_IS
119    );
120
121# These are all the keys that are
122# 1. Always present in %Config - lib/Config.pm #87 tie %Config
123# 2. Reported by 'perl -V' (the rest)
124my @config_vars = qw(
125
126    api_subversion
127    api_version
128    api_versionstring
129    archlibexp
130    dont_use_nlink
131    d_readlink
132    d_symlink
133    exe_ext
134    inc_version_list
135    ldlibpthname
136    patchlevel
137    path_sep
138    perl_patchlevel
139    privlibexp
140    scriptdir
141    sitearchexp
142    sitelibexp
143    subversion
144    usevendorprefix
145    version
146
147    git_commit_id
148    git_describe
149    git_branch
150    git_uncommitted_changes
151    git_commit_id_title
152    git_snapshot_date
153
154    package revision version_patchlevel_string
155
156    osname osvers archname
157    myuname
158    config_args
159    hint useposix d_sigaction
160    useithreads usemultiplicity
161    useperlio d_sfio uselargefiles usesocks
162    use64bitint use64bitall uselongdouble
163    usemymalloc default_inc_excludes_dot bincompat5005
164
165    cc ccflags
166    optimize
167    cppflags
168    ccversion gccversion gccosandvers
169    intsize longsize ptrsize doublesize byteorder
170    d_longlong longlongsize d_longdbl longdblsize
171    ivtype ivsize nvtype nvsize lseektype lseeksize
172    alignbytes prototype
173
174    ld ldflags
175    libpth
176    libs
177    perllibs
178    libc so useshrplib libperl
179    gnulibc_version
180
181    dlsrc dlext d_dlsymun ccdlflags
182    cccdlflags lddlflags
183    );
184
185my %empty_build = (
186    osname  => "",
187    stamp   => 0,
188    options => { %BTD },
189    patches => [],
190    );
191
192sub _make_derived {
193    my $conf = shift;
194
195    for ( [ lseektype		=> "Off_t"	],
196	  [ myuname		=> "uname"	],
197	  [ perl_patchlevel	=> "patch"	],
198	  ) {
199	my ($official, $derived) = @$_;
200	$conf->{config}{$derived}  ||= $conf->{config}{$official};
201	$conf->{config}{$official} ||= $conf->{config}{$derived};
202	$conf->{derived}{$derived} = delete $conf->{config}{$derived};
203	}
204
205    if (exists $conf->{config}{version_patchlevel_string} &&
206       !exists $conf->{config}{api_version}) {
207	my $vps = $conf->{config}{version_patchlevel_string};
208	$vps =~ s{\b revision   \s+ (\S+) }{}x and
209	    $conf->{config}{revision}        ||= $1;
210
211	$vps =~ s{\b version    \s+ (\S+) }{}x and
212	    $conf->{config}{api_version}     ||= $1;
213	$vps =~ s{\b subversion \s+ (\S+) }{}x and
214	    $conf->{config}{subversion}      ||= $1;
215	$vps =~ s{\b patch      \s+ (\S+) }{}x and
216	    $conf->{config}{perl_patchlevel} ||= $1;
217	}
218
219    ($conf->{config}{version_patchlevel_string} ||= join " ",
220	map  { ($_, $conf->{config}{$_} ) }
221	grep {      $conf->{config}{$_}   }
222	qw( api_version subversion perl_patchlevel )) =~ s/\bperl_//;
223
224    $conf->{config}{perl_patchlevel}  ||= "";	# 0 is not a valid patchlevel
225
226    if ($conf->{config}{perl_patchlevel} =~ m{^git\w*-([^-]+)}i) {
227	$conf->{config}{git_branch}   ||= $1;
228	$conf->{config}{git_describe} ||= $conf->{config}{perl_patchlevel};
229	}
230
231    $conf->{config}{$_} ||= "undef" for grep m/^(?:use|def)/ => @config_vars;
232
233    $conf;
234    } # _make_derived
235
236sub plv2hash {
237    my %config;
238
239    my $pv = join "\n" => @_;
240
241    if ($pv =~ m/^Summary of my\s+(\S+)\s+\(\s*(.*?)\s*\)/m) {
242	$config{"package"} = $1;
243	my $rev = $2;
244	$rev =~ s/^ revision \s+ (\S+) \s*//x and $config{revision} = $1;
245	$rev and $config{version_patchlevel_string} = $rev;
246	my ($rel) = $config{"package"} =~ m{perl(\d)};
247	my ($vers, $subvers) = $rev =~ m{version\s+(\d+)\s+subversion\s+(\d+)};
248	defined $vers && defined $subvers && defined $rel and
249	    $config{version} = "$rel.$vers.$subvers";
250	}
251
252    if ($pv =~ m/^\s+(Snapshot of:)\s+(\S+)/) {
253	$config{git_commit_id_title} = $1;
254	$config{git_commit_id}       = $2;
255	}
256
257    # these are always last on line and can have multiple quotation styles
258    for my $k (qw( ccflags ldflags lddlflags )) {
259	$pv =~ s{, \s* $k \s*=\s* (.*) \s*$}{}mx or next;
260	my $v = $1;
261	$v =~ s/\s*,\s*$//;
262	$v =~ s/^(['"])(.*)\1$/$2/;
263	$config{$k} = $v;
264	}
265
266    if (my %kv = ($pv =~ m{\b
267	    (\w+)		# key
268	    \s*=		# assign
269	    ( '\s*[^']*?\s*'	# quoted value
270	    | \S+[^=]*?\s*\n	# unquoted running till end of line
271	    | \S+		# unquoted value
272	    | \s*\n		# empty
273	    )
274	    (?:,?\s+|\s*\n)?	# separator (5.8.x reports did not have a ','
275	    }gx)) {		# between every kv pair
276
277	while (my ($k, $v) = each %kv) {
278	    $k =~ s/\s+$//;
279	    $v =~ s/\s*\n\z//;
280	    $v =~ s/,$//;
281	    $v =~ m/^'(.*)'$/ and $v = $1;
282	    $v =~ s/\s+$//;
283	    $config{$k} = $v;
284	    }
285	}
286
287    my $build = { %empty_build };
288
289    $pv =~ m{^\s+Compiled at\s+(.*)}m
290	and $build->{stamp}   = $1;
291    $pv =~ m{^\s+Locally applied patches:(?:\s+|\n)(.*?)(?:[\s\n]+Buil[td] under)}ms
292	and $build->{patches} = [ split m/\n+\s*/, $1 ];
293    $pv =~ m{^\s+Compile-time options:(?:\s+|\n)(.*?)(?:[\s\n]+(?:Locally applied|Buil[td] under))}ms
294	and map { $build->{options}{$_} = 1 } split m/\s+|\n/ => $1;
295
296    $build->{osname} = $config{osname};
297    $pv =~ m{^\s+Built under\s+(.*)}m
298	and $build->{osname}  = $1;
299    $config{osname} ||= $build->{osname};
300
301    return _make_derived ({
302	build		=> $build,
303	environment	=> {},
304	config		=> \%config,
305	derived		=> {},
306	inc		=> [],
307	});
308    } # plv2hash
309
310sub summary {
311    my $conf = shift || myconfig ();
312    ref $conf eq "HASH"
313    && exists $conf->{config}
314    && exists $conf->{build}
315    && ref $conf->{config} eq "HASH"
316    && ref $conf->{build}  eq "HASH" or return;
317
318    my %info = map {
319	exists $conf->{config}{$_} ? ( $_ => $conf->{config}{$_} ) : () }
320	qw( archname osname osvers revision patchlevel subversion version
321	    cc ccversion gccversion config_args inc_version_list
322	    d_longdbl d_longlong use64bitall use64bitint useithreads
323	    uselongdouble usemultiplicity usemymalloc useperlio useshrplib
324	    doublesize intsize ivsize nvsize longdblsize longlongsize lseeksize
325	    default_inc_excludes_dot
326	    );
327    $info{$_}++ for grep { $conf->{build}{options}{$_} } keys %{$conf->{build}{options}};
328
329    return \%info;
330    } # summary
331
332sub signature {
333    my $no_md5 = "0" x 32;
334    my $conf = summary (shift) or return $no_md5;
335
336    eval { require Digest::MD5 };
337    $@ and return $no_md5;
338
339    $conf->{cc} =~ s{.*\bccache\s+}{};
340    $conf->{cc} =~ s{.*[/\\]}{};
341
342    delete $conf->{config_args};
343    return Digest::MD5::md5_hex (join "\xFF" => map {
344	"$_=".(defined $conf->{$_} ? $conf->{$_} : "\xFE");
345	} sort keys %$conf);
346    } # signature
347
348sub myconfig {
349    my $args = shift;
350    my %args = ref $args eq "HASH"  ? %$args :
351               ref $args eq "ARRAY" ? @$args : ();
352
353    my $build = { %empty_build };
354
355    # 5.14.0 and later provide all the information without shelling out
356    my $stamp = eval { Config::compile_date () };
357    if (defined $stamp) {
358	$stamp =~ s/^Compiled at //;
359	$build->{osname}      = $^O;
360	$build->{stamp}       = $stamp;
361	$build->{patches}     =     [ Config::local_patches () ];
362	$build->{options}{$_} = 1 for Config::bincompat_options (),
363				      Config::non_bincompat_options ();
364	}
365    else {
366	#y $pv = qx[$^X -e"sub Config::myconfig{};" -V];
367	my $cnf = plv2hash (qx[$^X -V]);
368
369	$build->{$_} = $cnf->{build}{$_} for qw( osname stamp patches options );
370	}
371
372    my @KEYS = keys %ENV;
373    my %env  =
374	map {      $_ => $ENV{$_} } grep m/^PERL/      => @KEYS;
375    $args{env} and
376	map { $env{$_} = $ENV{$_} } grep m{$args{env}} => @KEYS;
377
378    my %config = map { $_ => $Config{$_} } @config_vars;
379
380    return _make_derived ({
381	build		=> $build,
382	environment	=> \%env,
383	config		=> \%config,
384	derived		=> {},
385	inc		=> \@INC,
386	});
387    } # myconfig
388
3891;
390
391__END__
392
393=head1 NAME
394
395Config::Perl::V - Structured data retrieval of perl -V output
396
397=head1 SYNOPSIS
398
399 use Config::Perl::V;
400
401 my $local_config = Config::Perl::V::myconfig ();
402 print $local_config->{config}{osname};
403
404=head1 DESCRIPTION
405
406=head2 $conf = myconfig ()
407
408This function will collect the data described in L</"The hash structure"> below,
409and return that as a hash reference. It optionally accepts an option to
410include more entries from %ENV. See L</environment> below.
411
412Note that this will not work on uninstalled perls when called with
413C<-I/path/to/uninstalled/perl/lib>, but it works when that path is in
414C<$PERL5LIB> or in C<$PERL5OPT>, as paths passed using C<-I> are not
415known when the C<-V> information is collected.
416
417=head2 $conf = plv2hash ($text [, ...])
418
419Convert a sole 'perl -V' text block, or list of lines, to a complete
420myconfig hash.  All unknown entries are defaulted.
421
422=head2 $info = summary ([$conf])
423
424Return an arbitrary selection of the information. If no C<$conf> is
425given, C<myconfig ()> is used instead.
426
427=head2 $md5 = signature ([$conf])
428
429Return the MD5 of the info returned by C<summary ()> without the
430C<config_args> entry.
431
432If C<Digest::MD5> is not available, it return a string with only C<0>'s.
433
434=head2 The hash structure
435
436The returned hash consists of 4 parts:
437
438=over 4
439
440=item build
441
442This information is extracted from the second block that is emitted by
443C<perl -V>, and usually looks something like
444
445 Characteristics of this binary (from libperl):
446   Compile-time options: DEBUGGING USE_64_BIT_INT USE_LARGE_FILES
447   Locally applied patches:
448	 defined-or
449	 MAINT24637
450   Built under linux
451   Compiled at Jun 13 2005 10:44:20
452   @INC:
453     /usr/lib/perl5/5.8.7/i686-linux-64int
454     /usr/lib/perl5/5.8.7
455     /usr/lib/perl5/site_perl/5.8.7/i686-linux-64int
456     /usr/lib/perl5/site_perl/5.8.7
457     /usr/lib/perl5/site_perl
458     .
459
460or
461
462 Characteristics of this binary (from libperl):
463   Compile-time options: DEBUGGING MULTIPLICITY
464			 PERL_DONT_CREATE_GVSV PERL_IMPLICIT_CONTEXT
465			 PERL_MALLOC_WRAP PERL_TRACK_MEMPOOL
466			 PERL_USE_SAFE_PUTENV USE_ITHREADS
467			 USE_LARGE_FILES USE_PERLIO
468			 USE_REENTRANT_API
469   Built under linux
470   Compiled at Jan 28 2009 15:26:59
471
472This information is not available anywhere else, including C<%Config>,
473but it is the information that is only known to the perl binary.
474
475The extracted information is stored in 5 entries in the C<build> hash:
476
477=over 4
478
479=item osname
480
481This is most likely the same as C<$Config{osname}>, and was the name
482known when perl was built. It might be different if perl was cross-compiled.
483
484The default for this field, if it cannot be extracted, is to copy
485C<$Config{osname}>. The two may be differing in casing (OpenBSD vs openbsd).
486
487=item stamp
488
489This is the time string for which the perl binary was compiled. The default
490value is 0.
491
492=item options
493
494This is a hash with all the known defines as keys. The value is either 0,
495which means unknown or unset, or 1, which means defined.
496
497=item derived
498
499As some variables are reported by a different name in the output of C<perl -V>
500than their actual name in C<%Config>, I decided to leave the C<config> entry
501as close to reality as possible, and put in the entries that might have been
502guessed by the printed output in a separate block.
503
504=item patches
505
506This is a list of optionally locally applied patches. Default is an empty list.
507
508=back
509
510=item environment
511
512By default this hash is only filled with the environment variables
513out of %ENV that start with C<PERL>, but you can pass the C<env> option
514to myconfig to get more
515
516 my $conf = Config::Perl::V::myconfig ({ env => qr/^ORACLE/ });
517 my $conf = Config::Perl::V::myconfig ([ env => qr/^ORACLE/ ]);
518
519=item config
520
521This hash is filled with the variables that C<perl -V> fills its report
522with, and it has the same variables that C<Config::myconfig> returns
523from C<%Config>.
524
525=item inc
526
527This is the list of default @INC.
528
529=back
530
531=head1 REASONING
532
533This module was written to be able to return the configuration for the
534currently used perl as deeply as needed for the CPANTESTERS framework.
535Up until now they used the output of myconfig as a single text blob,
536and so it was missing the vital binary characteristics of the running
537perl and the optional applied patches.
538
539=head1 BUGS
540
541Please feedback what is wrong
542
543=head1 TODO
544
545 * Implement retrieval functions/methods
546 * Documentation
547 * Error checking
548 * Tests
549
550=head1 AUTHOR
551
552H.Merijn Brand <h.m.brand@xs4all.nl>
553
554=head1 COPYRIGHT AND LICENSE
555
556Copyright (C) 2009-2018 H.Merijn Brand
557
558This library is free software; you can redistribute it and/or modify
559it under the same terms as Perl itself.
560
561=cut
562