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