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