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