better perldelta description for #120091/#118059
[perl.git] / configpm
1 #!./miniperl -w
2 #
3 # configpm
4 #
5 # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 # 2002, 2003, 2004, 2005, 2006, 2007 Larry Wall and others.
7 #
8 #
9 # Regenerate the files
10 #
11 #    lib/Config.pm
12 #    lib/Config_heavy.pl
13 #    lib/Config.pod
14 #    lib/Cross.pm (optionally)
15 #
16 #
17 # from the contents of the static files
18 #
19 #    Porting/Glossary
20 #    myconfig.SH
21 #
22 # and from the contents of the Configure-generated file
23 #
24 #    config.sh
25 #
26 # Note that output directory is xlib/[cross-name]/ for cross-compiling
27 #
28 # It will only update Config.pm and Config_heavy.pl if the contents of
29 # either file would be different. Note that *both* files are updated in
30 # this case, since for example an extension makefile that has a dependency
31 # on Config.pm should trigger even if only Config_heavy.pl has changed.
32
33 sub usage { die <<EOF }
34 usage: $0  [ options ]
35     --cross=PLATFORM    cross-compile for a different platform
36     --no-glossary       don't include Porting/Glossary in lib/Config.pod
37     --chdir=dir         change directory before writing files
38 EOF
39
40 use strict;
41 use vars qw(%Config $Config_SH_expanded);
42
43 my $how_many_common = 22;
44
45 # commonly used names to precache (and hence lookup fastest)
46 my %Common;
47
48 while ($how_many_common--) {
49     $_ = <DATA>;
50     chomp;
51     /^(\S+):\s*(\d+)$/ or die "Malformed line '$_'";
52     $Common{$1} = $1;
53 }
54
55 # Post 37589e1eefb1bd62 DynaLoader defaults to reading these at runtime.
56 # Ideally we're redo the data below, but Fotango's build system made it
57 # wonderfully easy to instrument, and no longer exists.
58 $Common{$_} = $_ foreach qw(dlext so);
59
60 # names of things which may need to have slashes changed to double-colons
61 my %Extensions = map {($_,$_)}
62                  qw(dynamic_ext static_ext extensions known_extensions);
63
64 # The plan is that this information is used by ExtUtils::MakeMaker to generate
65 # Makefile dependencies, rather than hardcoding a list, which has become out
66 # of date. However, currently, MM_Unix.pm and MM_VMS.pm have *different* lists,
67 # *and* descrip_mms.template doesn't actually install all the headers.
68 # The "Unix" list seems to (attempt to) avoid the generated headers, which I'm
69 # not sure is the right thing to do. Also, not certain whether it would be
70 # easier to parse MANIFEST to get these (adding config.h, and potentially
71 # removing others), but for now, stick to a hard coded list.
72
73 # Could use a map to add ".h", but I suspect that it's easier to use literals,
74 # so that anyone using grep will find them
75 # This is the list from MM_VMS, plus pad.h, parser.h, perlsfio.h utf8.h
76 # which it installs. It *doesn't* install perliol.h - FIXME.
77 my @header_files = qw(EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h
78                       embed.h embedvar.h form.h gv.h handy.h hv.h hv_func.h intrpvar.h
79                       iperlsys.h keywords.h mg.h nostdio.h op.h opcode.h
80                       pad.h parser.h patchlevel.h perl.h perlio.h perlsdio.h
81                       perlsfio.h perlvars.h perly.h pp.h pp_proto.h proto.h
82                       regcomp.h regexp.h regnodes.h scope.h sv.h thread.h utf8.h
83                       util.h);
84
85 push @header_files,
86     $^O eq 'VMS' ? 'vmsish.h' : qw(dosish.h perliol.h time64.h unixish.h);
87
88 my $header_files = '    return qw(' . join(' ', sort @header_files) . ');';
89 $header_files =~ s/(?=.{64})   # If line is still overlength
90                    (.{1,64})\  # Split at the last convenient space
91                   /$1\n              /gx;
92
93 # allowed opts as well as specifies default and initial values
94 my %Allowed_Opts = (
95     'cross'    => '', # --cross=PLATFORM - crosscompiling for PLATFORM
96     'glossary' => 1,  # --no-glossary  - no glossary file inclusion,
97                       #                  for compactness
98     'chdir'    => '', # --chdir=dir    - change directory before writing files
99 );
100
101 sub opts {
102     # user specified options
103     my %given_opts = (
104         # --opt=smth
105         (map {/^--([\-_\w]+)=(.*)$/} @ARGV),
106         # --opt --no-opt --noopt
107         (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV),
108     );
109
110     my %opts = (%Allowed_Opts, %given_opts);
111
112     for my $opt (grep {!exists $Allowed_Opts{$_}} keys %given_opts) {
113         warn "option '$opt' is not recognized";
114         usage;
115     }
116     @ARGV = grep {!/^--/} @ARGV;
117
118     return %opts;
119 }
120
121
122 my %Opts = opts();
123
124 if ($Opts{chdir}) {
125     chdir $Opts{chdir} or die "$0: could not chdir $Opts{chdir}: $!"
126 }
127
128 my ($Config_SH, $Config_PM, $Config_heavy, $Config_POD);
129 my $Glossary = 'Porting/Glossary';
130
131 if ($Opts{cross}) {
132   # creating cross-platform config file
133   mkdir "xlib";
134   mkdir "xlib/$Opts{cross}";
135   $Config_PM = "xlib/$Opts{cross}/Config.pm";
136   $Config_POD = "xlib/$Opts{cross}/Config.pod";
137   $Config_SH = "Cross/config-$Opts{cross}.sh";
138 }
139 else {
140   $Config_PM = "lib/Config.pm";
141   $Config_POD = "lib/Config.pod";
142   $Config_SH = "config.sh";
143 }
144 ($Config_heavy = $Config_PM) =~ s/\.pm$/_heavy.pl/;
145 die "Can't automatically determine name for Config_heavy.pl from '$Config_PM'"
146   if $Config_heavy eq $Config_PM;
147
148 my $config_txt;
149 my $heavy_txt;
150
151 my $from = $^O eq 'VMS' ? 'PERLSHR image' : 'binary (from libperl)';
152 my $env_cygwin = $^O eq 'cygwin'
153     ? 'push @env, "CYGWIN=\"$ENV{CYGWIN}\"" if $ENV{CYGWIN};' . "\n" : "";
154 $heavy_txt .= sprintf <<'ENDOFBEG', $^O, $^O, $from, $^O, $env_cygwin;
155 # This file was created by configpm when Perl was built. Any changes
156 # made to this file will be lost the next time perl is built.
157
158 package Config;
159 use strict;
160 use warnings;
161 use vars '%%Config';
162
163 sub bincompat_options {
164     return split ' ', (Internals::V())[0];
165 }
166
167 sub non_bincompat_options {
168     return split ' ', (Internals::V())[1];
169 }
170
171 sub compile_date {
172     return (Internals::V())[2]
173 }
174
175 sub local_patches {
176     my (undef, undef, undef, @patches) = Internals::V();
177     return @patches;
178 }
179
180 sub _V {
181     die "Perl lib was built for '%s' but is being run on '$^O'"
182         unless "%s" eq $^O;
183
184     my ($bincompat, $non_bincompat, $date, @patches) = Internals::V();
185
186     my $opts = join ' ', sort split ' ', "$bincompat $non_bincompat";
187
188     # wrap at 76 columns.
189
190     $opts =~ s/(?=.{53})(.{1,53}) /$1\n                        /mg;
191
192     print Config::myconfig();
193     print "\nCharacteristics of this %s: \n";
194
195     print "  Compile-time options: $opts\n";
196
197     if (@patches) {
198         print "  Locally applied patches:\n";
199         print "\t$_\n" foreach @patches;
200     }
201
202     print "  Built under %s\n";
203
204     print "  $date\n" if defined $date;
205
206     my @env = map { "$_=\"$ENV{$_}\"" } sort grep {/^PERL/} keys %%ENV;
207 %s
208     if (@env) {
209         print "  \%%ENV:\n";
210         print "    $_\n" foreach @env;
211     }
212     print "  \@INC:\n";
213     print "    $_\n" foreach @INC;
214 }
215
216 sub header_files {
217 ENDOFBEG
218
219 $heavy_txt .= $header_files . "\n}\n\n";
220
221 my $export_funcs = <<'EOT';
222 my %Export_Cache = (myconfig => 1, config_sh => 1, config_vars => 1,
223                     config_re => 1, compile_date => 1, local_patches => 1,
224                     bincompat_options => 1, non_bincompat_options => 1,
225                     header_files => 1);
226 EOT
227
228 my %export_ok = eval $export_funcs or die;
229
230 $config_txt .= sprintf << 'EOT', $], $export_funcs;
231 # This file was created by configpm when Perl was built. Any changes
232 # made to this file will be lost the next time perl is built.
233
234 # for a description of the variables, please have a look at the
235 # Glossary file, as written in the Porting folder, or use the url:
236 # http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
237
238 package Config;
239 use strict;
240 use warnings;
241 use vars '%%Config', '$VERSION';
242
243 $VERSION = "%s";
244
245 # Skip @Config::EXPORT because it only contains %%Config, which we special
246 # case below as it's not a function. @Config::EXPORT won't change in the
247 # lifetime of Perl 5.
248 %s
249 @Config::EXPORT = qw(%%Config);
250 @Config::EXPORT_OK = keys %%Export_Cache;
251
252 # Need to stub all the functions to make code such as print Config::config_sh
253 # keep working
254
255 EOT
256
257 $config_txt .= "sub $_;\n" foreach sort keys %export_ok;
258
259 my $myver = sprintf "%vd", $^V;
260
261 $config_txt .= sprintf <<'ENDOFBEG', ($myver) x 3;
262
263 # Define our own import method to avoid pulling in the full Exporter:
264 sub import {
265     shift;
266     @_ = @Config::EXPORT unless @_;
267
268     my @funcs = grep $_ ne '%%Config', @_;
269     my $export_Config = @funcs < @_ ? 1 : 0;
270
271     no strict 'refs';
272     my $callpkg = caller(0);
273     foreach my $func (@funcs) {
274         die qq{"$func" is not exported by the Config module\n}
275             unless $Export_Cache{$func};
276         *{$callpkg.'::'.$func} = \&{$func};
277     }
278
279     *{"$callpkg\::Config"} = \%%Config if $export_Config;
280     return;
281 }
282
283 die "$0: Perl lib version (%s) doesn't match executable '$^X' version ($])"
284     unless $^V;
285
286 $^V eq %s
287     or die sprintf "%%s: Perl lib version (%s) doesn't match executable '$^X' version (%%vd)", $0, $^V;
288
289 ENDOFBEG
290
291
292 my @non_v    = ();
293 my @v_others = ();
294 my $in_v     = 0;
295 my %Data     = ();
296 my $quote;
297
298
299 my %seen_quotes;
300 {
301   my ($name, $val);
302   open(CONFIG_SH, $Config_SH) || die "Can't open $Config_SH: $!";
303   while (<CONFIG_SH>) {
304     next if m:^#!/bin/sh:;
305
306     # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
307     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/ or m/^(\w+)='(.*)'$/;
308     my($k, $v) = ($1, $2);
309
310     # grandfather PATCHLEVEL and SUBVERSION and CONFIG
311     if ($k) {
312         if ($k eq 'PERL_VERSION') {
313             push @v_others, "PATCHLEVEL='$v'\n";
314         }
315         elsif ($k eq 'PERL_SUBVERSION') {
316             push @v_others, "SUBVERSION='$v'\n";
317         }
318         elsif ($k eq 'PERL_CONFIG_SH') {
319             push @v_others, "CONFIG='$v'\n";
320         }
321     }
322
323     # We can delimit things in config.sh with either ' or ". 
324     unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
325         push(@non_v, "#$_"); # not a name='value' line
326         next;
327     }
328     if ($in_v) { 
329         $val .= $_;
330     }
331     else { 
332         $quote = $2;
333         ($name,$val) = ($1,$3); 
334     }
335     $in_v = $val !~ /$quote\n/;
336     next if $in_v;
337
338     s,/,::,g if $Extensions{$name};
339
340     $val =~ s/$quote\n?\z//;
341
342     my $line = "$name=$quote$val$quote\n";
343     push(@v_others, $line);
344     $seen_quotes{$quote}++;
345   }
346   close CONFIG_SH;
347 }
348
349 # This is somewhat grim, but I want the code for parsing config.sh here and
350 # now so that I can expand $Config{ivsize} and $Config{ivtype}
351
352 my $fetch_string = <<'EOT';
353
354 # Search for it in the big string
355 sub fetch_string {
356     my($self, $key) = @_;
357
358 EOT
359
360 if ($seen_quotes{'"'}) {
361     # We need the full ' and " code
362
363 $fetch_string .= <<'EOT';
364     return undef unless my ($quote_type, $value) = $Config_SH_expanded =~ /\n$key=(['"])(.*?)\1\n/s;
365
366     # If we had a double-quote, we'd better eval it so escape
367     # sequences and such can be interpolated. Since the incoming
368     # value is supposed to follow shell rules and not perl rules,
369     # we escape any perl variable markers
370
371     # Historically, since " 'support' was added in change 1409, the
372     # interpolation was done before the undef. Stick to this arguably buggy
373     # behaviour as we're refactoring.
374     if ($quote_type eq '"') {
375         $value =~ s/\$/\\\$/g;
376         $value =~ s/\@/\\\@/g;
377         eval "\$value = \"$value\"";
378     }
379
380     # So we can say "if $Config{'foo'}".
381     $self->{$key} = $value eq 'undef' ? undef : $value; # cache it
382 }
383 EOT
384
385 } else {
386     # We only have ' delimited.
387
388 $fetch_string .= <<'EOT';
389     return undef unless $Config_SH_expanded =~ /\n$key=\'(.*?)\'\n/s;
390     # So we can say "if $Config{'foo'}".
391     $self->{$key} = $1 eq 'undef' ? undef : $1;
392 }
393 EOT
394
395 }
396
397 eval $fetch_string;
398 die if $@;
399
400 # Calculation for the keys for byteorder
401 # This is somewhat grim, but I need to run fetch_string here.
402 our $Config_SH_expanded = join "\n", '', @v_others;
403
404 my $t = fetch_string ({}, 'ivtype');
405 my $s = fetch_string ({}, 'ivsize');
406
407 # byteorder does exist on its own but we overlay a virtual
408 # dynamically recomputed value.
409
410 # However, ivtype and ivsize will not vary for sane fat binaries
411
412 my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
413
414 my $byteorder_code;
415 if ($s == 4 || $s == 8) {
416     my $list = join ',', reverse(1..$s-1);
417     my $format = 'a'x$s;
418     $byteorder_code = <<"EOT";
419
420 my \$i = ord($s);
421 foreach my \$c ($list) { \$i <<= 8; \$i |= ord(\$c); }
422 our \$byteorder = join('', unpack('$format', pack('$f', \$i)));
423 EOT
424 } else {
425     $byteorder_code = "our \$byteorder = '?'x$s;\n";
426 }
427
428 my @need_relocation;
429
430 if (fetch_string({},'userelocatableinc')) {
431     foreach my $what (qw(prefixexp
432
433                          archlibexp
434                          html1direxp
435                          html3direxp
436                          man1direxp
437                          man3direxp
438                          privlibexp
439                          scriptdirexp
440                          sitearchexp
441                          sitebinexp
442                          sitehtml1direxp
443                          sitehtml3direxp
444                          sitelibexp
445                          siteman1direxp
446                          siteman3direxp
447                          sitescriptexp
448                          vendorarchexp
449                          vendorbinexp
450                          vendorhtml1direxp
451                          vendorhtml3direxp
452                          vendorlibexp
453                          vendorman1direxp
454                          vendorman3direxp
455                          vendorscriptexp
456
457                          siteprefixexp
458                          sitelib_stem
459                          vendorlib_stem
460
461                          installarchlib
462                          installhtml1dir
463                          installhtml3dir
464                          installman1dir
465                          installman3dir
466                          installprefix
467                          installprefixexp
468                          installprivlib
469                          installscript
470                          installsitearch
471                          installsitebin
472                          installsitehtml1dir
473                          installsitehtml3dir
474                          installsitelib
475                          installsiteman1dir
476                          installsiteman3dir
477                          installsitescript
478                          installvendorarch
479                          installvendorbin
480                          installvendorhtml1dir
481                          installvendorhtml3dir
482                          installvendorlib
483                          installvendorman1dir
484                          installvendorman3dir
485                          installvendorscript
486                          )) {
487         push @need_relocation, $what if fetch_string({}, $what) =~ m!^\.\.\./!;
488     }
489 }
490
491 my %need_relocation;
492 @need_relocation{@need_relocation} = @need_relocation;
493
494 # This can have .../ anywhere:
495 if (fetch_string({}, 'otherlibdirs') =~ m!\.\.\./!) {
496     $need_relocation{otherlibdirs} = 'otherlibdirs';
497 }
498
499 my $relocation_code = <<'EOT';
500
501 sub relocate_inc {
502   my $libdir = shift;
503   return $libdir unless $libdir =~ s!^\.\.\./!!;
504   my $prefix = $^X;
505   if ($prefix =~ s!/[^/]*$!!) {
506     while ($libdir =~ m!^\.\./!) {
507       # Loop while $libdir starts "../" and $prefix still has a trailing
508       # directory
509       last unless $prefix =~ s!/([^/]+)$!!;
510       # but bail out if the directory we picked off the end of $prefix is .
511       # or ..
512       if ($1 eq '.' or $1 eq '..') {
513         # Undo! This should be rare, hence code it this way rather than a
514         # check each time before the s!!! above.
515         $prefix = "$prefix/$1";
516         last;
517       }
518       # Remove that leading ../ and loop again
519       substr ($libdir, 0, 3, '');
520     }
521     $libdir = "$prefix/$libdir";
522   }
523   $libdir;
524 }
525 EOT
526
527 if (%need_relocation) {
528   my $relocations_in_common;
529   # otherlibdirs only features in the hash
530   foreach (keys %need_relocation) {
531     $relocations_in_common++ if $Common{$_};
532   }
533   if ($relocations_in_common) {
534     $config_txt .= $relocation_code;
535   } else {
536     $heavy_txt .= $relocation_code;
537   }
538 }
539
540 $heavy_txt .= join('', @non_v) . "\n";
541
542 # copy config summary format from the myconfig.SH script
543 $heavy_txt .= "our \$summary = <<'!END!';\n";
544 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
545 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
546 do { $heavy_txt .= $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
547 close(MYCONFIG);
548
549 $heavy_txt .= "\n!END!\n" . <<'EOT';
550 my $summary_expanded;
551
552 sub myconfig {
553     return $summary_expanded if $summary_expanded;
554     ($summary_expanded = $summary) =~ s{\$(\w+)}
555                  { 
556                         my $c;
557                         if ($1 eq 'git_ancestor_line') {
558                                 if ($Config::Config{git_ancestor}) {
559                                         $c= "\n  Ancestor: $Config::Config{git_ancestor}";
560                                 } else {
561                                         $c= "";
562                                 }
563                         } else {
564                                 $c = $Config::Config{$1}; 
565                         }
566                         defined($c) ? $c : 'undef' 
567                 }ge;
568     $summary_expanded;
569 }
570
571 local *_ = \my $a;
572 $_ = <<'!END!';
573 EOT
574
575 $heavy_txt .= join('', sort @v_others) . "!END!\n";
576
577 # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
578 # the precached keys
579 if ($Common{byteorder}) {
580     $config_txt .= $byteorder_code;
581 } else {
582     $heavy_txt .= $byteorder_code;
583 }
584
585 if (@need_relocation) {
586 $heavy_txt .= 'foreach my $what (qw(' . join (' ', @need_relocation) .
587       ")) {\n" . <<'EOT';
588     s/^($what=)(['"])(.*?)\2/$1 . $2 . relocate_inc($3) . $2/me;
589 }
590 EOT
591 # Currently it only makes sense to do the ... relocation on Unix, so there's
592 # no need to emulate the "which separator for this platform" logic in perl.c -
593 # ':' will always be applicable
594 if ($need_relocation{otherlibdirs}) {
595 $heavy_txt .= << 'EOT';
596 s{^(otherlibdirs=)(['"])(.*?)\2}
597  {$1 . $2 . join ':', map {relocate_inc($_)} split ':', $3 . $2}me;
598 EOT
599 }
600 }
601
602 $heavy_txt .= <<'EOT';
603 s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
604
605 my $config_sh_len = length $_;
606
607 our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL';
608 EOT
609
610 foreach my $prefix (qw(ccflags ldflags)) {
611     my $value = fetch_string ({}, $prefix);
612     my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles");
613     if (defined $withlargefiles) {
614         $value =~ s/\Q$withlargefiles\E\b//;
615         $heavy_txt .= "${prefix}_nolargefiles='$value'\n";
616     }
617 }
618
619 foreach my $prefix (qw(libs libswanted)) {
620     my $value = fetch_string ({}, $prefix);
621     my $withlf = fetch_string ({}, 'libswanted_uselargefiles');
622     next unless defined $withlf;
623     my @lflibswanted
624        = split(' ', fetch_string ({}, 'libswanted_uselargefiles'));
625     if (@lflibswanted) {
626         my %lflibswanted;
627         @lflibswanted{@lflibswanted} = ();
628         if ($prefix eq 'libs') {
629             my @libs = grep { /^-l(.+)/ &&
630                             not exists $lflibswanted{$1} }
631                                     split(' ', fetch_string ({}, 'libs'));
632             $value = join(' ', @libs);
633         } else {
634             my @libswanted = grep { not exists $lflibswanted{$_} }
635                                   split(' ', fetch_string ({}, 'libswanted'));
636             $value = join(' ', @libswanted);
637         }
638     }
639     $heavy_txt .= "${prefix}_nolargefiles='$value'\n";
640 }
641
642 $heavy_txt .= "EOVIRTUAL\n";
643
644 $heavy_txt .= <<'ENDOFGIT';
645 eval {
646         # do not have hairy conniptions if this isnt available
647         require 'Config_git.pl';
648         $Config_SH_expanded .= $Config::Git_Data;
649         1;
650 } or warn "Warning: failed to load Config_git.pl, something strange about this perl...\n";
651 ENDOFGIT
652
653 $heavy_txt .= $fetch_string;
654
655 $config_txt .= <<'ENDOFEND';
656
657 sub FETCH {
658     my($self, $key) = @_;
659
660     # check for cached value (which may be undef so we use exists not defined)
661     return exists $self->{$key} ? $self->{$key} : $self->fetch_string($key);
662 }
663
664 ENDOFEND
665
666 $heavy_txt .= <<'ENDOFEND';
667
668 my $prevpos = 0;
669
670 sub FIRSTKEY {
671     $prevpos = 0;
672     substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
673 }
674
675 sub NEXTKEY {
676 ENDOFEND
677 if ($seen_quotes{'"'}) {
678 $heavy_txt .= <<'ENDOFEND';
679     # Find out how the current key's quoted so we can skip to its end.
680     my $quote = substr($Config_SH_expanded,
681                        index($Config_SH_expanded, "=", $prevpos)+1, 1);
682     my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
683 ENDOFEND
684 } else {
685     # Just ' quotes, so it's much easier.
686 $heavy_txt .= <<'ENDOFEND';
687     my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2;
688 ENDOFEND
689 }
690 $heavy_txt .= <<'ENDOFEND';
691     my $len = index($Config_SH_expanded, "=", $pos) - $pos;
692     $prevpos = $pos;
693     $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
694 }
695
696 sub EXISTS {
697     return 1 if exists($_[0]->{$_[1]});
698
699     return(index($Config_SH_expanded, "\n$_[1]='") != -1
700 ENDOFEND
701 if ($seen_quotes{'"'}) {
702 $heavy_txt .= <<'ENDOFEND';
703            or index($Config_SH_expanded, "\n$_[1]=\"") != -1
704 ENDOFEND
705 }
706 $heavy_txt .= <<'ENDOFEND';
707           );
708 }
709
710 sub STORE  { die "\%Config::Config is read-only\n" }
711 *DELETE = *CLEAR = \*STORE; # Typeglob aliasing uses less space
712
713 sub config_sh {
714     substr $Config_SH_expanded, 1, $config_sh_len;
715 }
716
717 sub config_re {
718     my $re = shift;
719     return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
720     $Config_SH_expanded;
721 }
722
723 sub config_vars {
724     # implements -V:cfgvar option (see perlrun -V:)
725     foreach (@_) {
726         # find optional leading, trailing colons; and query-spec
727         my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/;  # flags fore and aft, 
728         # map colon-flags to print decorations
729         my $prfx = $notag ? '': "$qry=";                # tag-prefix for print
730         my $lnend = $lncont ? ' ' : ";\n";              # line ending for print
731
732         # all config-vars are by definition \w only, any \W means regex
733         if ($qry =~ /\W/) {
734             my @matches = config_re($qry);
735             print map "$_$lnend", @matches ? @matches : "$qry: not found"               if !$notag;
736             print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found"  if  $notag;
737         } else {
738             my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
739                                                    : 'UNKNOWN';
740             $v = 'undef' unless defined $v;
741             print "${prfx}'${v}'$lnend";
742         }
743     }
744 }
745
746 # Called by the real AUTOLOAD
747 sub launcher {
748     undef &AUTOLOAD;
749     goto \&$Config::AUTOLOAD;
750 }
751
752 1;
753 ENDOFEND
754
755 if ($^O eq 'os2') {
756     $config_txt .= <<'ENDOFSET';
757 my %preconfig;
758 if ($OS2::is_aout) {
759     my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m;
760     for (split ' ', $value) {
761         ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m;
762         $preconfig{$_} = $v eq 'undef' ? undef : $v;
763     }
764 }
765 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
766 sub TIEHASH { bless {%preconfig} }
767 ENDOFSET
768     # Extract the name of the DLL from the makefile to avoid duplication
769     my ($f) = grep -r, qw(GNUMakefile Makefile);
770     my $dll;
771     if (open my $fh, '<', $f) {
772         while (<$fh>) {
773             $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
774         }
775     }
776     $config_txt .= <<ENDOFSET if $dll;
777 \$preconfig{dll_name} = '$dll';
778 ENDOFSET
779 } else {
780     $config_txt .= <<'ENDOFSET';
781 sub TIEHASH {
782     bless $_[1], $_[0];
783 }
784 ENDOFSET
785 }
786
787 foreach my $key (keys %Common) {
788     my $value = fetch_string ({}, $key);
789     # Is it safe on the LHS of => ?
790     my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'";
791     if (defined $value) {
792         # Quote things for a '' string
793         $value =~ s!\\!\\\\!g;
794         $value =~ s!'!\\'!g;
795         $value = "'$value'";
796         if ($key eq 'otherlibdirs') {
797             $value = "join (':', map {relocate_inc(\$_)} split (':', $value))";
798         } elsif ($need_relocation{$key}) {
799             $value = "relocate_inc($value)";
800         }
801     } else {
802         $value = "undef";
803     }
804     $Common{$key} = "$qkey => $value";
805 }
806
807 if ($Common{byteorder}) {
808     $Common{byteorder} = 'byteorder => $byteorder';
809 }
810 my $fast_config = join '', map { "    $_,\n" } sort values %Common;
811
812 # Sanity check needed to stop an infinite loop if Config_heavy.pl fails to
813 # define &launcher for some reason (eg it got truncated)
814 $config_txt .= sprintf <<'ENDOFTIE', $fast_config;
815
816 sub DESTROY { }
817
818 sub AUTOLOAD {
819     require 'Config_heavy.pl';
820     goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
821     die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
822 }
823
824 # tie returns the object, so the value returned to require will be true.
825 tie %%Config, 'Config', {
826 %s};
827 ENDOFTIE
828
829
830 open(CONFIG_POD, ">$Config_POD") or die "Can't open $Config_POD: $!";
831 print CONFIG_POD <<'ENDOFTAIL';
832 =head1 NAME
833
834 Config - access Perl configuration information
835
836 =head1 SYNOPSIS
837
838     use Config;
839     if ($Config{usethreads}) {
840         print "has thread support\n"
841     } 
842
843     use Config qw(myconfig config_sh config_vars config_re);
844
845     print myconfig();
846
847     print config_sh();
848
849     print config_re();
850
851     config_vars(qw(osname archname));
852
853
854 =head1 DESCRIPTION
855
856 The Config module contains all the information that was available to
857 the C<Configure> program at Perl build time (over 900 values).
858
859 Shell variables from the F<config.sh> file (written by Configure) are
860 stored in the readonly-variable C<%Config>, indexed by their names.
861
862 Values stored in config.sh as 'undef' are returned as undefined
863 values.  The perl C<exists> function can be used to check if a
864 named variable exists.
865
866 For a description of the variables, please have a look at the
867 Glossary file, as written in the Porting folder, or use the url:
868 http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
869
870 =over 4
871
872 =item myconfig()
873
874 Returns a textual summary of the major perl configuration values.
875 See also C<-V> in L<perlrun/Command Switches>.
876
877 =item config_sh()
878
879 Returns the entire perl configuration information in the form of the
880 original config.sh shell variable assignment script.
881
882 =item config_re($regex)
883
884 Like config_sh() but returns, as a list, only the config entries who's
885 names match the $regex.
886
887 =item config_vars(@names)
888
889 Prints to STDOUT the values of the named configuration variable. Each is
890 printed on a separate line in the form:
891
892   name='value';
893
894 Names which are unknown are output as C<name='UNKNOWN';>.
895 See also C<-V:name> in L<perlrun/Command Switches>.
896
897 =item bincompat_options()
898
899 Returns a list of C pre-processor options used when compiling this F<perl>
900 binary, which affect its binary compatibility with extensions.
901 C<bincompat_options()> and C<non_bincompat_options()> are shown together in
902 the output of C<perl -V> as I<Compile-time options>.
903
904 =item non_bincompat_options()
905
906 Returns a list of C pre-processor options used when compiling this F<perl>
907 binary, which do not affect binary compatibility with extensions.
908
909 =item compile_date()
910
911 Returns the compile date (as a string), equivalent to what is shown by
912 C<perl -V>
913
914 =item local_patches()
915
916 Returns a list of the names of locally applied patches, equivalent to what
917 is shown by C<perl -V>.
918
919 =item header_files()
920
921 Returns a list of the header files that should be used as dependencies for
922 XS code, for this version of Perl on this platform.
923
924 =back
925
926 =head1 EXAMPLE
927
928 Here's a more sophisticated example of using %Config:
929
930     use Config;
931     use strict;
932
933     my %sig_num;
934     my @sig_name;
935     unless($Config{sig_name} && $Config{sig_num}) {
936         die "No sigs?";
937     } else {
938         my @names = split ' ', $Config{sig_name};
939         @sig_num{@names} = split ' ', $Config{sig_num};
940         foreach (@names) {
941             $sig_name[$sig_num{$_}] ||= $_;
942         }   
943     }
944
945     print "signal #17 = $sig_name[17]\n";
946     if ($sig_num{ALRM}) { 
947         print "SIGALRM is $sig_num{ALRM}\n";
948     }   
949
950 =head1 WARNING
951
952 Because this information is not stored within the perl executable
953 itself it is possible (but unlikely) that the information does not
954 relate to the actual perl binary which is being used to access it.
955
956 The Config module is installed into the architecture and version
957 specific library directory ($Config{installarchlib}) and it checks the
958 perl version number when loaded.
959
960 The values stored in config.sh may be either single-quoted or
961 double-quoted. Double-quoted strings are handy for those cases where you
962 need to include escape sequences in the strings. To avoid runtime variable
963 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
964 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
965 or C<\@> in double-quoted strings unless you're willing to deal with the
966 consequences. (The slashes will end up escaped and the C<$> or C<@> will
967 trigger variable interpolation)
968
969 =head1 GLOSSARY
970
971 Most C<Config> variables are determined by the C<Configure> script
972 on platforms supported by it (which is most UNIX platforms).  Some
973 platforms have custom-made C<Config> variables, and may thus not have
974 some of the variables described below, or may have extraneous variables
975 specific to that particular port.  See the port specific documentation
976 in such cases.
977
978 =cut
979
980 ENDOFTAIL
981
982 if ($Opts{glossary}) {
983   open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!";
984 }
985 my %seen = ();
986 my $text = 0;
987 $/ = '';
988
989 sub process {
990   if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
991     my $c = substr $1, 0, 1;
992     unless ($seen{$c}++) {
993       print CONFIG_POD <<EOF if $text;
994 =back
995
996 =cut
997
998 EOF
999       print CONFIG_POD <<EOF;
1000 =head2 $c
1001
1002 =over 4
1003
1004 =cut
1005
1006 EOF
1007      $text = 1;
1008     }
1009   }
1010   elsif (!$text || !/\A\t/) {
1011     warn "Expected a Configure variable header",
1012       ($text ? " or another paragraph of description" : () );
1013   }
1014   s/n't/n\00t/g;                # leave can't, won't etc untouched
1015   s/^\t\s+(.*)/\n$1/gm;         # Indented lines ===> new paragraph
1016   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
1017   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
1018   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
1019   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
1020   s{
1021      (?<! [\w./<\'\"\$] )               # Only standalone file names
1022      (?! e \. g \. )            # Not e.g.
1023      (?! \. \. \. )             # Not ...
1024      (?! \d )                   # Not 5.004
1025      (?! read/ )                # Not read/write
1026      (?! etc\. )                # Not etc.
1027      (?! I/O )                  # Not I/O
1028      (
1029         \$ ?                    # Allow leading $
1030         [\w./]* [./] [\w./]*    # Require . or / inside
1031      )
1032      (?<! \. (?= [\s)] ) )      # Do not include trailing dot
1033      (?! [\w/] )                # Include all of it
1034    }
1035    (F<$1>)xg;                   # /usr/local
1036   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
1037   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
1038   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
1039   s/n[\0]t/n't/g;               # undo can't, won't damage
1040 }
1041
1042 if ($Opts{glossary}) {
1043     <GLOS>;                             # Skip the "DO NOT EDIT"
1044     <GLOS>;                             # Skip the preamble
1045   while (<GLOS>) {
1046     process;
1047     print CONFIG_POD;
1048   }
1049 }
1050
1051 print CONFIG_POD <<'ENDOFTAIL';
1052
1053 =back
1054
1055 =head1 GIT DATA
1056
1057 Information on the git commit from which the current perl binary was compiled
1058 can be found in the variable C<$Config::Git_Data>.  The variable is a
1059 structured string that looks something like this:
1060
1061   git_commit_id='ea0c2dbd5f5ac6845ecc7ec6696415bf8e27bd52'
1062   git_describe='GitLive-blead-1076-gea0c2db'
1063   git_branch='smartmatch'
1064   git_uncommitted_changes=''
1065   git_commit_id_title='Commit id:'
1066   git_commit_date='2009-05-09 17:47:31 +0200'
1067
1068 Its format is not guaranteed not to change over time.
1069
1070 =head1 NOTE
1071
1072 This module contains a good example of how to use tie to implement a
1073 cache and an example of how to make a tied variable readonly to those
1074 outside of it.
1075
1076 =cut
1077
1078 ENDOFTAIL
1079
1080 close(GLOS) if $Opts{glossary};
1081 close(CONFIG_POD);
1082 print "written $Config_POD\n";
1083
1084 my $orig_config_txt = "";
1085 my $orig_heavy_txt = "";
1086 {
1087     local $/;
1088     my $fh;
1089     $orig_config_txt = <$fh> if open $fh, "<", $Config_PM;
1090     $orig_heavy_txt  = <$fh> if open $fh, "<", $Config_heavy;
1091 }
1092
1093 if ($orig_config_txt ne $config_txt or $orig_heavy_txt ne $heavy_txt) {
1094     open CONFIG, ">", $Config_PM or die "Can't open $Config_PM: $!\n";
1095     open CONFIG_HEAVY, ">", $Config_heavy or die "Can't open $Config_heavy: $!\n";
1096     print CONFIG $config_txt;
1097     print CONFIG_HEAVY $heavy_txt;
1098     close(CONFIG_HEAVY);
1099     close(CONFIG);
1100     print "updated $Config_PM\n";
1101     print "updated $Config_heavy\n";
1102 }
1103
1104
1105 # Now create Cross.pm if needed
1106 if ($Opts{cross}) {
1107   open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!";
1108   my $cross = <<'EOS';
1109 # typical invocation:
1110 #   perl -MCross Makefile.PL
1111 #   perl -MCross=wince -V:cc
1112 package Cross;
1113
1114 sub import {
1115   my ($package,$platform) = @_;
1116   unless (defined $platform) {
1117     # if $platform is not specified, then use last one when
1118     # 'configpm; was invoked with --cross option
1119     $platform = '***replace-marker***';
1120   }
1121   #a Perl debugger can load a bunch of modules before -MCross with PERL5DB env
1122   #var, stopping a cross compile Config.pm from being loaded because the native
1123   #Config.pm was already use'd
1124   if(exists $INC{'Config.pm'}) {
1125     warn "Cross.pm found Config.pm is already loaded, reload required, will delete from %INC";
1126     delete $INC{'Config.pm'};
1127   }
1128   @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
1129   $::Cross::platform = $platform;
1130 }
1131
1132 1;
1133 EOS
1134   $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
1135   print CROSS $cross;
1136   close CROSS;
1137   print "written lib/Cross.pm\n";
1138   unshift(@INC,"xlib/$Opts{cross}");
1139 }
1140
1141 # Now do some simple tests on the Config.pm file we have created
1142 unshift(@INC,'lib');
1143 unshift(@INC,'xlib/symbian') if $Opts{cross};
1144 require $Config_PM;
1145 require $Config_heavy;
1146 import Config;
1147
1148 die "$0: $Config_PM not valid"
1149         unless $Config{'PERL_CONFIG_SH'} eq 'true';
1150
1151 die "$0: error processing $Config_PM"
1152         if defined($Config{'an impossible name'})
1153         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
1154         ;
1155
1156 die "$0: error processing $Config_PM"
1157         if eval '$Config{"cc"} = 1'
1158         or eval 'delete $Config{"cc"}'
1159         ;
1160
1161
1162 exit 0;
1163 # Popularity of various entries in %Config, based on a large build and test
1164 # run of code in the Fotango build system:
1165 __DATA__
1166 path_sep:       8490
1167 d_readlink:     7101
1168 d_symlink:      7101
1169 archlibexp:     4318
1170 sitearchexp:    4305
1171 sitelibexp:     4305
1172 privlibexp:     4163
1173 ldlibpthname:   4041
1174 libpth: 2134
1175 archname:       1591
1176 exe_ext:        1256
1177 scriptdir:      1155
1178 version:        1116
1179 useithreads:    1002
1180 osvers: 982
1181 osname: 851
1182 inc_version_list:       783
1183 dont_use_nlink: 779
1184 intsize:        759
1185 usevendorprefix:        642
1186 dlsrc:  624
1187 cc:     541
1188 lib_ext:        520
1189 so:     512
1190 ld:     501
1191 ccdlflags:      500
1192 ldflags:        495
1193 obj_ext:        495
1194 cccdlflags:     493
1195 lddlflags:      493
1196 ar:     492
1197 dlext:  492
1198 libc:   492
1199 ranlib: 492
1200 full_ar:        491
1201 vendorarchexp:  491
1202 vendorlibexp:   491
1203 installman1dir: 489
1204 installman3dir: 489
1205 installsitebin: 489
1206 installsiteman1dir:     489
1207 installsiteman3dir:     489
1208 installvendorman1dir:   489
1209 installvendorman3dir:   489
1210 d_flexfnam:     474
1211 eunicefix:      360
1212 d_link: 347
1213 installsitearch:        344
1214 installscript:  341
1215 installprivlib: 337
1216 binexp: 336
1217 installarchlib: 336
1218 installprefixexp:       336
1219 installsitelib: 336
1220 installstyle:   336
1221 installvendorarch:      336
1222 installvendorbin:       336
1223 installvendorlib:       336
1224 man1ext:        336
1225 man3ext:        336
1226 sh:     336
1227 siteprefixexp:  336
1228 installbin:     335
1229 usedl:  332
1230 ccflags:        285
1231 startperl:      232
1232 optimize:       231
1233 usemymalloc:    229
1234 cpprun: 228
1235 sharpbang:      228
1236 perllibs:       225
1237 usesfio:        224
1238 usethreads:     220
1239 perlpath:       218
1240 extensions:     217
1241 usesocks:       208
1242 shellflags:     198
1243 make:   191
1244 d_pwage:        189
1245 d_pwchange:     189
1246 d_pwclass:      189
1247 d_pwcomment:    189
1248 d_pwexpire:     189
1249 d_pwgecos:      189
1250 d_pwpasswd:     189
1251 d_pwquota:      189
1252 gccversion:     189
1253 libs:   186
1254 useshrplib:     186
1255 cppflags:       185
1256 ptrsize:        185
1257 shrpenv:        185
1258 static_ext:     185
1259 use5005threads: 185
1260 uselargefiles:  185
1261 alignbytes:     184
1262 byteorder:      184
1263 ccversion:      184
1264 config_args:    184
1265 cppminus:       184