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