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