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 sort split ' ', (Internals::V())[0];
 163 }
 164
 165 sub non_bincompat_options {
 166     return sort 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';
 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
 296
 297 my %seen_quotes;
 298 {
 299   my ($name, $val);
 300   open(CONFIG_SH, $Config_SH) || die "Can't open $Config_SH: $!";
 301   while (<CONFIG_SH>) {
 302     next if m:^#!/bin/sh:;
 303
 304     # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
 305     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/ or m/^(\w+)='(.*)'$/;
 306     my($k, $v) = ($1, $2);
 307
 308     # grandfather PATCHLEVEL and SUBVERSION and CONFIG
 309     if ($k) {
 310         if ($k eq 'PERL_VERSION') {
 311             push @v_others, "PATCHLEVEL='$v'\n";
 312         }
 313         elsif ($k eq 'PERL_SUBVERSION') {
 314             push @v_others, "SUBVERSION='$v'\n";
 315         }
 316         elsif ($k eq 'PERL_CONFIG_SH') {
 317             push @v_others, "CONFIG='$v'\n";
 318         }
 319     }
 320
 321     # We can delimit things in config.sh with either ' or ".
 322     unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
 323         push(@non_v, "#$_"); # not a name='value' line
 324         next;
 325     }
 326     my $quote = $2;
 327     if ($in_v) {
 328         $val .= $_;
 329     }
 330     else {
 331         ($name,$val) = ($1,$3);
 332     }
 333     $in_v = $val !~ /$quote\n/;
 334     next if $in_v;
 335
 336     s,/,::,g if $Extensions{$name};
 337
 338     $val =~ s/$quote\n?\z//;
 339
 340     my $line = "$name=$quote$val$quote\n";
 341     push(@v_others, $line);
 342     $seen_quotes{$quote}++;
 343   }
 344   close CONFIG_SH;
 345 }
 346
 347 # This is somewhat grim, but I want the code for parsing config.sh here and
 348 # now so that I can expand $Config{ivsize} and $Config{ivtype}
 349
 350 my $fetch_string = <<'EOT';
 351
 352 # Search for it in the big string
 353 sub fetch_string {
 354     my($self, $key) = @_;
 355
 356 EOT
 357
 358 if ($seen_quotes{'"'}) {
 359     # We need the full ' and " code
 360
 361 $fetch_string .= <<'EOT';
 362     return undef unless my ($quote_type, $value) = $Config_SH_expanded =~ /\n$key=(['"])(.*?)\1\n/s;
 363
 364     # If we had a double-quote, we'd better eval it so escape
 365     # sequences and such can be interpolated. Since the incoming
 366     # value is supposed to follow shell rules and not perl rules,
 367     # we escape any perl variable markers
 368
 369     # Historically, since " 'support' was added in change 1409, the
 370     # interpolation was done before the undef. Stick to this arguably buggy
 371     # behaviour as we're refactoring.
 372     if ($quote_type eq '"') {
 373         $value =~ s/\$/\\\$/g;
 374         $value =~ s/\@/\\\@/g;
 375         eval "\$value = \"$value\"";
 376     }
 377
 378     # So we can say "if $Config{'foo'}".
 379     $self->{$key} = $value eq 'undef' ? undef : $value; # cache it
 380 }
 381 EOT
 382
 383 } else {
 384     # We only have ' delimted.
 385
 386 $fetch_string .= <<'EOT';
 387     return undef unless $Config_SH_expanded =~ /\n$key=\'(.*?)\'\n/s;
 388     # So we can say "if $Config{'foo'}".
 389     $self->{$key} = $1 eq 'undef' ? undef : $1;
 390 }
 391 EOT
 392
 393 }
 394
 395 eval $fetch_string;
 396 die if $@;
 397
 398 # Calculation for the keys for byteorder
 399 # This is somewhat grim, but I need to run fetch_string here.
 400 our $Config_SH_expanded = join "\n", '', @v_others;
 401
 402 my $t = fetch_string ({}, 'ivtype');
 403 my $s = fetch_string ({}, 'ivsize');
 404
 405 # byteorder does exist on its own but we overlay a virtual
 406 # dynamically recomputed value.
 407
 408 # However, ivtype and ivsize will not vary for sane fat binaries
 409
 410 my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
 411
 412 my $byteorder_code;
 413 if ($s == 4 || $s == 8) {
 414     my $list = join ',', reverse(2..$s);
 415     my $format = 'a'x$s;
 416     $byteorder_code = <<"EOT";
 417
 418 my \$i = 0;
 419 foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 }
 420 \$i |= ord(1);
 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 = \&STORE;
 711 *CLEAR  = \&STORE;
 712
 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 infite loop if Config_heavy.pl fails to define
 814 # &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/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/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