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