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