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