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