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