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