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