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(prefixexp
 302
 303                          archlibexp
 304                          html1direxp
 305                          html3direxp
 306                          man1direxp
 307                          man3direxp
 308                          privlibexp
 309                          scriptdirexp
 310                          sitearchexp
 311                          sitebinexp
 312                          sitehtml1direxp
 313                          sitehtml3direxp
 314                          sitelibexp
 315                          siteman1direxp
 316                          siteman3direxp
 317                          sitescriptexp
 318                          vendorarchexp
 319                          vendorbinexp
 320                          vendorhtml1direxp
 321                          vendorhtml3direxp
 322                          vendorlibexp
 323                          vendorman1direxp
 324                          vendorman3direxp
 325                          vendorscriptexp
 326
 327                          siteprefixexp
 328                          sitelib_stem
 329                          vendorlib_stem
 330
 331                          installarchlib
 332                          installhtml1dir
 333                          installhtml3dir
 334                          installman1dir
 335                          installman3dir
 336                          installprefix
 337                          installprefixexp
 338                          installprivlib
 339                          installscript
 340                          installsitearch
 341                          installsitebin
 342                          installsitehtml1dir
 343                          installsitehtml3dir
 344                          installsitelib
 345                          installsiteman1dir
 346                          installsiteman3dir
 347                          installsitescript
 348                          installvendorarch
 349                          installvendorbin
 350                          installvendorhtml1dir
 351                          installvendorhtml3dir
 352                          installvendorlib
 353                          installvendorman1dir
 354                          installvendorman3dir
 355                          installvendorscript
 356                          )) {
 357         push @need_relocation, $what if fetch_string({}, $what) =~ m!^\.\.\./!;
 358     }
 359 }
 360
 361 my %need_relocation;
 362 @need_relocation{@need_relocation} = @need_relocation;
 363
 364 # This can have .../ anywhere:
 365 if (fetch_string({}, 'otherlibdirs') =~ m!\.\.\./!) {
 366     $need_relocation{otherlibdirs} = 'otherlibdirs';
 367 }
 368
 369 my $relocation_code = <<'EOT';
 370
 371 sub relocate_inc {
 372   my $libdir = shift;
 373   return $libdir unless $libdir =~ s!^\.\.\./!!;
 374   my $prefix = $^X;
 375   if ($prefix =~ s!/[^/]*$!!) {
 376     while ($libdir =~ m!^\.\./!) {
 377       # Loop while $libdir starts "../" and $prefix still has a trailing
 378       # directory
 379       last unless $prefix =~ s!/([^/]+)$!!;
 380       # but bail out if the directory we picked off the end of $prefix is .
 381       # or ..
 382       if ($1 eq '.' or $1 eq '..') {
 383         # Undo! This should be rare, hence code it this way rather than a
 384         # check each time before the s!!! above.
 385         $prefix = "$prefix/$1";
 386         last;
 387       }
 388       # Remove that leading ../ and loop again
 389       substr ($libdir, 0, 3, '');
 390     }
 391     $libdir = "$prefix/$libdir";
 392   }
 393   $libdir;
 394 }
 395 EOT
 396
 397 if (%need_relocation) {
 398   my $relocations_in_common;
 399   # otherlibdirs only features in the hash
 400   foreach (keys %need_relocation) {
 401     $relocations_in_common++ if $Common{$_};
 402   }
 403   if ($relocations_in_common) {
 404     print CONFIG $relocation_code;
 405   } else {
 406     print CONFIG_HEAVY $relocation_code;
 407   }
 408 }
 409
 410 print CONFIG_HEAVY @non_v, "\n";
 411
 412 # copy config summary format from the myconfig.SH script
 413 print CONFIG_HEAVY "our \$summary = <<'!END!';\n";
 414 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
 415 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
 416 do { print CONFIG_HEAVY $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
 417 close(MYCONFIG);
 418
 419 print CONFIG_HEAVY "\n!END!\n", <<'EOT';
 420 my $summary_expanded;
 421
 422 sub myconfig {
 423     return $summary_expanded if $summary_expanded;
 424     ($summary_expanded = $summary) =~ s{\$(\w+)}
 425                  { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge;
 426     $summary_expanded;
 427 }
 428
 429 local *_ = \my $a;
 430 $_ = <<'!END!';
 431 EOT
 432
 433 print CONFIG_HEAVY join('', sort @v_others), "!END!\n";
 434
 435 # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
 436 # the precached keys
 437 if ($Common{byteorder}) {
 438     print CONFIG $byteorder_code;
 439 } else {
 440     print CONFIG_HEAVY $byteorder_code;
 441 }
 442
 443 if (@need_relocation) {
 444 print CONFIG_HEAVY 'foreach my $what (qw(', join (' ', @need_relocation),
 445       ")) {\n", <<'EOT';
 446     s<^($what=)(['"])(.*?)\2>
 447      <$1 . $2 . relocate_inc($3) . $2 . "\n" .
 448       'raw_' . $1 . $2 . $3 . $2>me;
 449 }
 450 EOT
 451 # Currently it only makes sense to do the ... relocation on Unix, so there's
 452 # no need to emulate the "which separator for this platform" logic in perl.c -
 453 # ':' will always be applicable
 454 if ($need_relocation{otherlibdirs}) {
 455 print CONFIG_HEAVY << 'EOT';
 456 s{^(otherlibdirs=)(['"])(.*?)\2}
 457  {$1 . $2 . join ':', map {relocate_inc($_)} split ':', $3 . $2}me;
 458 EOT
 459 }
 460 }
 461
 462 print CONFIG_HEAVY <<'EOT';
 463 s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
 464
 465 my $config_sh_len = length $_;
 466
 467 our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL';
 468 EOT
 469
 470 foreach my $prefix (qw(ccflags ldflags)) {
 471     my $value = fetch_string ({}, $prefix);
 472     my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles");
 473     if (defined $withlargefiles) {
 474         $value =~ s/\Q$withlargefiles\E\b//;
 475         print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
 476     }
 477 }
 478
 479 foreach my $prefix (qw(libs libswanted)) {
 480     my $value = fetch_string ({}, $prefix);
 481     my $withlf = fetch_string ({}, 'libswanted_uselargefiles');
 482     next unless defined $withlf;
 483     my @lflibswanted
 484        = split(' ', fetch_string ({}, 'libswanted_uselargefiles'));
 485     if (@lflibswanted) {
 486         my %lflibswanted;
 487         @lflibswanted{@lflibswanted} = ();
 488         if ($prefix eq 'libs') {
 489             my @libs = grep { /^-l(.+)/ &&
 490                             not exists $lflibswanted{$1} }
 491                                     split(' ', fetch_string ({}, 'libs'));
 492             $value = join(' ', @libs);
 493         } else {
 494             my @libswanted = grep { not exists $lflibswanted{$_} }
 495                                   split(' ', fetch_string ({}, 'libswanted'));
 496             $value = join(' ', @libswanted);
 497         }
 498     }
 499     print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
 500 }
 501
 502 print CONFIG_HEAVY "EOVIRTUAL\n";
 503
 504 print CONFIG_HEAVY $fetch_string;
 505
 506 print CONFIG <<'ENDOFEND';
 507
 508 sub FETCH {
 509     my($self, $key) = @_;
 510
 511     # check for cached value (which may be undef so we use exists not defined)
 512     return $self->{$key} if exists $self->{$key};
 513
 514     return $self->fetch_string($key);
 515 }
 516 ENDOFEND
 517
 518 print CONFIG_HEAVY <<'ENDOFEND';
 519
 520 my $prevpos = 0;
 521
 522 sub FIRSTKEY {
 523     $prevpos = 0;
 524     substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
 525 }
 526
 527 sub NEXTKEY {
 528 ENDOFEND
 529 if ($seen_quotes{'"'}) {
 530 print CONFIG_HEAVY <<'ENDOFEND';
 531     # Find out how the current key's quoted so we can skip to its end.
 532     my $quote = substr($Config_SH_expanded,
 533                        index($Config_SH_expanded, "=", $prevpos)+1, 1);
 534     my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
 535 ENDOFEND
 536 } else {
 537     # Just ' quotes, so it's much easier.
 538 print CONFIG_HEAVY <<'ENDOFEND';
 539     my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2;
 540 ENDOFEND
 541 }
 542 print CONFIG_HEAVY <<'ENDOFEND';
 543     my $len = index($Config_SH_expanded, "=", $pos) - $pos;
 544     $prevpos = $pos;
 545     $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
 546 }
 547
 548 sub EXISTS {
 549     return 1 if exists($_[0]->{$_[1]});
 550
 551     return(index($Config_SH_expanded, "\n$_[1]='") != -1
 552 ENDOFEND
 553 if ($seen_quotes{'"'}) {
 554 print CONFIG_HEAVY <<'ENDOFEND';
 555            or index($Config_SH_expanded, "\n$_[1]=\"") != -1
 556 ENDOFEND
 557 }
 558 print CONFIG_HEAVY <<'ENDOFEND';
 559           );
 560 }
 561
 562 sub STORE  { die "\%Config::Config is read-only\n" }
 563 *DELETE = \&STORE;
 564 *CLEAR  = \&STORE;
 565
 566
 567 sub config_sh {
 568     substr $Config_SH_expanded, 1, $config_sh_len;
 569 }
 570
 571 sub config_re {
 572     my $re = shift;
 573     return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
 574     $Config_SH_expanded;
 575 }
 576
 577 sub config_vars {
 578     # implements -V:cfgvar option (see perlrun -V:)
 579     foreach (@_) {
 580         # find optional leading, trailing colons; and query-spec
 581         my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/;  # flags fore and aft,
 582         # map colon-flags to print decorations
 583         my $prfx = $notag ? '': "$qry=";                # tag-prefix for print
 584         my $lnend = $lncont ? ' ' : ";\n";              # line ending for print
 585
 586         # all config-vars are by definition \w only, any \W means regex
 587         if ($qry =~ /\W/) {
 588             my @matches = config_re($qry);
 589             print map "$_$lnend", @matches ? @matches : "$qry: not found"               if !$notag;
 590             print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found"  if  $notag;
 591         } else {
 592             my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
 593                                                    : 'UNKNOWN';
 594             $v = 'undef' unless defined $v;
 595             print "${prfx}'${v}'$lnend";
 596         }
 597     }
 598 }
 599
 600 # Called by the real AUTOLOAD
 601 sub launcher {
 602     undef &AUTOLOAD;
 603     goto \&$Config::AUTOLOAD;
 604 }
 605
 606 1;
 607 ENDOFEND
 608
 609 if ($^O eq 'os2') {
 610     print CONFIG <<'ENDOFSET';
 611 my %preconfig;
 612 if ($OS2::is_aout) {
 613     my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m;
 614     for (split ' ', $value) {
 615         ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m;
 616         $preconfig{$_} = $v eq 'undef' ? undef : $v;
 617     }
 618 }
 619 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
 620 sub TIEHASH { bless {%preconfig} }
 621 ENDOFSET
 622     # Extract the name of the DLL from the makefile to avoid duplication
 623     my ($f) = grep -r, qw(GNUMakefile Makefile);
 624     my $dll;
 625     if (open my $fh, '<', $f) {
 626         while (<$fh>) {
 627             $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
 628         }
 629     }
 630     print CONFIG <<ENDOFSET if $dll;
 631 \$preconfig{dll_name} = '$dll';
 632 ENDOFSET
 633 } else {
 634     print CONFIG <<'ENDOFSET';
 635 sub TIEHASH {
 636     bless $_[1], $_[0];
 637 }
 638 ENDOFSET
 639 }
 640
 641 foreach my $key (keys %Common) {
 642     my $value = fetch_string ({}, $key);
 643     # Is it safe on the LHS of => ?
 644     my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'";
 645     if (defined $value) {
 646         # Quote things for a '' string
 647         $value =~ s!\\!\\\\!g;
 648         $value =~ s!'!\\'!g;
 649         $value = "'$value'";
 650         if ($key eq 'otherlibdirs') {
 651             $value = "join (':', map {relocate_inc(\$_)} split (':', $value))";
 652         } elsif ($need_relocation{$key}) {
 653             $value = "relocate_inc($value)";
 654         }
 655     } else {
 656         $value = "undef";
 657     }
 658     $Common{$key} = "$qkey => $value";
 659 }
 660
 661 if ($Common{byteorder}) {
 662     $Common{byteorder} = 'byteorder => $byteorder';
 663 }
 664 my $fast_config = join '', map { "    $_,\n" } sort values %Common;
 665
 666 # Sanity check needed to stop an infite loop if Config_heavy.pl fails to define
 667 # &launcher for some reason (eg it got truncated)
 668 print CONFIG sprintf <<'ENDOFTIE', $fast_config;
 669
 670 sub DESTROY { }
 671
 672 sub AUTOLOAD {
 673     require 'Config_heavy.pl';
 674     goto \&launcher unless $Config::AUTOLOAD =~ /launcher$/;
 675     die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
 676 }
 677
 678 # tie returns the object, so the value returned to require will be true.
 679 tie %%Config, 'Config', {
 680 %s};
 681 ENDOFTIE
 682
 683
 684 open(CONFIG_POD, ">lib/Config.pod") or die "Can't open lib/Config.pod: $!";
 685 print CONFIG_POD <<'ENDOFTAIL';
 686 =head1 NAME
 687
 688 Config - access Perl configuration information
 689
 690 =head1 SYNOPSIS
 691
 692     use Config;
 693     if ($Config{usethreads}) {
 694         print "has thread support\n"
 695     }
 696
 697     use Config qw(myconfig config_sh config_vars config_re);
 698
 699     print myconfig();
 700
 701     print config_sh();
 702
 703     print config_re();
 704
 705     config_vars(qw(osname archname));
 706
 707
 708 =head1 DESCRIPTION
 709
 710 The Config module contains all the information that was available to
 711 the C<Configure> program at Perl build time (over 900 values).
 712
 713 Shell variables from the F<config.sh> file (written by Configure) are
 714 stored in the readonly-variable C<%Config>, indexed by their names.
 715
 716 Values stored in config.sh as 'undef' are returned as undefined
 717 values.  The perl C<exists> function can be used to check if a
 718 named variable exists.
 719
 720 =over 4
 721
 722 =item myconfig()
 723
 724 Returns a textual summary of the major perl configuration values.
 725 See also C<-V> in L<perlrun/Switches>.
 726
 727 =item config_sh()
 728
 729 Returns the entire perl configuration information in the form of the
 730 original config.sh shell variable assignment script.
 731
 732 =item config_re($regex)
 733
 734 Like config_sh() but returns, as a list, only the config entries who's
 735 names match the $regex.
 736
 737 =item config_vars(@names)
 738
 739 Prints to STDOUT the values of the named configuration variable. Each is
 740 printed on a separate line in the form:
 741
 742   name='value';
 743
 744 Names which are unknown are output as C<name='UNKNOWN';>.
 745 See also C<-V:name> in L<perlrun/Switches>.
 746
 747 =back
 748
 749 =head1 EXAMPLE
 750
 751 Here's a more sophisticated example of using %Config:
 752
 753     use Config;
 754     use strict;
 755
 756     my %sig_num;
 757     my @sig_name;
 758     unless($Config{sig_name} && $Config{sig_num}) {
 759         die "No sigs?";
 760     } else {
 761         my @names = split ' ', $Config{sig_name};
 762         @sig_num{@names} = split ' ', $Config{sig_num};
 763         foreach (@names) {
 764             $sig_name[$sig_num{$_}] ||= $_;
 765         }
 766     }
 767
 768     print "signal #17 = $sig_name[17]\n";
 769     if ($sig_num{ALRM}) {
 770         print "SIGALRM is $sig_num{ALRM}\n";
 771     }
 772
 773 =head1 WARNING
 774
 775 Because this information is not stored within the perl executable
 776 itself it is possible (but unlikely) that the information does not
 777 relate to the actual perl binary which is being used to access it.
 778
 779 The Config module is installed into the architecture and version
 780 specific library directory ($Config{installarchlib}) and it checks the
 781 perl version number when loaded.
 782
 783 The values stored in config.sh may be either single-quoted or
 784 double-quoted. Double-quoted strings are handy for those cases where you
 785 need to include escape sequences in the strings. To avoid runtime variable
 786 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
 787 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
 788 or C<\@> in double-quoted strings unless you're willing to deal with the
 789 consequences. (The slashes will end up escaped and the C<$> or C<@> will
 790 trigger variable interpolation)
 791
 792 =head1 GLOSSARY
 793
 794 Most C<Config> variables are determined by the C<Configure> script
 795 on platforms supported by it (which is most UNIX platforms).  Some
 796 platforms have custom-made C<Config> variables, and may thus not have
 797 some of the variables described below, or may have extraneous variables
 798 specific to that particular port.  See the port specific documentation
 799 in such cases.
 800
 801 ENDOFTAIL
 802
 803 if ($Opts{glossary}) {
 804   open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!";
 805 }
 806 my %seen = ();
 807 my $text = 0;
 808 $/ = '';
 809
 810 sub process {
 811   if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
 812     my $c = substr $1, 0, 1;
 813     unless ($seen{$c}++) {
 814       print CONFIG_POD <<EOF if $text;
 815 =back
 816
 817 EOF
 818       print CONFIG_POD <<EOF;
 819 =head2 $c
 820
 821 =over 4
 822
 823 EOF
 824      $text = 1;
 825     }
 826   }
 827   elsif (!$text || !/\A\t/) {
 828     warn "Expected a Configure variable header",
 829       ($text ? " or another paragraph of description" : () );
 830   }
 831   s/n't/n\00t/g;                # leave can't, won't etc untouched
 832   s/^\t\s+(.*)/\n$1/gm;         # Indented lines ===> new paragraph
 833   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
 834   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
 835   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
 836   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
 837   s{
 838      (?<! [\w./<\'\"] )         # Only standalone file names
 839      (?! e \. g \. )            # Not e.g.
 840      (?! \. \. \. )             # Not ...
 841      (?! \d )                   # Not 5.004
 842      (?! read/ )                # Not read/write
 843      (?! etc\. )                # Not etc.
 844      (?! I/O )                  # Not I/O
 845      (
 846         \$ ?                    # Allow leading $
 847         [\w./]* [./] [\w./]*    # Require . or / inside
 848      )
 849      (?<! \. (?= [\s)] ) )      # Do not include trailing dot
 850      (?! [\w/] )                # Include all of it
 851    }
 852    (F<$1>)xg;                   # /usr/local
 853   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
 854   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
 855   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
 856   s/n[\0]t/n't/g;               # undo can't, won't damage
 857 }
 858
 859 if ($Opts{glossary}) {
 860     <GLOS>;                             # Skip the "DO NOT EDIT"
 861     <GLOS>;                             # Skip the preamble
 862   while (<GLOS>) {
 863     process;
 864     print CONFIG_POD;
 865   }
 866 }
 867
 868 print CONFIG_POD <<'ENDOFTAIL';
 869
 870 =back
 871
 872 =head1 NOTE
 873
 874 This module contains a good example of how to use tie to implement a
 875 cache and an example of how to make a tied variable readonly to those
 876 outside of it.
 877
 878 =cut
 879
 880 ENDOFTAIL
 881
 882 close(CONFIG_HEAVY);
 883 close(CONFIG);
 884 close(GLOS);
 885 close(CONFIG_POD);
 886
 887 # Now create Cross.pm if needed
 888 if ($Opts{cross}) {
 889   open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!";
 890   my $cross = <<'EOS';
 891 # typical invocation:
 892 #   perl -MCross Makefile.PL
 893 #   perl -MCross=wince -V:cc
 894 package Cross;
 895
 896 sub import {
 897   my ($package,$platform) = @_;
 898   unless (defined $platform) {
 899     # if $platform is not specified, then use last one when
 900     # 'configpm; was invoked with --cross option
 901     $platform = '***replace-marker***';
 902   }
 903   @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
 904   $::Cross::platform = $platform;
 905 }
 906
 907 1;
 908 EOS
 909   $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
 910   print CROSS $cross;
 911   close CROSS;
 912   unshift(@INC,"xlib/$Opts{cross}");
 913 }
 914
 915 # Now do some simple tests on the Config.pm file we have created
 916 unshift(@INC,'lib');
 917 unshift(@INC,'xlib/symbian') if $Opts{cross};
 918 require $Config_PM;
 919 require $Config_heavy;
 920 import Config;
 921
 922 die "$0: $Config_PM not valid"
 923         unless $Config{'PERL_CONFIG_SH'} eq 'true';
 924
 925 die "$0: error processing $Config_PM"
 926         if defined($Config{'an impossible name'})
 927         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
 928         ;
 929
 930 die "$0: error processing $Config_PM"
 931         if eval '$Config{"cc"} = 1'
 932         or eval 'delete $Config{"cc"}'
 933         ;
 934
 935
 936 exit 0;
 937 # Popularity of various entries in %Config, based on a large build and test
 938 # run of code in the Fotango build system:
 939 __DATA__
 940 path_sep:       8490
 941 d_readlink:     7101
 942 d_symlink:      7101
 943 archlibexp:     4318
 944 sitearchexp:    4305
 945 sitelibexp:     4305
 946 privlibexp:     4163
 947 ldlibpthname:   4041
 948 libpth: 2134
 949 archname:       1591
 950 exe_ext:        1256
 951 scriptdir:      1155
 952 version:        1116
 953 useithreads:    1002
 954 osvers: 982
 955 osname: 851
 956 inc_version_list:       783
 957 dont_use_nlink: 779
 958 intsize:        759
 959 usevendorprefix:        642
 960 dlsrc:  624
 961 cc:     541
 962 lib_ext:        520
 963 so:     512
 964 ld:     501
 965 ccdlflags:      500
 966 ldflags:        495
 967 obj_ext:        495
 968 cccdlflags:     493
 969 lddlflags:      493
 970 ar:     492
 971 dlext:  492
 972 libc:   492
 973 ranlib: 492
 974 full_ar:        491
 975 vendorarchexp:  491
 976 vendorlibexp:   491
 977 installman1dir: 489
 978 installman3dir: 489
 979 installsitebin: 489
 980 installsiteman1dir:     489
 981 installsiteman3dir:     489
 982 installvendorman1dir:   489
 983 installvendorman3dir:   489
 984 d_flexfnam:     474
 985 eunicefix:      360
 986 d_link: 347
 987 installsitearch:        344
 988 installscript:  341
 989 installprivlib: 337
 990 binexp: 336
 991 installarchlib: 336
 992 installprefixexp:       336
 993 installsitelib: 336
 994 installstyle:   336
 995 installvendorarch:      336
 996 installvendorbin:       336
 997 installvendorlib:       336
 998 man1ext:        336
 999 man3ext:        336
1000 sh:     336
1001 siteprefixexp:  336
1002 installbin:     335
1003 usedl:  332
1004 ccflags:        285
1005 startperl:      232
1006 optimize:       231
1007 usemymalloc:    229
1008 cpprun: 228
1009 sharpbang:      228
1010 perllibs:       225
1011 usesfio:        224
1012 usethreads:     220
1013 perlpath:       218
1014 extensions:     217
1015 usesocks:       208
1016 shellflags:     198
1017 make:   191
1018 d_pwage:        189
1019 d_pwchange:     189
1020 d_pwclass:      189
1021 d_pwcomment:    189
1022 d_pwexpire:     189
1023 d_pwgecos:      189
1024 d_pwpasswd:     189
1025 d_pwquota:      189
1026 gccversion:     189
1027 libs:   186
1028 useshrplib:     186
1029 cppflags:       185
1030 ptrsize:        185
1031 shrpenv:        185
1032 static_ext:     185
1033 use5005threads: 185
1034 uselargefiles:  185
1035 alignbytes:     184
1036 byteorder:      184
1037 ccversion:      184
1038 config_args:    184
1039 cppminus:       184