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