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