Perldelta: Linkefy references to Perl RT tickets in the Modules section.
[perl.git] / configpm
1 #!./miniperl -w
2 #
3 # configpm
4 #
5 # Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 # 2002, 2003, 2004, 2005, 2006, 2007 Larry Wall and others.
7 #
8 #
9 # Regenerate the files
10 #
11 #    lib/Config.pm
12 #    lib/Config_heavy.pl
13 #    lib/Config.pod
14 #
15 #
16 # from the contents of the static files
17 #
18 #    Porting/Glossary
19 #    myconfig.SH
20 #
21 # and from the contents of the Configure-generated file
22 #
23 #    config.sh
24 #
25 #
26 # It will only update Config.pm and Config_heavy.pl if the contents of
27 # either file would be different. Note that *both* files are updated in
28 # this case, since for example an extension makefile that has a dependency
29 # on Config.pm should trigger even if only Config_heavy.pl has changed.
30
31 sub usage { die <<EOF }
32 usage: $0  [ options ]
33     --no-glossary       don't include Porting/Glossary in lib/Config.pod
34     --chdir=dir         change directory before writing files
35 EOF
36
37 use strict;
38 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 $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 my %seen_var;
578 $heavy_txt .= join('',
579     map { $_->[-1] }
580     sort {$a->[0] cmp $b->[0] }
581     grep { !$seen_var{ $_->[0] }++ }
582     map {
583         /^([^=]+)/ ? [ $1, $_ ]
584                    : [ $_, $_ ] # shouldnt happen
585     } @v_others, @v_forced
586 ) . "!END!\n";
587
588 # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
589 # the precached keys
590 if ($Common{byteorder}) {
591     $config_txt .= $byteorder_code;
592 } else {
593     $heavy_txt .= $byteorder_code;
594 }
595
596 if (@need_relocation) {
597 $heavy_txt .= 'foreach my $what (qw(' . join (' ', @need_relocation) .
598       ")) {\n" . <<'EOT';
599     s/^($what=)(['"])(.*?)\2/$1 . $2 . relocate_inc($3) . $2/me;
600 }
601 EOT
602 # Currently it only makes sense to do the ... relocation on Unix, so there's
603 # no need to emulate the "which separator for this platform" logic in perl.c -
604 # ':' will always be applicable
605 if ($need_relocation{otherlibdirs}) {
606 $heavy_txt .= << 'EOT';
607 s{^(otherlibdirs=)(['"])(.*?)\2}
608  {$1 . $2 . join ':', map {relocate_inc($_)} split ':', $3 . $2}me;
609 EOT
610 }
611 }
612
613 $heavy_txt .= <<'EOT';
614 s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
615
616 my $config_sh_len = length $_;
617
618 our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL';
619 EOT
620
621 foreach my $prefix (qw(ccflags ldflags)) {
622     my $value = fetch_string ({}, $prefix);
623     my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles");
624     if (defined $withlargefiles) {
625         $value =~ s/\Q$withlargefiles\E\b//;
626         $heavy_txt .= "${prefix}_nolargefiles='$value'\n";
627     }
628 }
629
630 foreach my $prefix (qw(libs libswanted)) {
631     my $value = fetch_string ({}, $prefix);
632     my $withlf = fetch_string ({}, 'libswanted_uselargefiles');
633     next unless defined $withlf;
634     my @lflibswanted
635        = split(' ', fetch_string ({}, 'libswanted_uselargefiles'));
636     if (@lflibswanted) {
637         my %lflibswanted;
638         @lflibswanted{@lflibswanted} = ();
639         if ($prefix eq 'libs') {
640             my @libs = grep { /^-l(.+)/ &&
641                             not exists $lflibswanted{$1} }
642                                     split(' ', fetch_string ({}, 'libs'));
643             $value = join(' ', @libs);
644         } else {
645             my @libswanted = grep { not exists $lflibswanted{$_} }
646                                   split(' ', fetch_string ({}, 'libswanted'));
647             $value = join(' ', @libswanted);
648         }
649     }
650     $heavy_txt .= "${prefix}_nolargefiles='$value'\n";
651 }
652
653 if (open(my $fh, '<', 'cflags')) {
654     my $ccwarnflags;
655     my $ccstdflags;
656     while (<$fh>) {
657         if (/^warn="(.+)"$/) {
658             $ccwarnflags = $1;
659         } elsif (/^stdflags="(.+)"$/) {
660             $ccstdflags = $1;
661         }
662     }
663     if (defined $ccwarnflags) {
664       $heavy_txt .= "ccwarnflags='$ccwarnflags'\n";
665     }
666     if (defined $ccstdflags) {
667       $heavy_txt .= "ccstdflags='$ccstdflags'\n";
668     }
669 }
670
671 $heavy_txt .= "EOVIRTUAL\n";
672
673 $heavy_txt .= <<'ENDOFGIT';
674 eval {
675         # do not have hairy conniptions if this isnt available
676         require 'Config_git.pl';
677         $Config_SH_expanded .= $Config::Git_Data;
678         1;
679 } or warn "Warning: failed to load Config_git.pl, something strange about this perl...\n";
680 ENDOFGIT
681
682 $heavy_txt .= $fetch_string;
683
684 $config_txt .= <<'ENDOFEND';
685
686 sub FETCH {
687     my($self, $key) = @_;
688
689     # check for cached value (which may be undef so we use exists not defined)
690     return exists $self->{$key} ? $self->{$key} : $self->fetch_string($key);
691 }
692
693 ENDOFEND
694
695 $heavy_txt .= <<'ENDOFEND';
696
697 my $prevpos = 0;
698
699 sub FIRSTKEY {
700     $prevpos = 0;
701     substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
702 }
703
704 sub NEXTKEY {
705 ENDOFEND
706 if ($seen_quotes{'"'}) {
707 $heavy_txt .= <<'ENDOFEND';
708     # Find out how the current key's quoted so we can skip to its end.
709     my $quote = substr($Config_SH_expanded,
710                        index($Config_SH_expanded, "=", $prevpos)+1, 1);
711     my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
712 ENDOFEND
713 } else {
714     # Just ' quotes, so it's much easier.
715 $heavy_txt .= <<'ENDOFEND';
716     my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2;
717 ENDOFEND
718 }
719 $heavy_txt .= <<'ENDOFEND';
720     my $len = index($Config_SH_expanded, "=", $pos) - $pos;
721     $prevpos = $pos;
722     $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
723 }
724
725 sub EXISTS {
726     return 1 if exists($_[0]->{$_[1]});
727
728     return(index($Config_SH_expanded, "\n$_[1]='") != -1
729 ENDOFEND
730 if ($seen_quotes{'"'}) {
731 $heavy_txt .= <<'ENDOFEND';
732            or index($Config_SH_expanded, "\n$_[1]=\"") != -1
733 ENDOFEND
734 }
735 $heavy_txt .= <<'ENDOFEND';
736           );
737 }
738
739 sub STORE  { die "\%Config::Config is read-only\n" }
740 *DELETE = *CLEAR = \*STORE; # Typeglob aliasing uses less space
741
742 sub config_sh {
743     substr $Config_SH_expanded, 1, $config_sh_len;
744 }
745
746 sub config_re {
747     my $re = shift;
748     return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
749     $Config_SH_expanded;
750 }
751
752 sub config_vars {
753     # implements -V:cfgvar option (see perlrun -V:)
754     foreach (@_) {
755         # find optional leading, trailing colons; and query-spec
756         my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/;  # flags fore and aft, 
757         # map colon-flags to print decorations
758         my $prfx = $notag ? '': "$qry=";                # tag-prefix for print
759         my $lnend = $lncont ? ' ' : ";\n";              # line ending for print
760
761         # all config-vars are by definition \w only, any \W means regex
762         if ($qry =~ /\W/) {
763             my @matches = config_re($qry);
764             print map "$_$lnend", @matches ? @matches : "$qry: not found"               if !$notag;
765             print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found"  if  $notag;
766         } else {
767             my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
768                                                    : 'UNKNOWN';
769             $v = 'undef' unless defined $v;
770             print "${prfx}'${v}'$lnend";
771         }
772     }
773 }
774
775 # Called by the real AUTOLOAD
776 sub launcher {
777     undef &AUTOLOAD;
778     goto \&$Config::AUTOLOAD;
779 }
780
781 1;
782 ENDOFEND
783
784 if ($^O eq 'os2') {
785     $config_txt .= <<'ENDOFSET';
786 my %preconfig;
787 if ($OS2::is_aout) {
788     my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m;
789     for (split ' ', $value) {
790         ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m;
791         $preconfig{$_} = $v eq 'undef' ? undef : $v;
792     }
793 }
794 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
795 sub TIEHASH { bless {%preconfig} }
796 ENDOFSET
797     # Extract the name of the DLL from the makefile to avoid duplication
798     my ($f) = grep -r, qw(GNUMakefile Makefile);
799     my $dll;
800     if (open my $fh, '<', $f) {
801         while (<$fh>) {
802             $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
803         }
804     }
805     $config_txt .= <<ENDOFSET if $dll;
806 \$preconfig{dll_name} = '$dll';
807 ENDOFSET
808 } else {
809     $config_txt .= <<'ENDOFSET';
810 sub TIEHASH {
811     bless $_[1], $_[0];
812 }
813 ENDOFSET
814 }
815
816 foreach my $key (keys %Common) {
817     my $value = fetch_string ({}, $key);
818     # Is it safe on the LHS of => ?
819     my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'";
820     if (defined $value) {
821         # Quote things for a '' string
822         $value =~ s!\\!\\\\!g;
823         $value =~ s!'!\\'!g;
824         $value = "'$value'";
825         if ($key eq 'otherlibdirs') {
826             $value = "join (':', map {relocate_inc(\$_)} split (':', $value))";
827         } elsif ($need_relocation{$key}) {
828             $value = "relocate_inc($value)";
829         }
830     } else {
831         $value = "undef";
832     }
833     $Common{$key} = "$qkey => $value";
834 }
835
836 if ($Common{byteorder}) {
837     $Common{byteorder} = 'byteorder => $byteorder';
838 }
839 my $fast_config = join '', map { "    $_,\n" } sort values %Common;
840
841 # Sanity check needed to stop an infinite loop if Config_heavy.pl fails to
842 # define &launcher for some reason (eg it got truncated)
843 $config_txt .= sprintf <<'ENDOFTIE', $fast_config;
844
845 sub DESTROY { }
846
847 sub AUTOLOAD {
848     require 'Config_heavy.pl';
849     goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
850     die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
851 }
852
853 # tie returns the object, so the value returned to require will be true.
854 tie %%Config, 'Config', {
855 %s};
856 ENDOFTIE
857
858
859 open(CONFIG_POD, '>', $Config_POD) or die "Can't open $Config_POD: $!";
860 print CONFIG_POD <<'ENDOFTAIL';
861 =head1 NAME
862
863 Config - access Perl configuration information
864
865 =head1 SYNOPSIS
866
867     use Config;
868     if ($Config{usethreads}) {
869         print "has thread support\n"
870     } 
871
872     use Config qw(myconfig config_sh config_vars config_re);
873
874     print myconfig();
875
876     print config_sh();
877
878     print config_re();
879
880     config_vars(qw(osname archname));
881
882
883 =head1 DESCRIPTION
884
885 The Config module contains all the information that was available to
886 the C<Configure> program at Perl build time (over 900 values).
887
888 Shell variables from the F<config.sh> file (written by Configure) are
889 stored in the readonly-variable C<%Config>, indexed by their names.
890
891 Values stored in config.sh as 'undef' are returned as undefined
892 values.  The perl C<exists> function can be used to check if a
893 named variable exists.
894
895 For a description of the variables, please have a look at the
896 Glossary file, as written in the Porting folder, or use the url:
897 http://perl5.git.perl.org/perl.git/blob/HEAD:/Porting/Glossary
898
899 =over 4
900
901 =item myconfig()
902
903 Returns a textual summary of the major perl configuration values.
904 See also C<-V> in L<perlrun/Command Switches>.
905
906 =item config_sh()
907
908 Returns the entire perl configuration information in the form of the
909 original config.sh shell variable assignment script.
910
911 =item config_re($regex)
912
913 Like config_sh() but returns, as a list, only the config entries who's
914 names match the $regex.
915
916 =item config_vars(@names)
917
918 Prints to STDOUT the values of the named configuration variable. Each is
919 printed on a separate line in the form:
920
921   name='value';
922
923 Names which are unknown are output as C<name='UNKNOWN';>.
924 See also C<-V:name> in L<perlrun/Command Switches>.
925
926 =item bincompat_options()
927
928 Returns a list of C pre-processor options used when compiling this F<perl>
929 binary, which affect its binary compatibility with extensions.
930 C<bincompat_options()> and C<non_bincompat_options()> are shown together in
931 the output of C<perl -V> as I<Compile-time options>.
932
933 =item non_bincompat_options()
934
935 Returns a list of C pre-processor options used when compiling this F<perl>
936 binary, which do not affect binary compatibility with extensions.
937
938 =item compile_date()
939
940 Returns the compile date (as a string), equivalent to what is shown by
941 C<perl -V>
942
943 =item local_patches()
944
945 Returns a list of the names of locally applied patches, equivalent to what
946 is shown by C<perl -V>.
947
948 =item header_files()
949
950 Returns a list of the header files that should be used as dependencies for
951 XS code, for this version of Perl on this platform.
952
953 =back
954
955 =head1 EXAMPLE
956
957 Here's a more sophisticated example of using %Config:
958
959     use Config;
960     use strict;
961
962     my %sig_num;
963     my @sig_name;
964     unless($Config{sig_name} && $Config{sig_num}) {
965         die "No sigs?";
966     } else {
967         my @names = split ' ', $Config{sig_name};
968         @sig_num{@names} = split ' ', $Config{sig_num};
969         foreach (@names) {
970             $sig_name[$sig_num{$_}] ||= $_;
971         }   
972     }
973
974     print "signal #17 = $sig_name[17]\n";
975     if ($sig_num{ALRM}) { 
976         print "SIGALRM is $sig_num{ALRM}\n";
977     }   
978
979 =head1 WARNING
980
981 Because this information is not stored within the perl executable
982 itself it is possible (but unlikely) that the information does not
983 relate to the actual perl binary which is being used to access it.
984
985 The Config module is installed into the architecture and version
986 specific library directory ($Config{installarchlib}) and it checks the
987 perl version number when loaded.
988
989 The values stored in config.sh may be either single-quoted or
990 double-quoted. Double-quoted strings are handy for those cases where you
991 need to include escape sequences in the strings. To avoid runtime variable
992 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
993 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
994 or C<\@> in double-quoted strings unless you're willing to deal with the
995 consequences. (The slashes will end up escaped and the C<$> or C<@> will
996 trigger variable interpolation)
997
998 =head1 GLOSSARY
999
1000 Most C<Config> variables are determined by the C<Configure> script
1001 on platforms supported by it (which is most UNIX platforms).  Some
1002 platforms have custom-made C<Config> variables, and may thus not have
1003 some of the variables described below, or may have extraneous variables
1004 specific to that particular port.  See the port specific documentation
1005 in such cases.
1006
1007 =cut
1008
1009 ENDOFTAIL
1010
1011 if ($Opts{glossary}) {
1012   open(GLOS, '<', $Glossary) or die "Can't open $Glossary: $!";
1013 }
1014 my %seen = ();
1015 my $text = 0;
1016 $/ = '';
1017 my $errors= 0;
1018
1019 sub process {
1020   if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
1021     my $c = substr $1, 0, 1;
1022     unless ($seen{$c}++) {
1023       print CONFIG_POD <<EOF if $text;
1024 =back
1025
1026 =cut
1027
1028 EOF
1029       print CONFIG_POD <<EOF;
1030 =head2 $c
1031
1032 =over 4
1033
1034 =cut
1035
1036 EOF
1037      $text = 1;
1038     }
1039   }
1040   elsif (!$text || !/\A\t/) {
1041     warn "Expected a Configure variable header",
1042       ($text ? " or another paragraph of description" : () ),
1043       ", instead we got:\n$_";
1044     $errors++;
1045   }
1046   s/n't/n\00t/g;                # leave can't, won't etc untouched
1047   s/^\t\s+(.*)/\n$1/gm;         # Indented lines ===> new paragraph
1048   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
1049   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
1050   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
1051   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
1052   s{
1053      (?<! [\w./<\'\"\$] )               # Only standalone file names
1054      (?! e \. g \. )            # Not e.g.
1055      (?! \. \. \. )             # Not ...
1056      (?! \d )                   # Not 5.004
1057      (?! read/ )                # Not read/write
1058      (?! etc\. )                # Not etc.
1059      (?! I/O )                  # Not I/O
1060      (
1061         \$ ?                    # Allow leading $
1062         [\w./]* [./] [\w./]*    # Require . or / inside
1063      )
1064      (?<! \. (?= [\s)] ) )      # Do not include trailing dot
1065      (?! [\w/] )                # Include all of it
1066    }
1067    (F<$1>)xg;                   # /usr/local
1068   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
1069   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
1070   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
1071   s/n[\0]t/n't/g;               # undo can't, won't damage
1072 }
1073
1074 if ($Opts{glossary}) {
1075     <GLOS>;                             # Skip the "DO NOT EDIT"
1076     <GLOS>;                             # Skip the preamble
1077   while (<GLOS>) {
1078     process;
1079     print CONFIG_POD;
1080   }
1081   if ($errors) {
1082     die "Errors encountered while processing $Glossary. ",
1083         "Header lines are expected to be of the form:\n",
1084         "NAME (CLASS):\n",
1085         "Maybe there is a malformed header?\n",
1086     ;
1087   }
1088 }
1089
1090 print CONFIG_POD <<'ENDOFTAIL';
1091
1092 =back
1093
1094 =head1 GIT DATA
1095
1096 Information on the git commit from which the current perl binary was compiled
1097 can be found in the variable C<$Config::Git_Data>.  The variable is a
1098 structured string that looks something like this:
1099
1100   git_commit_id='ea0c2dbd5f5ac6845ecc7ec6696415bf8e27bd52'
1101   git_describe='GitLive-blead-1076-gea0c2db'
1102   git_branch='smartmatch'
1103   git_uncommitted_changes=''
1104   git_commit_id_title='Commit id:'
1105   git_commit_date='2009-05-09 17:47:31 +0200'
1106
1107 Its format is not guaranteed not to change over time.
1108
1109 =head1 NOTE
1110
1111 This module contains a good example of how to use tie to implement a
1112 cache and an example of how to make a tied variable readonly to those
1113 outside of it.
1114
1115 =cut
1116
1117 ENDOFTAIL
1118
1119 close(GLOS) if $Opts{glossary};
1120 close(CONFIG_POD);
1121 print "written $Config_POD\n";
1122
1123 my $orig_config_txt = "";
1124 my $orig_heavy_txt = "";
1125 {
1126     local $/;
1127     my $fh;
1128     $orig_config_txt = <$fh> if open $fh, "<", $Config_PM;
1129     $orig_heavy_txt  = <$fh> if open $fh, "<", $Config_heavy;
1130 }
1131
1132 if ($orig_config_txt ne $config_txt or $orig_heavy_txt ne $heavy_txt) {
1133     open CONFIG, ">", $Config_PM or die "Can't open $Config_PM: $!\n";
1134     open CONFIG_HEAVY, ">", $Config_heavy or die "Can't open $Config_heavy: $!\n";
1135     print CONFIG $config_txt;
1136     print CONFIG_HEAVY $heavy_txt;
1137     close(CONFIG_HEAVY);
1138     close(CONFIG);
1139     print "updated $Config_PM\n";
1140     print "updated $Config_heavy\n";
1141 }
1142
1143 # Now do some simple tests on the Config.pm file we have created
1144 unshift(@INC,'lib');
1145 require $Config_PM;
1146 require $Config_heavy;
1147 import Config;
1148
1149 die "$0: $Config_PM not valid"
1150         unless $Config{'PERL_CONFIG_SH'} eq 'true';
1151
1152 die "$0: error processing $Config_PM"
1153         if defined($Config{'an impossible name'})
1154         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
1155         ;
1156
1157 die "$0: error processing $Config_PM"
1158         if eval '$Config{"cc"} = 1'
1159         or eval 'delete $Config{"cc"}'
1160         ;
1161
1162
1163 exit 0;
1164 # Popularity of various entries in %Config, based on a large build and test
1165 # run of code in the Fotango build system:
1166 __DATA__
1167 path_sep:       8490
1168 d_readlink:     7101
1169 d_symlink:      7101
1170 archlibexp:     4318
1171 sitearchexp:    4305
1172 sitelibexp:     4305
1173 privlibexp:     4163
1174 ldlibpthname:   4041
1175 libpth: 2134
1176 archname:       1591
1177 exe_ext:        1256
1178 scriptdir:      1155
1179 version:        1116
1180 useithreads:    1002
1181 osvers: 982
1182 osname: 851
1183 inc_version_list:       783
1184 dont_use_nlink: 779
1185 intsize:        759
1186 usevendorprefix:        642
1187 dlsrc:  624
1188 cc:     541
1189 lib_ext:        520
1190 so:     512
1191 ld:     501
1192 ccdlflags:      500
1193 ldflags:        495
1194 obj_ext:        495
1195 cccdlflags:     493
1196 lddlflags:      493
1197 ar:     492
1198 dlext:  492
1199 libc:   492
1200 ranlib: 492
1201 full_ar:        491
1202 vendorarchexp:  491
1203 vendorlibexp:   491
1204 installman1dir: 489
1205 installman3dir: 489
1206 installsitebin: 489
1207 installsiteman1dir:     489
1208 installsiteman3dir:     489
1209 installvendorman1dir:   489
1210 installvendorman3dir:   489
1211 d_flexfnam:     474
1212 eunicefix:      360
1213 d_link: 347
1214 installsitearch:        344
1215 installscript:  341
1216 installprivlib: 337
1217 binexp: 336
1218 installarchlib: 336
1219 installprefixexp:       336
1220 installsitelib: 336
1221 installstyle:   336
1222 installvendorarch:      336
1223 installvendorbin:       336
1224 installvendorlib:       336
1225 man1ext:        336
1226 man3ext:        336
1227 sh:     336
1228 siteprefixexp:  336
1229 installbin:     335
1230 usedl:  332
1231 ccflags:        285
1232 startperl:      232
1233 optimize:       231
1234 usemymalloc:    229
1235 cpprun: 228
1236 sharpbang:      228
1237 perllibs:       225
1238 usesfio:        224
1239 usethreads:     220
1240 perlpath:       218
1241 extensions:     217
1242 usesocks:       208
1243 shellflags:     198
1244 make:   191
1245 d_pwage:        189
1246 d_pwchange:     189
1247 d_pwclass:      189
1248 d_pwcomment:    189
1249 d_pwexpire:     189
1250 d_pwgecos:      189
1251 d_pwpasswd:     189
1252 d_pwquota:      189
1253 gccversion:     189
1254 libs:   186
1255 useshrplib:     186
1256 cppflags:       185
1257 ptrsize:        185
1258 shrpenv:        185
1259 static_ext:     185
1260 use5005threads: 185
1261 uselargefiles:  185
1262 alignbytes:     184
1263 byteorder:      184
1264 ccversion:      184
1265 config_args:    184
1266 cppminus:       184