configpm

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