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