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