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