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 "v%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 print CONFIG_HEAVY @non_v, "\n";
 299
 300 # copy config summary format from the myconfig.SH script
 301 print CONFIG_HEAVY "our \$summary : unique = <<'!END!';\n";
 302 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
 303 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
 304 do { print CONFIG_HEAVY $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
 305 close(MYCONFIG);
 306
 307 # NB. as $summary is unique, we need to copy it in a lexical variable
 308 # before expanding it, because may have been made readonly if a perl
 309 # interpreter has been cloned.
 310
 311 print CONFIG_HEAVY "\n!END!\n", <<'EOT';
 312 my $summary_expanded;
 313
 314 sub myconfig {
 315     return $summary_expanded if $summary_expanded;
 316     ($summary_expanded = $summary) =~ s{\$(\w+)}
 317                  { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge;
 318     $summary_expanded;
 319 }
 320
 321 local *_ = \my $a;
 322 $_ = <<'!END!';
 323 EOT
 324
 325 print CONFIG_HEAVY join('', sort @v_others), "!END!\n";
 326
 327 # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
 328 # the precached keys
 329 if ($Common{byteorder}) {
 330     print CONFIG $byteorder_code;
 331 } else {
 332     print CONFIG_HEAVY $byteorder_code;
 333 }
 334
 335 print CONFIG_HEAVY <<'EOT';
 336 s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
 337
 338 my $config_sh_len = length $_;
 339
 340 our $Config_SH_expanded : unique = "\n$_" . << 'EOVIRTUAL';
 341 EOT
 342
 343 foreach my $prefix (qw(ccflags ldflags)) {
 344     my $value = fetch_string ({}, $prefix);
 345     my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles");
 346     $value =~ s/\Q$withlargefiles\E\b//;
 347     print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
 348 }
 349
 350 foreach my $prefix (qw(libs libswanted)) {
 351     my $value = fetch_string ({}, $prefix);
 352     my @lflibswanted
 353        = split(' ', fetch_string ({}, 'libswanted_uselargefiles'));
 354     if (@lflibswanted) {
 355         my %lflibswanted;
 356         @lflibswanted{@lflibswanted} = ();
 357         if ($prefix eq 'libs') {
 358             my @libs = grep { /^-l(.+)/ &&
 359                             not exists $lflibswanted{$1} }
 360                                     split(' ', fetch_string ({}, 'libs'));
 361             $value = join(' ', @libs);
 362         } else {
 363             my @libswanted = grep { not exists $lflibswanted{$_} }
 364                                   split(' ', fetch_string ({}, 'libswanted'));
 365             $value = join(' ', @libswanted);
 366         }
 367     }
 368     print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
 369 }
 370
 371 print CONFIG_HEAVY "EOVIRTUAL\n";
 372
 373 print CONFIG_HEAVY $fetch_string;
 374
 375 print CONFIG <<'ENDOFEND';
 376
 377 sub FETCH {
 378     my($self, $key) = @_;
 379
 380     # check for cached value (which may be undef so we use exists not defined)
 381     return $self->{$key} if exists $self->{$key};
 382
 383     return $self->fetch_string($key);
 384 }
 385 ENDOFEND
 386
 387 print CONFIG_HEAVY <<'ENDOFEND';
 388
 389 my $prevpos = 0;
 390
 391 sub FIRSTKEY {
 392     $prevpos = 0;
 393     substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
 394 }
 395
 396 sub NEXTKEY {
 397 ENDOFEND
 398 if ($seen_quotes{'"'}) {
 399 print CONFIG_HEAVY <<'ENDOFEND';
 400     # Find out how the current key's quoted so we can skip to its end.
 401     my $quote = substr($Config_SH_expanded,
 402                        index($Config_SH_expanded, "=", $prevpos)+1, 1);
 403     my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
 404 ENDOFEND
 405 } else {
 406     # Just ' quotes, so it's much easier.
 407 print CONFIG_HEAVY <<'ENDOFEND';
 408     my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2;
 409 ENDOFEND
 410 }
 411 print CONFIG_HEAVY <<'ENDOFEND';
 412     my $len = index($Config_SH_expanded, "=", $pos) - $pos;
 413     $prevpos = $pos;
 414     $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
 415 }
 416
 417 sub EXISTS {
 418     return 1 if exists($_[0]->{$_[1]});
 419
 420     return(index($Config_SH_expanded, "\n$_[1]='") != -1
 421 ENDOFEND
 422 if ($seen_quotes{'"'}) {
 423 print CONFIG_HEAVY <<'ENDOFEND';
 424            or index($Config_SH_expanded, "\n$_[1]=\"") != -1
 425 ENDOFEND
 426 }
 427 print CONFIG_HEAVY <<'ENDOFEND';
 428           );
 429 }
 430
 431 sub STORE  { die "\%Config::Config is read-only\n" }
 432 *DELETE = \&STORE;
 433 *CLEAR  = \&STORE;
 434
 435
 436 sub config_sh {
 437     substr $Config_SH_expanded, 1, $config_sh_len;
 438 }
 439
 440 sub config_re {
 441     my $re = shift;
 442     return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
 443     $Config_SH_expanded;
 444 }
 445
 446 sub config_vars {
 447     # implements -V:cfgvar option (see perlrun -V:)
 448     foreach (@_) {
 449         # find optional leading, trailing colons; and query-spec
 450         my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/;  # flags fore and aft,
 451         # map colon-flags to print decorations
 452         my $prfx = $notag ? '': "$qry=";                # tag-prefix for print
 453         my $lnend = $lncont ? ' ' : ";\n";              # line ending for print
 454
 455         # all config-vars are by definition \w only, any \W means regex
 456         if ($qry =~ /\W/) {
 457             my @matches = config_re($qry);
 458             print map "$_$lnend", @matches ? @matches : "$qry: not found"               if !$notag;
 459             print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found"  if  $notag;
 460         } else {
 461             my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
 462                                                    : 'UNKNOWN';
 463             $v = 'undef' unless defined $v;
 464             print "${prfx}'${v}'$lnend";
 465         }
 466     }
 467 }
 468
 469 # Called by the real AUTOLOAD
 470 sub launcher {
 471     undef &AUTOLOAD;
 472     goto \&$Config::AUTOLOAD;
 473 }
 474
 475 1;
 476 ENDOFEND
 477
 478 if ($^O eq 'os2') {
 479     print CONFIG <<'ENDOFSET';
 480 my %preconfig;
 481 if ($OS2::is_aout) {
 482     my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m;
 483     for (split ' ', $value) {
 484         ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m;
 485         $preconfig{$_} = $v eq 'undef' ? undef : $v;
 486     }
 487 }
 488 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
 489 sub TIEHASH { bless {%preconfig} }
 490 ENDOFSET
 491     # Extract the name of the DLL from the makefile to avoid duplication
 492     my ($f) = grep -r, qw(GNUMakefile Makefile);
 493     my $dll;
 494     if (open my $fh, '<', $f) {
 495         while (<$fh>) {
 496             $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
 497         }
 498     }
 499     print CONFIG <<ENDOFSET if $dll;
 500 \$preconfig{dll_name} = '$dll';
 501 ENDOFSET
 502 } else {
 503     print CONFIG <<'ENDOFSET';
 504 sub TIEHASH {
 505     bless $_[1], $_[0];
 506 }
 507 ENDOFSET
 508 }
 509
 510 foreach my $key (keys %Common) {
 511     my $value = fetch_string ({}, $key);
 512     # Is it safe on the LHS of => ?
 513     my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'";
 514     if (defined $value) {
 515         # Quote things for a '' string
 516         $value =~ s!\\!\\\\!g;
 517         $value =~ s!'!\\'!g;
 518         $value = "'$value'";
 519     } else {
 520         $value = "undef";
 521     }
 522     $Common{$key} = "$qkey => $value";
 523 }
 524
 525 if ($Common{byteorder}) {
 526     $Common{byteorder} = 'byteorder => $byteorder';
 527 }
 528 my $fast_config = join '', map { "    $_,\n" } sort values %Common;
 529
 530 print CONFIG sprintf <<'ENDOFTIE', $fast_config;
 531
 532 sub DESTROY { }
 533
 534 sub AUTOLOAD {
 535     require 'Config_heavy.pl';
 536     goto \&launcher;
 537     die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
 538 }
 539
 540 tie %%Config, 'Config', {
 541 %s};
 542
 543 1;
 544 ENDOFTIE
 545
 546
 547 open(CONFIG_POD, ">lib/Config.pod") or die "Can't open lib/Config.pod: $!";
 548 print CONFIG_POD <<'ENDOFTAIL';
 549 =head1 NAME
 550
 551 Config - access Perl configuration information
 552
 553 =head1 SYNOPSIS
 554
 555     use Config;
 556     if ($Config{usethreads}) {
 557         print "has thread support\n"
 558     }
 559
 560     use Config qw(myconfig config_sh config_vars config_re);
 561
 562     print myconfig();
 563
 564     print config_sh();
 565
 566     print config_re();
 567
 568     config_vars(qw(osname archname));
 569
 570
 571 =head1 DESCRIPTION
 572
 573 The Config module contains all the information that was available to
 574 the C<Configure> program at Perl build time (over 900 values).
 575
 576 Shell variables from the F<config.sh> file (written by Configure) are
 577 stored in the readonly-variable C<%Config>, indexed by their names.
 578
 579 Values stored in config.sh as 'undef' are returned as undefined
 580 values.  The perl C<exists> function can be used to check if a
 581 named variable exists.
 582
 583 =over 4
 584
 585 =item myconfig()
 586
 587 Returns a textual summary of the major perl configuration values.
 588 See also C<-V> in L<perlrun/Switches>.
 589
 590 =item config_sh()
 591
 592 Returns the entire perl configuration information in the form of the
 593 original config.sh shell variable assignment script.
 594
 595 =item config_re($regex)
 596
 597 Like config_sh() but returns, as a list, only the config entries who's
 598 names match the $regex.
 599
 600 =item config_vars(@names)
 601
 602 Prints to STDOUT the values of the named configuration variable. Each is
 603 printed on a separate line in the form:
 604
 605   name='value';
 606
 607 Names which are unknown are output as C<name='UNKNOWN';>.
 608 See also C<-V:name> in L<perlrun/Switches>.
 609
 610 =back
 611
 612 =head1 EXAMPLE
 613
 614 Here's a more sophisticated example of using %Config:
 615
 616     use Config;
 617     use strict;
 618
 619     my %sig_num;
 620     my @sig_name;
 621     unless($Config{sig_name} && $Config{sig_num}) {
 622         die "No sigs?";
 623     } else {
 624         my @names = split ' ', $Config{sig_name};
 625         @sig_num{@names} = split ' ', $Config{sig_num};
 626         foreach (@names) {
 627             $sig_name[$sig_num{$_}] ||= $_;
 628         }
 629     }
 630
 631     print "signal #17 = $sig_name[17]\n";
 632     if ($sig_num{ALRM}) {
 633         print "SIGALRM is $sig_num{ALRM}\n";
 634     }
 635
 636 =head1 WARNING
 637
 638 Because this information is not stored within the perl executable
 639 itself it is possible (but unlikely) that the information does not
 640 relate to the actual perl binary which is being used to access it.
 641
 642 The Config module is installed into the architecture and version
 643 specific library directory ($Config{installarchlib}) and it checks the
 644 perl version number when loaded.
 645
 646 The values stored in config.sh may be either single-quoted or
 647 double-quoted. Double-quoted strings are handy for those cases where you
 648 need to include escape sequences in the strings. To avoid runtime variable
 649 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
 650 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
 651 or C<\@> in double-quoted strings unless you're willing to deal with the
 652 consequences. (The slashes will end up escaped and the C<$> or C<@> will
 653 trigger variable interpolation)
 654
 655 =head1 GLOSSARY
 656
 657 Most C<Config> variables are determined by the C<Configure> script
 658 on platforms supported by it (which is most UNIX platforms).  Some
 659 platforms have custom-made C<Config> variables, and may thus not have
 660 some of the variables described below, or may have extraneous variables
 661 specific to that particular port.  See the port specific documentation
 662 in such cases.
 663
 664 ENDOFTAIL
 665
 666 if ($Opts{glossary}) {
 667   open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!";
 668 }
 669 my %seen = ();
 670 my $text = 0;
 671 $/ = '';
 672
 673 sub process {
 674   if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
 675     my $c = substr $1, 0, 1;
 676     unless ($seen{$c}++) {
 677       print CONFIG_POD <<EOF if $text;
 678 =back
 679
 680 EOF
 681       print CONFIG_POD <<EOF;
 682 =head2 $c
 683
 684 =over 4
 685
 686 EOF
 687      $text = 1;
 688     }
 689   }
 690   elsif (!$text || !/\A\t/) {
 691     warn "Expected a Configure variable header",
 692       ($text ? " or another paragraph of description" : () );
 693   }
 694   s/n't/n\00t/g;                # leave can't, won't etc untouched
 695   s/^\t\s+(.*)/\n$1/gm;         # Indented lines ===> new paragraph
 696   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
 697   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
 698   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
 699   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
 700   s{
 701      (?<! [\w./<\'\"] )         # Only standalone file names
 702      (?! e \. g \. )            # Not e.g.
 703      (?! \. \. \. )             # Not ...
 704      (?! \d )                   # Not 5.004
 705      (?! read/ )                # Not read/write
 706      (?! etc\. )                # Not etc.
 707      (?! I/O )                  # Not I/O
 708      (
 709         \$ ?                    # Allow leading $
 710         [\w./]* [./] [\w./]*    # Require . or / inside
 711      )
 712      (?<! \. (?= [\s)] ) )      # Do not include trailing dot
 713      (?! [\w/] )                # Include all of it
 714    }
 715    (F<$1>)xg;                   # /usr/local
 716   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
 717   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
 718   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
 719   s/n[\0]t/n't/g;               # undo can't, won't damage
 720 }
 721
 722 if ($Opts{glossary}) {
 723     <GLOS>;                             # Skip the "DO NOT EDIT"
 724     <GLOS>;                             # Skip the preamble
 725   while (<GLOS>) {
 726     process;
 727     print CONFIG_POD;
 728   }
 729 }
 730
 731 print CONFIG_POD <<'ENDOFTAIL';
 732
 733 =back
 734
 735 =head1 NOTE
 736
 737 This module contains a good example of how to use tie to implement a
 738 cache and an example of how to make a tied variable readonly to those
 739 outside of it.
 740
 741 =cut
 742
 743 ENDOFTAIL
 744
 745 close(CONFIG_HEAVY);
 746 close(CONFIG);
 747 close(GLOS);
 748 close(CONFIG_POD);
 749
 750 # Now create Cross.pm if needed
 751 if ($Opts{cross}) {
 752   open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!";
 753   my $cross = <<'EOS';
 754 # typical invocation:
 755 #   perl -MCross Makefile.PL
 756 #   perl -MCross=wince -V:cc
 757 package Cross;
 758
 759 sub import {
 760   my ($package,$platform) = @_;
 761   unless (defined $platform) {
 762     # if $platform is not specified, then use last one when
 763     # 'configpm; was invoked with --cross option
 764     $platform = '***replace-marker***';
 765   }
 766   @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
 767   $::Cross::platform = $platform;
 768 }
 769
 770 1;
 771 EOS
 772   $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
 773   print CROSS $cross;
 774   close CROSS;
 775 }
 776
 777 # Now do some simple tests on the Config.pm file we have created
 778 unshift(@INC,'lib');
 779 require $Config_PM;
 780 import Config;
 781
 782 die "$0: $Config_PM not valid"
 783         unless $Config{'PERL_CONFIG_SH'} eq 'true';
 784
 785 die "$0: error processing $Config_PM"
 786         if defined($Config{'an impossible name'})
 787         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
 788         ;
 789
 790 die "$0: error processing $Config_PM"
 791         if eval '$Config{"cc"} = 1'
 792         or eval 'delete $Config{"cc"}'
 793         ;
 794
 795
 796 exit 0;
 797 # Popularity of various entries in %Config, based on a large build and test
 798 # run of code in the Fotango build system:
 799 __DATA__
 800 path_sep:       8490
 801 d_readlink:     7101
 802 d_symlink:      7101
 803 archlibexp:     4318
 804 sitearchexp:    4305
 805 sitelibexp:     4305
 806 privlibexp:     4163
 807 ldlibpthname:   4041
 808 libpth: 2134
 809 archname:       1591
 810 exe_ext:        1256
 811 scriptdir:      1155
 812 version:        1116
 813 useithreads:    1002
 814 osvers: 982
 815 osname: 851
 816 inc_version_list:       783
 817 dont_use_nlink: 779
 818 intsize:        759
 819 usevendorprefix:        642
 820 dlsrc:  624
 821 cc:     541
 822 lib_ext:        520
 823 so:     512
 824 ld:     501
 825 ccdlflags:      500
 826 ldflags:        495
 827 obj_ext:        495
 828 cccdlflags:     493
 829 lddlflags:      493
 830 ar:     492
 831 dlext:  492
 832 libc:   492
 833 ranlib: 492
 834 full_ar:        491
 835 vendorarchexp:  491
 836 vendorlibexp:   491
 837 installman1dir: 489
 838 installman3dir: 489
 839 installsitebin: 489
 840 installsiteman1dir:     489
 841 installsiteman3dir:     489
 842 installvendorman1dir:   489
 843 installvendorman3dir:   489
 844 d_flexfnam:     474
 845 eunicefix:      360
 846 d_link: 347
 847 installsitearch:        344
 848 installscript:  341
 849 installprivlib: 337
 850 binexp: 336
 851 installarchlib: 336
 852 installprefixexp:       336
 853 installsitelib: 336
 854 installstyle:   336
 855 installvendorarch:      336
 856 installvendorbin:       336
 857 installvendorlib:       336
 858 man1ext:        336
 859 man3ext:        336
 860 sh:     336
 861 siteprefixexp:  336
 862 installbin:     335
 863 usedl:  332
 864 ccflags:        285
 865 startperl:      232
 866 optimize:       231
 867 usemymalloc:    229
 868 cpprun: 228
 869 sharpbang:      228
 870 perllibs:       225
 871 usesfio:        224
 872 usethreads:     220
 873 perlpath:       218
 874 extensions:     217
 875 usesocks:       208
 876 shellflags:     198
 877 make:   191
 878 d_pwage:        189
 879 d_pwchange:     189
 880 d_pwclass:      189
 881 d_pwcomment:    189
 882 d_pwexpire:     189
 883 d_pwgecos:      189
 884 d_pwpasswd:     189
 885 d_pwquota:      189
 886 gccversion:     189
 887 libs:   186
 888 useshrplib:     186
 889 cppflags:       185
 890 ptrsize:        185
 891 shrpenv:        185
 892 static_ext:     185
 893 use5005threads: 185
 894 uselargefiles:  185
 895 alignbytes:     184
 896 byteorder:      184
 897 ccversion:      184
 898 config_args:    184
 899 cppminus:       184