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