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