configpm

   1 #!./miniperl -w
   2
   3 my $config_pm = $ARGV[0] || 'lib/Config.pm';
   4 my $glossary = $ARGV[1] || 'Porting/Glossary';
   5 @ARGV = "./config.sh";
   6
   7 # list names to put first (and hence lookup fastest)
   8 @fast = qw(archname osname osvers prefix libs libpth
   9         dynamic_ext static_ext extensions dlsrc so
  10         sig_name sig_num cc ccflags cppflags
  11         privlibexp archlibexp installprivlib installarchlib
  12         sharpbang startsh shsharp
  13 );
  14
  15 # names of things which may need to have slashes changed to double-colons
  16 @extensions = qw(dynamic_ext static_ext extensions known_extensions);
  17
  18
  19 open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
  20 $myver = sprintf "v%vd", $^V;
  21
  22 print CONFIG <<'ENDOFBEG_NOQ', <<"ENDOFBEG";
  23 package Config;
  24 use Exporter ();
  25 @EXPORT = qw(%Config);
  26 @EXPORT_OK = qw(myconfig config_sh config_vars);
  27
  28 # Define our own import method to avoid pulling in the full Exporter:
  29 sub import {
  30   my $pkg = shift;
  31   @_ = @EXPORT unless @_;
  32   my @func = grep {$_ ne '%Config'} @_;
  33   local $Exporter::ExportLevel = 1;
  34   Exporter::import('Config', @func) if @func;
  35   return if @func == @_;
  36   my $callpkg = caller(0);
  37   *{"$callpkg\::Config"} = \%Config;
  38 }
  39
  40 ENDOFBEG_NOQ
  41 die "Perl lib version ($myver) doesn't match executable version (\$])"
  42     unless \$^V;
  43
  44 \$^V eq $myver
  45   or die "Perl lib version ($myver) doesn't match executable version (" .
  46     (sprintf "v%vd",\$^V) . ")";
  47
  48 # This file was created by configpm when Perl was built. Any changes
  49 # made to this file will be lost the next time perl is built.
  50
  51 ENDOFBEG
  52
  53
  54 @fast{@fast} = @fast;
  55 @extensions{@extensions} = @extensions;
  56 @non_v=();
  57 @v_fast=();
  58 @v_others=();
  59 $in_v = 0;
  60
  61 while (<>) {
  62     next if m:^#!/bin/sh:;
  63     # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
  64     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
  65     my ($k,$v) = ($1,$2);
  66     # grandfather PATCHLEVEL and SUBVERSION and CONFIG
  67     if ($k) {
  68         if ($k eq 'PERL_VERSION') {
  69             push @v_others, "PATCHLEVEL='$v'\n";
  70         }
  71         elsif ($k eq 'PERL_SUBVERSION') {
  72             push @v_others, "SUBVERSION='$v'\n";
  73         }
  74         elsif ($k eq 'PERL_CONFIG_SH') {
  75             push @v_others, "CONFIG='$v'\n";
  76         }
  77     }
  78     # We can delimit things in config.sh with either ' or ".
  79     unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
  80         push(@non_v, "#$_"); # not a name='value' line
  81         next;
  82     }
  83     $quote = $2;
  84     if ($in_v) { $val .= $_;             }
  85     else       { ($name,$val) = ($1,$3); }
  86     $in_v = $val !~ /$quote\n/;
  87     next if $in_v;
  88     if ($extensions{$name}) { s,/,::,g }
  89     if (!$fast{$name}){ push(@v_others, "$name=$quote$val"); next; }
  90     push(@v_fast,"$name=$quote$val");
  91 }
  92
  93 foreach(@non_v){ print CONFIG $_ }
  94
  95 print CONFIG "\n",
  96     "my \$config_sh = <<'!END!';\n",
  97     join("", @v_fast, sort @v_others),
  98     "!END!\n\n";
  99
 100 # copy config summary format from the myconfig.SH script
 101
 102 print CONFIG "my \$summary = <<'!END!';\n";
 103
 104 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
 105 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
 106 do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
 107 close(MYCONFIG);
 108
 109 print CONFIG "\n!END!\n", <<'EOT';
 110 my $summary_expanded = 0;
 111
 112 sub myconfig {
 113         return $summary if $summary_expanded;
 114         $summary =~ s{\$(\w+)}
 115                      { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
 116         $summary_expanded = 1;
 117         $summary;
 118 }
 119 EOT
 120
 121 # ----
 122
 123 print CONFIG <<'ENDOFEND';
 124
 125 sub FETCH {
 126     # check for cached value (which may be undef so we use exists not defined)
 127     return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});
 128
 129     # Search for it in the big string
 130     my($value, $start, $marker, $quote_type);
 131
 132     $quote_type = "'";
 133     # Virtual entries.
 134     if ($_[1] eq 'byteorder') {
 135         # byteorder does exist on its own but we overlay a virtual
 136         # dynamically recomputed value.
 137         my $t = $Config{ivtype};
 138         my $s = $Config{ivsize};
 139         my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
 140         if ($s == 4 || $s == 8) {
 141             my $i = 0;
 142             foreach my $c (reverse(2..$s)) { $i |= ord($c); $i <<= 8 }
 143             $i |= ord(1);
 144             $value = join('', unpack('a'x$s, pack($f, $i)));
 145         } else {
 146             $value = '?'x$s;
 147         }
 148     } elsif ($_[1] =~ /^((?:cc|ld)flags|libs(?:wanted)?)_nolargefiles/) {
 149         # These are purely virtual, they do not exist, but need to
 150         # be computed on demand for largefile-incapable extensions.
 151         my $key = "${1}_uselargefiles";
 152         $value = $Config{$1};
 153         my $withlargefiles = $Config{$key};
 154         if ($key =~ /^(?:cc|ld)flags_/) {
 155             $value =~ s/\Q$withlargefiles\E\b//;
 156         } elsif ($key =~ /^libs/) {
 157             my @lflibswanted = split(' ', $Config{libswanted_uselargefiles});
 158             if (@lflibswanted) {
 159                 my %lflibswanted;
 160                 @lflibswanted{@lflibswanted} = ();
 161                 if ($key =~ /^libs_/) {
 162                     my @libs = grep { /^-l(.+)/ &&
 163                                       not exists $lflibswanted{$1} }
 164                                     split(' ', $Config{libs});
 165                     $Config{libs} = join(' ', @libs);
 166                 } elsif ($key =~ /^libswanted_/) {
 167                     my @libswanted = grep { not exists $lflibswanted{$_} }
 168                                           split(' ', $Config{libswanted});
 169                     $Config{libswanted} = join(' ', @libswanted);
 170                 }
 171             }
 172         }
 173     } else {
 174         $marker = "$_[1]=";
 175         # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
 176         # Check for the common case, ' delimeted
 177         $start = index($config_sh, "\n$marker$quote_type");
 178         # If that failed, check for " delimited
 179         if ($start == -1) {
 180             $quote_type = '"';
 181             $start = index($config_sh, "\n$marker$quote_type");
 182         }
 183         return undef if ( ($start == -1) &&  # in case it's first
 184                           (substr($config_sh, 0, length($marker)) ne $marker) );
 185         if ($start == -1) {
 186             # It's the very first thing we found. Skip $start forward
 187             # and figure out the quote mark after the =.
 188             $start = length($marker) + 1;
 189             $quote_type = substr($config_sh, $start - 1, 1);
 190         }
 191         else {
 192             $start += length($marker) + 2;
 193         }
 194         $value = substr($config_sh, $start,
 195                         index($config_sh, "$quote_type\n", $start) - $start);
 196     }
 197     # If we had a double-quote, we'd better eval it so escape
 198     # sequences and such can be interpolated. Since the incoming
 199     # value is supposed to follow shell rules and not perl rules,
 200     # we escape any perl variable markers
 201     if ($quote_type eq '"') {
 202         $value =~ s/\$/\\\$/g;
 203         $value =~ s/\@/\\\@/g;
 204         eval "\$value = \"$value\"";
 205     }
 206     #$value = sprintf($value) if $quote_type eq '"';
 207     # So we can say "if $Config{'foo'}".
 208     $value = undef if $value eq 'undef';
 209     $_[0]->{$_[1]} = $value; # cache it
 210     return $value;
 211 }
 212
 213 my $prevpos = 0;
 214
 215 sub FIRSTKEY {
 216     $prevpos = 0;
 217     # my($key) = $config_sh =~ m/^(.*?)=/;
 218     substr($config_sh, 0, index($config_sh, '=') );
 219     # $key;
 220 }
 221
 222 sub NEXTKEY {
 223     # Find out how the current key's quoted so we can skip to its end.
 224     my $quote = substr($config_sh, index($config_sh, "=", $prevpos)+1, 1);
 225     my $pos = index($config_sh, qq($quote\n), $prevpos) + 2;
 226     my $len = index($config_sh, "=", $pos) - $pos;
 227     $prevpos = $pos;
 228     $len > 0 ? substr($config_sh, $pos, $len) : undef;
 229 }
 230
 231 sub EXISTS {
 232     # exists($_[0]->{$_[1]})  or  $config_sh =~ m/^$_[1]=/m;
 233     exists($_[0]->{$_[1]}) or
 234     index($config_sh, "\n$_[1]='") != -1 or
 235     substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or
 236     index($config_sh, "\n$_[1]=\"") != -1 or
 237     substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"" or
 238     $_[1] =~ /^(?:(?:cc|ld)flags|libs(?:wanted)?)_nolargefiles$/;
 239 }
 240
 241 sub STORE  { die "\%Config::Config is read-only\n" }
 242 sub DELETE { &STORE }
 243 sub CLEAR  { &STORE }
 244
 245
 246 sub config_sh {
 247     $config_sh
 248 }
 249
 250 sub config_re {
 251     my $re = shift;
 252     my @matches = grep /^$re=/, split /^/, $config_sh;
 253     @matches ? (print @matches) : print "$re: not found\n";
 254 }
 255
 256 sub config_vars {
 257     foreach(@_){
 258         config_re($_), next if /\W/;
 259         my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
 260         $v='undef' unless defined $v;
 261         print "$_='$v';\n";
 262     }
 263 }
 264
 265 ENDOFEND
 266
 267 if ($^O eq 'os2') {
 268   print CONFIG <<'ENDOFSET';
 269 my %preconfig;
 270 if ($OS2::is_aout) {
 271     my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
 272     for (split ' ', $value) {
 273         ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
 274         $preconfig{$_} = $v eq 'undef' ? undef : $v;
 275     }
 276 }
 277 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
 278 sub TIEHASH { bless {%preconfig} }
 279 ENDOFSET
 280   # Extract the name of the DLL from the makefile to avoid duplication
 281   my ($f) = grep -r, qw(GNUMakefile Makefile);
 282   my $dll;
 283   if (open my $fh, '<', $f) {
 284     while (<$fh>) {
 285       $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
 286     }
 287   }
 288   print CONFIG <<ENDOFSET if $dll;
 289 \$preconfig{dll_name} = '$dll';
 290 ENDOFSET
 291 } else {
 292   print CONFIG <<'ENDOFSET';
 293 sub TIEHASH { bless {} }
 294 ENDOFSET
 295 }
 296
 297 print CONFIG <<'ENDOFTAIL';
 298
 299 # avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
 300 sub DESTROY { }
 301
 302 tie %Config, 'Config';
 303
 304 1;
 305 __END__
 306
 307 =head1 NAME
 308
 309 Config - access Perl configuration information
 310
 311 =head1 SYNOPSIS
 312
 313     use Config;
 314     if ($Config{'cc'} =~ /gcc/) {
 315         print "built by gcc\n";
 316     }
 317
 318     use Config qw(myconfig config_sh config_vars);
 319
 320     print myconfig();
 321
 322     print config_sh();
 323
 324     config_vars(qw(osname archname));
 325
 326
 327 =head1 DESCRIPTION
 328
 329 The Config module contains all the information that was available to
 330 the C<Configure> program at Perl build time (over 900 values).
 331
 332 Shell variables from the F<config.sh> file (written by Configure) are
 333 stored in the readonly-variable C<%Config>, indexed by their names.
 334
 335 Values stored in config.sh as 'undef' are returned as undefined
 336 values.  The perl C<exists> function can be used to check if a
 337 named variable exists.
 338
 339 =over 4
 340
 341 =item myconfig()
 342
 343 Returns a textual summary of the major perl configuration values.
 344 See also C<-V> in L<perlrun/Switches>.
 345
 346 =item config_sh()
 347
 348 Returns the entire perl configuration information in the form of the
 349 original config.sh shell variable assignment script.
 350
 351 =item config_vars(@names)
 352
 353 Prints to STDOUT the values of the named configuration variable. Each is
 354 printed on a separate line in the form:
 355
 356   name='value';
 357
 358 Names which are unknown are output as C<name='UNKNOWN';>.
 359 See also C<-V:name> in L<perlrun/Switches>.
 360
 361 =back
 362
 363 =head1 EXAMPLE
 364
 365 Here's a more sophisticated example of using %Config:
 366
 367     use Config;
 368     use strict;
 369
 370     my %sig_num;
 371     my @sig_name;
 372     unless($Config{sig_name} && $Config{sig_num}) {
 373         die "No sigs?";
 374     } else {
 375         my @names = split ' ', $Config{sig_name};
 376         @sig_num{@names} = split ' ', $Config{sig_num};
 377         foreach (@names) {
 378             $sig_name[$sig_num{$_}] ||= $_;
 379         }
 380     }
 381
 382     print "signal #17 = $sig_name[17]\n";
 383     if ($sig_num{ALRM}) {
 384         print "SIGALRM is $sig_num{ALRM}\n";
 385     }
 386
 387 =head1 WARNING
 388
 389 Because this information is not stored within the perl executable
 390 itself it is possible (but unlikely) that the information does not
 391 relate to the actual perl binary which is being used to access it.
 392
 393 The Config module is installed into the architecture and version
 394 specific library directory ($Config{installarchlib}) and it checks the
 395 perl version number when loaded.
 396
 397 The values stored in config.sh may be either single-quoted or
 398 double-quoted. Double-quoted strings are handy for those cases where you
 399 need to include escape sequences in the strings. To avoid runtime variable
 400 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
 401 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
 402 or C<\@> in double-quoted strings unless you're willing to deal with the
 403 consequences. (The slashes will end up escaped and the C<$> or C<@> will
 404 trigger variable interpolation)
 405
 406 =head1 GLOSSARY
 407
 408 Most C<Config> variables are determined by the C<Configure> script
 409 on platforms supported by it (which is most UNIX platforms).  Some
 410 platforms have custom-made C<Config> variables, and may thus not have
 411 some of the variables described below, or may have extraneous variables
 412 specific to that particular port.  See the port specific documentation
 413 in such cases.
 414
 415 ENDOFTAIL
 416
 417 open(GLOS, "<$glossary") or die "Can't open $glossary: $!";
 418 %seen = ();
 419 $text = 0;
 420 $/ = '';
 421
 422 sub process {
 423   if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
 424     my $c = substr $1, 0, 1;
 425     unless ($seen{$c}++) {
 426       print CONFIG <<EOF if $text;
 427 =back
 428
 429 EOF
 430       print CONFIG <<EOF;
 431 =head2 $c
 432
 433 =over 4
 434
 435 EOF
 436      $text = 1;
 437     }
 438   }
 439   elsif (!$text || !/\A\t/) {
 440     warn "Expected a Configure variable header",
 441       ($text ? " or another paragraph of description" : () );
 442   }
 443   s/n't/n\00t/g;                # leave can't, won't etc untouched
 444   s/^\t\s+(.*)/\n\t$1\n/gm;     # Indented lines ===> paragraphs
 445   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
 446   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
 447   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
 448   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
 449   s{
 450      (?<! [\w./<\'\"] )         # Only standalone file names
 451      (?! e \. g \. )            # Not e.g.
 452      (?! \. \. \. )             # Not ...
 453      (?! \d )                   # Not 5.004
 454      (?! read/ )                # Not read/write
 455      (?! etc\. )                # Not etc.
 456      (?! I/O )                  # Not I/O
 457      (
 458         \$ ?                    # Allow leading $
 459         [\w./]* [./] [\w./]*    # Require . or / inside
 460      )
 461      (?<! \. (?= [\s)] ) )      # Do not include trailing dot
 462      (?! [\w/] )                # Include all of it
 463    }
 464    (F<$1>)xg;                   # /usr/local
 465   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
 466   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
 467   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
 468   s/n[\0]t/n't/g;               # undo can't, won't damage
 469 }
 470
 471 <GLOS>;                         # Skip the preamble
 472 while (<GLOS>) {
 473   process;
 474   print CONFIG;
 475 }
 476
 477 print CONFIG <<'ENDOFTAIL';
 478
 479 =back
 480
 481 =head1 NOTE
 482
 483 This module contains a good example of how to use tie to implement a
 484 cache and an example of how to make a tied variable readonly to those
 485 outside of it.
 486
 487 =cut
 488
 489 ENDOFTAIL
 490
 491 close(CONFIG);
 492 close(GLOS);
 493
 494 # Now do some simple tests on the Config.pm file we have created
 495 unshift(@INC,'lib');
 496 require $config_pm;
 497 import Config;
 498
 499 die "$0: $config_pm not valid"
 500         unless $Config{'PERL_CONFIG_SH'} eq 'true';
 501
 502 die "$0: error processing $config_pm"
 503         if defined($Config{'an impossible name'})
 504         or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
 505         ;
 506
 507 die "$0: error processing $config_pm"
 508         if eval '$Config{"cc"} = 1'
 509         or eval 'delete $Config{"cc"}'
 510         ;
 511
 512
 513 exit 0;