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