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