regcomp.c: Remove useless code
[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 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 # No point in adding fakethr.h, as it no longer works
86 push @header_files,
87     $^O eq 'VMS' ? 'vmsish.h' : qw(dosish.h perliol.h time64.h unixish.h);
88
89 my $header_files = '    return qw(' . join(' ', sort @header_files) . ');';
90 $header_files =~ s/(?=.{64})   # If line is still overlength
91                    (.{1,64})\  # Split at the last convenient space
92                   /$1\n              /gx;
93
94 # allowed opts as well as specifies default and initial values
95 my %Allowed_Opts = (
96     'cross'    => '', # --cross=PLATFORM - crosscompiling for PLATFORM
97     'glossary' => 1,  # --no-glossary  - no glossary file inclusion,
98                       #                  for compactness
99     'chdir'    => '', # --chdir=dir    - change directory before writing files
100 );
101
102 sub opts {
103     # user specified options
104     my %given_opts = (
105         # --opt=smth
106         (map {/^--([\-_\w]+)=(.*)$/} @ARGV),
107         # --opt --no-opt --noopt
108         (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV),
109     );
110
111     my %opts = (%Allowed_Opts, %given_opts);
112
113     for my $opt (grep {!exists $Allowed_Opts{$_}} keys %given_opts) {
114         warn "option '$opt' is not recognized";
115         usage;
116     }
117     @ARGV = grep {!/^--/} @ARGV;
118
119     return %opts;
120 }
121
122
123 my %Opts = opts();
124
125 if ($Opts{chdir}) {
126     chdir $Opts{chdir} or die "$0: could not chdir $Opts{chdir}: $!"
127 }
128
129 my ($Config_SH, $Config_PM, $Config_heavy, $Config_POD);
130 my $Glossary = 'Porting/Glossary';
131
132 if ($Opts{cross}) {
133   # creating cross-platform config file
134   mkdir "xlib";
135   mkdir "xlib/$Opts{cross}";
136   $Config_PM = "xlib/$Opts{cross}/Config.pm";
137   $Config_POD = "xlib/$Opts{cross}/Config.pod";
138   $Config_SH = "Cross/config-$Opts{cross}.sh";
139 }
140 else {
141   $Config_PM = "lib/Config.pm";
142   $Config_POD = "lib/Config.pod";
143   $Config_SH = "config.sh";
144 }
145 ($Config_heavy = $Config_PM) =~ s/\.pm$/_heavy.pl/;
146 die "Can't automatically determine name for Config_heavy.pl from '$Config_PM'"
147   if $Config_heavy eq $Config_PM;
148
149 my $config_txt;
150 my $heavy_txt;
151
152 my $from = $^O eq 'VMS' ? 'PERLSHR image' : 'binary (from libperl)';
153 my $env_cygwin = $^O eq 'cygwin'
154     ? 'push @env, "CYGWIN=\"$ENV{CYGWIN}\"" if $ENV{CYGWIN};' . "\n" : "";
155 $heavy_txt .= sprintf <<'ENDOFBEG', $^O, $^O, $from, $^O, $env_cygwin;
156 # This file was created by configpm when Perl was built. Any changes
157 # made to this file will be lost the next time perl is built.
158
159 package Config;
160 use strict;
161 use warnings;
162 use vars '%%Config';
163
164 sub bincompat_options {
165     return split ' ', (Internals::V())[0];
166 }
167
168 sub non_bincompat_options {
169     return split ' ', (Internals::V())[1];
170 }
171
172 sub compile_date {
173     return (Internals::V())[2]
174 }
175
176 sub local_patches {
177     my (undef, undef, undef, @patches) = Internals::V();
178     return @patches;
179 }
180
181 sub _V {
182     die "Perl lib was built for '%s' but is being run on '$^O'"
183         unless "%s" eq $^O;
184
185     my ($bincompat, $non_bincompat, $date, @patches) = Internals::V();
186
187     my $opts = join ' ', sort split ' ', "$bincompat $non_bincompat";
188
189     # wrap at 76 columns.
190
191     $opts =~ s/(?=.{53})(.{1,53}) /$1\n                        /mg;
192
193     print Config::myconfig();
194     print "\nCharacteristics of this %s: \n";
195
196     print "  Compile-time options: $opts\n";
197
198     if (@patches) {
199         print "  Locally applied patches:\n";
200         print "\t$_\n" foreach @patches;
201     }
202
203     print "  Built under %s\n";
204
205     print "  $date\n" if defined $date;
206
207     my @env = map { "$_=\"$ENV{$_}\"" } sort grep {/^PERL/} keys %%ENV;
208 %s
209     if (@env) {
210         print "  \%%ENV:\n";
211         print "    $_\n" foreach @env;
212     }
213     print "  \@INC:\n";
214     print "    $_\n" foreach @INC;
215 }
216
217 sub header_files {
218 ENDOFBEG
219
220 $heavy_txt .= $header_files . "\n}\n\n";
221
222 my $export_funcs = <<'EOT';
223 my %Export_Cache = (myconfig => 1, config_sh => 1, config_vars => 1,
224                     config_re => 1, compile_date => 1, local_patches => 1,
225                     bincompat_options => 1, non_bincompat_options => 1,
226                     header_files => 1);
227 EOT
228
229 my %export_ok = eval $export_funcs or die;
230
231 $config_txt .= sprintf << 'EOT', $export_funcs;
232 # This file was created by configpm when Perl was built. Any changes
233 # made to this file will be lost the next time perl is built.
234
235 # for a description of the variables, please have a look at the
236 # Glossary file, as written in the Porting folder, or use the url:
237 # http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
238
239 package Config;
240 use strict;
241 use warnings;
242 use vars '%%Config';
243
244 # Skip @Config::EXPORT because it only contains %%Config, which we special
245 # case below as it's not a function. @Config::EXPORT won't change in the
246 # lifetime of Perl 5.
247 %s
248 @Config::EXPORT = qw(%%Config);
249 @Config::EXPORT_OK = keys %%Export_Cache;
250
251 # Need to stub all the functions to make code such as print Config::config_sh
252 # keep working
253
254 EOT
255
256 $config_txt .= "sub $_;\n" foreach sort keys %export_ok;
257
258 my $myver = sprintf "%vd", $^V;
259
260 $config_txt .= sprintf <<'ENDOFBEG', ($myver) x 3;
261
262 # Define our own import method to avoid pulling in the full Exporter:
263 sub import {
264     shift;
265     @_ = @Config::EXPORT unless @_;
266
267     my @funcs = grep $_ ne '%%Config', @_;
268     my $export_Config = @funcs < @_ ? 1 : 0;
269
270     no strict 'refs';
271     my $callpkg = caller(0);
272     foreach my $func (@funcs) {
273         die qq{"$func" is not exported by the Config module\n}
274             unless $Export_Cache{$func};
275         *{$callpkg.'::'.$func} = \&{$func};
276     }
277
278     *{"$callpkg\::Config"} = \%%Config if $export_Config;
279     return;
280 }
281
282 die "Perl lib version (%s) doesn't match executable '$0' version ($])"
283     unless $^V;
284
285 $^V eq %s
286     or die "Perl lib version (%s) doesn't match executable '$0' version (" .
287         sprintf("v%%vd",$^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 ' delimted.
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   @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
1122   $::Cross::platform = $platform;
1123 }
1124
1125 1;
1126 EOS
1127   $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
1128   print CROSS $cross;
1129   close CROSS;
1130   print "written lib/Cross.pm\n";
1131   unshift(@INC,"xlib/$Opts{cross}");
1132 }
1133
1134 # Now do some simple tests on the Config.pm file we have created
1135 unshift(@INC,'lib');
1136 unshift(@INC,'xlib/symbian') if $Opts{cross};
1137 require $Config_PM;
1138 require $Config_heavy;
1139 import Config;
1140
1141 die "$0: $Config_PM not valid"
1142         unless $Config{'PERL_CONFIG_SH'} eq 'true';
1143
1144 die "$0: error processing $Config_PM"
1145         if defined($Config{'an impossible name'})
1146         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
1147         ;
1148
1149 die "$0: error processing $Config_PM"
1150         if eval '$Config{"cc"} = 1'
1151         or eval 'delete $Config{"cc"}'
1152         ;
1153
1154
1155 exit 0;
1156 # Popularity of various entries in %Config, based on a large build and test
1157 # run of code in the Fotango build system:
1158 __DATA__
1159 path_sep:       8490
1160 d_readlink:     7101
1161 d_symlink:      7101
1162 archlibexp:     4318
1163 sitearchexp:    4305
1164 sitelibexp:     4305
1165 privlibexp:     4163
1166 ldlibpthname:   4041
1167 libpth: 2134
1168 archname:       1591
1169 exe_ext:        1256
1170 scriptdir:      1155
1171 version:        1116
1172 useithreads:    1002
1173 osvers: 982
1174 osname: 851
1175 inc_version_list:       783
1176 dont_use_nlink: 779
1177 intsize:        759
1178 usevendorprefix:        642
1179 dlsrc:  624
1180 cc:     541
1181 lib_ext:        520
1182 so:     512
1183 ld:     501
1184 ccdlflags:      500
1185 ldflags:        495
1186 obj_ext:        495
1187 cccdlflags:     493
1188 lddlflags:      493
1189 ar:     492
1190 dlext:  492
1191 libc:   492
1192 ranlib: 492
1193 full_ar:        491
1194 vendorarchexp:  491
1195 vendorlibexp:   491
1196 installman1dir: 489
1197 installman3dir: 489
1198 installsitebin: 489
1199 installsiteman1dir:     489
1200 installsiteman3dir:     489
1201 installvendorman1dir:   489
1202 installvendorman3dir:   489
1203 d_flexfnam:     474
1204 eunicefix:      360
1205 d_link: 347
1206 installsitearch:        344
1207 installscript:  341
1208 installprivlib: 337
1209 binexp: 336
1210 installarchlib: 336
1211 installprefixexp:       336
1212 installsitelib: 336
1213 installstyle:   336
1214 installvendorarch:      336
1215 installvendorbin:       336
1216 installvendorlib:       336
1217 man1ext:        336
1218 man3ext:        336
1219 sh:     336
1220 siteprefixexp:  336
1221 installbin:     335
1222 usedl:  332
1223 ccflags:        285
1224 startperl:      232
1225 optimize:       231
1226 usemymalloc:    229
1227 cpprun: 228
1228 sharpbang:      228
1229 perllibs:       225
1230 usesfio:        224
1231 usethreads:     220
1232 perlpath:       218
1233 extensions:     217
1234 usesocks:       208
1235 shellflags:     198
1236 make:   191
1237 d_pwage:        189
1238 d_pwchange:     189
1239 d_pwclass:      189
1240 d_pwcomment:    189
1241 d_pwexpire:     189
1242 d_pwgecos:      189
1243 d_pwpasswd:     189
1244 d_pwquota:      189
1245 gccversion:     189
1246 libs:   186
1247 useshrplib:     186
1248 cppflags:       185
1249 ptrsize:        185
1250 shrpenv:        185
1251 static_ext:     185
1252 use5005threads: 185
1253 uselargefiles:  185
1254 alignbytes:     184
1255 byteorder:      184
1256 ccversion:      184
1257 config_args:    184
1258 cppminus:       184