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