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