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