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