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