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 CONFIGDOTSH=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 'CONFIGDOTSH') {
  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     if ($_[1] eq 'byteorder') {
 134         my $t = $Config{ivtype};
 135         my $s = $Config{ivsize};
 136         my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
 137         my $i = unpack($f, pack('C*', map { ord() } 1..$s));
 138         if ($s == 4 || $s == 8) {
 139             $value = join('', unpack('a'x$s, pack($f, $i)));
 140         } else {
 141             $value = '?'x$s;
 142         }
 143     } else {
 144         $marker = "$_[1]=";
 145         # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
 146         # Check for the common case, ' delimeted
 147         $start = index($config_sh, "\n$marker$quote_type");
 148         # If that failed, check for " delimited
 149         if ($start == -1) {
 150             $quote_type = '"';
 151             $start = index($config_sh, "\n$marker$quote_type");
 152         }
 153         return undef if ( ($start == -1) &&  # in case it's first
 154                           (substr($config_sh, 0, length($marker)) ne $marker) );
 155         if ($start == -1) {
 156             # It's the very first thing we found. Skip $start forward
 157             # and figure out the quote mark after the =.
 158             $start = length($marker) + 1;
 159             $quote_type = substr($config_sh, $start - 1, 1);
 160         }
 161         else {
 162             $start += length($marker) + 2;
 163         }
 164         $value = substr($config_sh, $start,
 165                         index($config_sh, "$quote_type\n", $start) - $start);
 166     }
 167     # If we had a double-quote, we'd better eval it so escape
 168     # sequences and such can be interpolated. Since the incoming
 169     # value is supposed to follow shell rules and not perl rules,
 170     # we escape any perl variable markers
 171     if ($quote_type eq '"') {
 172         $value =~ s/\$/\\\$/g;
 173         $value =~ s/\@/\\\@/g;
 174         eval "\$value = \"$value\"";
 175     }
 176     #$value = sprintf($value) if $quote_type eq '"';
 177     # So we can say "if $Config{'foo'}".
 178     $value = undef if $value eq 'undef';
 179     $_[0]->{$_[1]} = $value; # cache it
 180     return $value;
 181 }
 182
 183 my $prevpos = 0;
 184
 185 sub FIRSTKEY {
 186     $prevpos = 0;
 187     # my($key) = $config_sh =~ m/^(.*?)=/;
 188     substr($config_sh, 0, index($config_sh, '=') );
 189     # $key;
 190 }
 191
 192 sub NEXTKEY {
 193     # Find out how the current key's quoted so we can skip to its end.
 194     my $quote = substr($config_sh, index($config_sh, "=", $prevpos)+1, 1);
 195     my $pos = index($config_sh, qq($quote\n), $prevpos) + 2;
 196     my $len = index($config_sh, "=", $pos) - $pos;
 197     $prevpos = $pos;
 198     $len > 0 ? substr($config_sh, $pos, $len) : undef;
 199 }
 200
 201 sub EXISTS {
 202     # exists($_[0]->{$_[1]})  or  $config_sh =~ m/^$_[1]=/m;
 203     exists($_[0]->{$_[1]}) or
 204     index($config_sh, "\n$_[1]='") != -1 or
 205     substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or
 206     index($config_sh, "\n$_[1]=\"") != -1 or
 207     substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"";
 208 }
 209
 210 sub STORE  { die "\%Config::Config is read-only\n" }
 211 sub DELETE { &STORE }
 212 sub CLEAR  { &STORE }
 213
 214
 215 sub config_sh {
 216     $config_sh
 217 }
 218
 219 sub config_re {
 220     my $re = shift;
 221     my @matches = ($config_sh =~ /^$re=.*\n/mg);
 222     @matches ? (print @matches) : print "$re: not found\n";
 223 }
 224
 225 sub config_vars {
 226     foreach(@_){
 227         config_re($_), next if /\W/;
 228         my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
 229         $v='undef' unless defined $v;
 230         print "$_='$v';\n";
 231     }
 232 }
 233
 234 ENDOFEND
 235
 236 if ($^O eq 'os2') {
 237   print CONFIG <<'ENDOFSET';
 238 my %preconfig;
 239 if ($OS2::is_aout) {
 240     my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
 241     for (split ' ', $value) {
 242         ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
 243         $preconfig{$_} = $v eq 'undef' ? undef : $v;
 244     }
 245 }
 246 sub TIEHASH { bless {%preconfig} }
 247 ENDOFSET
 248 } else {
 249   print CONFIG <<'ENDOFSET';
 250 sub TIEHASH { bless {} }
 251 ENDOFSET
 252 }
 253
 254 print CONFIG <<'ENDOFTAIL';
 255
 256 # avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
 257 sub DESTROY { }
 258
 259 tie %Config, 'Config';
 260
 261 1;
 262 __END__
 263
 264 =head1 NAME
 265
 266 Config - access Perl configuration information
 267
 268 =head1 SYNOPSIS
 269
 270     use Config;
 271     if ($Config{'cc'} =~ /gcc/) {
 272         print "built by gcc\n";
 273     }
 274
 275     use Config qw(myconfig config_sh config_vars);
 276
 277     print myconfig();
 278
 279     print config_sh();
 280
 281     config_vars(qw(osname archname));
 282
 283
 284 =head1 DESCRIPTION
 285
 286 The Config module contains all the information that was available to
 287 the C<Configure> program at Perl build time (over 900 values).
 288
 289 Shell variables from the F<config.sh> file (written by Configure) are
 290 stored in the readonly-variable C<%Config>, indexed by their names.
 291
 292 Values stored in config.sh as 'undef' are returned as undefined
 293 values.  The perl C<exists> function can be used to check if a
 294 named variable exists.
 295
 296 =over 4
 297
 298 =item myconfig()
 299
 300 Returns a textual summary of the major perl configuration values.
 301 See also C<-V> in L<perlrun/Switches>.
 302
 303 =item config_sh()
 304
 305 Returns the entire perl configuration information in the form of the
 306 original config.sh shell variable assignment script.
 307
 308 =item config_vars(@names)
 309
 310 Prints to STDOUT the values of the named configuration variable. Each is
 311 printed on a separate line in the form:
 312
 313   name='value';
 314
 315 Names which are unknown are output as C<name='UNKNOWN';>.
 316 See also C<-V:name> in L<perlrun/Switches>.
 317
 318 =back
 319
 320 =head1 EXAMPLE
 321
 322 Here's a more sophisticated example of using %Config:
 323
 324     use Config;
 325     use strict;
 326
 327     my %sig_num;
 328     my @sig_name;
 329     unless($Config{sig_name} && $Config{sig_num}) {
 330         die "No sigs?";
 331     } else {
 332         my @names = split ' ', $Config{sig_name};
 333         @sig_num{@names} = split ' ', $Config{sig_num};
 334         foreach (@names) {
 335             $sig_name[$sig_num{$_}] ||= $_;
 336         }
 337     }
 338
 339     print "signal #17 = $sig_name[17]\n";
 340     if ($sig_num{ALRM}) {
 341         print "SIGALRM is $sig_num{ALRM}\n";
 342     }
 343
 344 =head1 WARNING
 345
 346 Because this information is not stored within the perl executable
 347 itself it is possible (but unlikely) that the information does not
 348 relate to the actual perl binary which is being used to access it.
 349
 350 The Config module is installed into the architecture and version
 351 specific library directory ($Config{installarchlib}) and it checks the
 352 perl version number when loaded.
 353
 354 The values stored in config.sh may be either single-quoted or
 355 double-quoted. Double-quoted strings are handy for those cases where you
 356 need to include escape sequences in the strings. To avoid runtime variable
 357 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
 358 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
 359 or C<\@> in double-quoted strings unless you're willing to deal with the
 360 consequences. (The slashes will end up escaped and the C<$> or C<@> will
 361 trigger variable interpolation)
 362
 363 =head1 GLOSSARY
 364
 365 Most C<Config> variables are determined by the C<Configure> script
 366 on platforms supported by it (which is most UNIX platforms).  Some
 367 platforms have custom-made C<Config> variables, and may thus not have
 368 some of the variables described below, or may have extraneous variables
 369 specific to that particular port.  See the port specific documentation
 370 in such cases.
 371
 372 ENDOFTAIL
 373
 374 open(GLOS, "<$glossary") or die "Can't open $glossary: $!";
 375 %seen = ();
 376 $text = 0;
 377 $/ = '';
 378
 379 sub process {
 380   s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m;
 381   my $c = substr $1, 0, 1;
 382   unless ($seen{$c}++) {
 383     print CONFIG <<EOF if $text;
 384 =back
 385
 386 EOF
 387     print CONFIG <<EOF;
 388 =head2 $c
 389
 390 =over
 391
 392 EOF
 393     $text = 1;
 394   }
 395   s/n't/n\00t/g;                # leave can't, won't etc untouched
 396   s/^\t\s+(.*)/\n\t$1\n/gm;     # Indented lines ===> paragraphs
 397   s/^(?<!\n\n)\t(.*)/$1/gm;     # Not indented lines ===> text
 398   s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
 399   s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
 400   s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
 401   s{
 402      (?<! [\w./<\'\"] )         # Only standalone file names
 403      (?! e \. g \. )            # Not e.g.
 404      (?! \. \. \. )             # Not ...
 405      (?! \d )                   # Not 5.004
 406      ( [\w./]* [./] [\w./]* )   # Require . or / inside
 407      (?<! \. (?= \s ) )         # Do not include trailing dot
 408      (?! [\w/] )                # Include all of it
 409    }
 410    (F<$1>)xg;                   # /usr/local
 411   s/((?<=\s)~\w*)/F<$1>/g;      # ~name
 412   s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;    # UNISTD
 413   s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
 414   s/n[\0]t/n't/g;               # undo can't, won't damage
 415 }
 416
 417 <GLOS>;                         # Skip the preamble
 418 while (<GLOS>) {
 419   process;
 420   print CONFIG;
 421 }
 422
 423 print CONFIG <<'ENDOFTAIL';
 424
 425 =back
 426
 427 =head1 NOTE
 428
 429 This module contains a good example of how to use tie to implement a
 430 cache and an example of how to make a tied variable readonly to those
 431 outside of it.
 432
 433 =cut
 434
 435 ENDOFTAIL
 436
 437 close(CONFIG);
 438 close(GLOS);
 439
 440 # Now do some simple tests on the Config.pm file we have created
 441 unshift(@INC,'lib');
 442 require $config_pm;
 443 import Config;
 444
 445 die "$0: $config_pm not valid"
 446         unless $Config{'CONFIGDOTSH'} eq 'true';
 447
 448 die "$0: error processing $config_pm"
 449         if defined($Config{'an impossible name'})
 450         or $Config{'CONFIGDOTSH'} ne 'true' # test cache
 451         ;
 452
 453 die "$0: error processing $config_pm"
 454         if eval '$Config{"cc"} = 1'
 455         or eval 'delete $Config{"cc"}'
 456         ;
 457
 458
 459 exit 0;