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