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