configpm

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