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