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