configpm

   1 #!./miniperl -w
   2
   3 $config_pm = $ARGV[0] || 'lib/Config.pm';
   4 @ARGV = "./config.sh";
   5
   6 # list names to put first (and hence lookup fastest)
   7 @fast = qw(archname osname osvers prefix libs libpth
   8         dynamic_ext static_ext extensions dlsrc so
   9         sig_name cc ccflags cppflags
  10         privlibexp archlibexp installprivlib installarchlib
  11         sharpbang startsh shsharp
  12 );
  13
  14 # names of things which may need to have slashes changed to double-colons
  15 @extensions = qw(dynamic_ext static_ext extensions known_extensions);
  16
  17
  18 open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
  19 $myver = $];
  20
  21 print CONFIG <<"ENDOFBEG";
  22 package Config;
  23 use Exporter ();
  24 \@ISA = (Exporter);
  25 \@EXPORT = qw(%Config);
  26 \@EXPORT_OK = qw(myconfig config_sh config_vars);
  27
  28 \$] == $myver
  29   or die "Perl lib version ($myver) doesn't match executable version (\$])";
  30
  31 # This file was created by configpm when Perl was built. Any changes
  32 # made to this file will be lost the next time perl is built.
  33
  34 ENDOFBEG
  35
  36
  37 @fast{@fast} = @fast;
  38 @extensions{@extensions} = @extensions;
  39 @non_v=();
  40 @v_fast=();
  41 @v_others=();
  42
  43 while (<>) {
  44     next if m:^#!/bin/sh:;
  45     # Catch CONFIG=true and PATCHLEVEL=n line from Configure.
  46     s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
  47     unless (m/^(\w+)='(.*)'\s*$/){
  48         push(@non_v, "#$_"); # not a name='value' line
  49         next;
  50     }
  51     $name = $1;
  52     if ($extensions{$name}) { s,/,::,g }
  53     if (!$fast{$name}){ push(@v_others, $_); next; }
  54     push(@v_fast,$_);
  55 }
  56
  57 foreach(@non_v){ print CONFIG $_ }
  58
  59 print CONFIG "\n",
  60     "my \$config_sh = <<'!END!';\n",
  61     join("", @v_fast, sort @v_others),
  62     "!END!\n\n";
  63
  64 # copy config summary format from the myconfig script
  65
  66 print CONFIG "my \$summary = <<'!END!';\n";
  67
  68 open(MYCONFIG,"<myconfig") || die "open myconfig failed: $!";
  69 1 while( ($_=<MYCONFIG>) !~ /^Summary of/);
  70 do { print CONFIG $_ } until ($_ = <MYCONFIG>) =~ /^\s*$/;
  71 close(MYCONFIG);
  72
  73 print CONFIG "\n!END!\n", <<'EOT';
  74 my $summary_expanded = 0;
  75
  76 sub myconfig {
  77         return $summary if $summary_expanded;
  78         $summary =~ s/\$(\w+)/$Config{$1}/ge;
  79         $summary_expanded = 1;
  80         $summary;
  81 }
  82 EOT
  83
  84 # ----
  85
  86 print CONFIG <<'ENDOFEND';
  87
  88 sub FETCH {
  89     # check for cached value (which may be undef so we use exists not defined)
  90     return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});
  91
  92     # Search for it in the big string
  93     my($value, $start, $marker);
  94     $marker = "$_[1]='";
  95     # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
  96     $start = index($config_sh, "\n$marker");
  97     return undef if ( ($start == -1) &&  # in case it's first
  98         (substr($config_sh, 0, length($marker)) ne $marker) );
  99     if ($start == -1) { $start = length($marker) }
 100         else { $start += length($marker) + 1 }
 101     $value = substr($config_sh, $start,
 102         index($config_sh, q('), $start) - $start);
 103
 104     $value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}".
 105     $_[0]->{$_[1]} = $value; # cache it
 106     return $value;
 107 }
 108
 109 my $prevpos = 0;
 110
 111 sub FIRSTKEY {
 112     $prevpos = 0;
 113     # my($key) = $config_sh =~ m/^(.*?)=/;
 114     substr($config_sh, 0, index($config_sh, '=') );
 115     # $key;
 116 }
 117
 118 sub NEXTKEY {
 119     my $pos = index($config_sh, "\n", $prevpos) + 1;
 120     my $len = index($config_sh, "=", $pos) - $pos;
 121     $prevpos = $pos;
 122     $len > 0 ? substr($config_sh, $pos, $len) : undef;
 123 }
 124
 125 sub EXISTS {
 126     # exists($_[0]->{$_[1]})  or  $config_sh =~ m/^$_[1]=/m;
 127     exists($_[0]->{$_[1]}) or
 128     index($config_sh, "\n$_[1]='") != -1 or
 129     substr($config_sh, 0, length($_[1])+2) eq "$_[1]='";
 130 }
 131
 132 sub STORE  { die "\%Config::Config is read-only\n" }
 133 sub DELETE { &STORE }
 134 sub CLEAR  { &STORE }
 135
 136
 137 sub config_sh {
 138     $config_sh
 139 }
 140
 141 sub config_re {
 142     my $re = shift;
 143     my @matches = ($config_sh =~ /^$re=.*\n/mg);
 144     @matches ? (print @matches) : print "$re: not found\n";
 145 }
 146
 147 sub config_vars {
 148     foreach(@_){
 149         config_re($_), next if /\W/;
 150         my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
 151         $v='undef' unless defined $v;
 152         print "$_='$v';\n";
 153     }
 154 }
 155
 156 ENDOFEND
 157
 158 if ($^O eq 'os2') {
 159   print CONFIG <<'ENDOFSET';
 160 my %preconfig;
 161 if ($OS2::is_aout) {
 162     my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
 163     for (split ' ', $value) {
 164         ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
 165         $preconfig{$_} = $v eq 'undef' ? undef : $v;
 166     }
 167 }
 168 sub TIEHASH { bless {%preconfig} }
 169 ENDOFSET
 170 } else {
 171   print CONFIG <<'ENDOFSET';
 172 sub TIEHASH { bless {} }
 173 ENDOFSET
 174 }
 175
 176 print CONFIG <<'ENDOFTAIL';
 177
 178 tie %Config, 'Config';
 179
 180 1;
 181 __END__
 182
 183 =head1 NAME
 184
 185 Config - access Perl configuration information
 186
 187 =head1 SYNOPSIS
 188
 189     use Config;
 190     if ($Config{'cc'} =~ /gcc/) {
 191         print "built by gcc\n";
 192     }
 193
 194     use Config qw(myconfig config_sh config_vars);
 195
 196     print myconfig();
 197
 198     print config_sh();
 199
 200     config_vars(qw(osname archname));
 201
 202
 203 =head1 DESCRIPTION
 204
 205 The Config module contains all the information that was available to
 206 the C<Configure> program at Perl build time (over 900 values).
 207
 208 Shell variables from the F<config.sh> file (written by Configure) are
 209 stored in the readonly-variable C<%Config>, indexed by their names.
 210
 211 Values stored in config.sh as 'undef' are returned as undefined
 212 values.  The perl C<exists> function can be used to check if a
 213 named variable exists.
 214
 215 =over 4
 216
 217 =item myconfig()
 218
 219 Returns a textual summary of the major perl configuration values.
 220 See also C<-V> in L<perlrun/Switches>.
 221
 222 =item config_sh()
 223
 224 Returns the entire perl configuration information in the form of the
 225 original config.sh shell variable assignment script.
 226
 227 =item config_vars(@names)
 228
 229 Prints to STDOUT the values of the named configuration variable. Each is
 230 printed on a separate line in the form:
 231
 232   name='value';
 233
 234 Names which are unknown are output as C<name='UNKNOWN';>.
 235 See also C<-V:name> in L<perlrun/Switches>.
 236
 237 =back
 238
 239 =head1 EXAMPLE
 240
 241 Here's a more sophisticated example of using %Config:
 242
 243     use Config;
 244
 245     defined $Config{sig_name} || die "No sigs?";
 246     foreach $name (split(' ', $Config{sig_name})) {
 247         $signo{$name} = $i;
 248         $signame[$i] = $name;
 249         $i++;
 250     }
 251
 252     print "signal #17 = $signame[17]\n";
 253     if ($signo{ALRM}) {
 254         print "SIGALRM is $signo{ALRM}\n";
 255     }
 256
 257 =head1 WARNING
 258
 259 Because this information is not stored within the perl executable
 260 itself it is possible (but unlikely) that the information does not
 261 relate to the actual perl binary which is being used to access it.
 262
 263 The Config module is installed into the architecture and version
 264 specific library directory ($Config{installarchlib}) and it checks the
 265 perl version number when loaded.
 266
 267 =head1 NOTE
 268
 269 This module contains a good example of how to use tie to implement a
 270 cache and an example of how to make a tied variable readonly to those
 271 outside of it.
 272
 273 =cut
 274
 275 ENDOFTAIL
 276
 277 close(CONFIG);
 278
 279 # Now do some simple tests on the Config.pm file we have created
 280 unshift(@INC,'lib');
 281 require $config_pm;
 282 import Config;
 283
 284 die "$0: $config_pm not valid"
 285         unless $Config{'CONFIG'} eq 'true';
 286
 287 die "$0: error processing $config_pm"
 288         if defined($Config{'an impossible name'})
 289         or $Config{'CONFIG'} ne 'true' # test cache
 290         ;
 291
 292 die "$0: error processing $config_pm"
 293         if eval '$Config{"cc"} = 1'
 294         or eval 'delete $Config{"cc"}'
 295         ;
 296
 297
 298 exit 0;