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