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