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