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