configpm

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