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