3 use vars qw(%Config $Config_SH_expanded);
5 my $how_many_common = 22;
7 # commonly used names to precache (and hence lookup fastest)
10 while ($how_many_common--) {
13 /^(\S+):\s*(\d+)$/ or die "Malformed line '$_'";
17 # names of things which may need to have slashes changed to double-colons
18 my %Extensions = map {($_,$_)}
19 qw(dynamic_ext static_ext extensions known_extensions);
21 # allowed opts as well as specifies default and initial values
23 'cross' => '', # --cross=PLATFORM - crosscompiling for PLATFORM
24 'glossary' => 1, # --no-glossary - no glossary file inclusion,
26 'heavy' => '', # pathname of the Config_heavy.pl file
30 # user specified options
33 (map {/^--([\-_\w]+)=(.*)$/} @ARGV),
34 # --opt --no-opt --noopt
35 (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV),
38 my %opts = (%Allowed_Opts, %given_opts);
40 for my $opt (grep {!exists $Allowed_Opts{$_}} keys %given_opts) {
41 die "option '$opt' is not recognized";
43 @ARGV = grep {!/^--/} @ARGV;
51 my ($Config_PM, $Config_heavy);
52 my $Glossary = $ARGV[1] || 'Porting/Glossary';
55 # creating cross-platform config file
57 mkdir "xlib/$Opts{cross}";
58 $Config_PM = $ARGV[0] || "xlib/$Opts{cross}/Config.pm";
61 $Config_PM = $ARGV[0] || 'lib/Config.pm';
64 $Config_heavy = $Opts{heavy};
67 ($Config_heavy = $Config_PM) =~ s!\.pm$!_heavy.pl!;
68 die "Can't automatically determine name for Config_heavy.pl from '$Config_PM'"
69 if $Config_heavy eq $Config_PM;
72 open CONFIG, ">$Config_PM" or die "Can't open $Config_PM: $!\n";
73 open CONFIG_HEAVY, ">$Config_heavy" or die "Can't open $Config_heavy: $!\n";
75 print CONFIG_HEAVY <<'ENDOFBEG';
76 # This file was created by configpm when Perl was built. Any changes
77 # made to this file will be lost the next time perl is built.
81 # use warnings; Pulls in Carp
82 # use vars pulls in Carp
85 my $myver = sprintf "v%vd", $^V;
87 printf CONFIG <<'ENDOFBEG', ($myver) x 3;
88 # This file was created by configpm when Perl was built. Any changes
89 # made to this file will be lost the next time perl is built.
93 # use warnings; Pulls in Carp
94 # use vars pulls in Carp
95 @Config::EXPORT = qw(%%Config);
96 @Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);
98 # Need to stub all the functions to make code such as print Config::config_sh
106 my %%Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);
110 # Define our own import method to avoid pulling in the full Exporter:
113 @_ = @Config::EXPORT unless @_;
115 my @funcs = grep $_ ne '%%Config', @_;
116 my $export_Config = @funcs < @_ ? 1 : 0;
119 my $callpkg = caller(0);
120 foreach my $func (@funcs) {
121 die sprintf qq{"%%s" is not exported by the %%s module\n},
122 $func, __PACKAGE__ unless $Export_Cache{$func};
123 *{$callpkg.'::'.$func} = \&{$func};
126 *{"$callpkg\::Config"} = \%%Config if $export_Config;
130 die "Perl lib version (%s) doesn't match executable version ($])"
134 or die "Perl lib version (%s) doesn't match executable version (" .
135 sprintf("v%%vd",$^V) . ")";
149 open(CONFIG_SH, 'config.sh') || die "Can't open config.sh: $!";
150 while (<CONFIG_SH>) {
151 next if m:^#!/bin/sh:;
153 # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
154 s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/ or m/^(\w+)='(.*)'$/;
155 my($k, $v) = ($1, $2);
157 # grandfather PATCHLEVEL and SUBVERSION and CONFIG
159 if ($k eq 'PERL_VERSION') {
160 push @v_others, "PATCHLEVEL='$v'\n";
162 elsif ($k eq 'PERL_SUBVERSION') {
163 push @v_others, "SUBVERSION='$v'\n";
165 elsif ($k eq 'PERL_CONFIG_SH') {
166 push @v_others, "CONFIG='$v'\n";
170 # We can delimit things in config.sh with either ' or ".
171 unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
172 push(@non_v, "#$_"); # not a name='value' line
180 ($name,$val) = ($1,$3);
182 $in_v = $val !~ /$quote\n/;
185 s,/,::,g if $Extensions{$name};
187 $val =~ s/$quote\n?\z//;
189 my $line = "$name=$quote$val$quote\n";
190 push(@v_others, $line);
191 $seen_quotes{$quote}++;
196 # This is somewhat grim, but I want the code for parsing config.sh here and
197 # now so that I can expand $Config{ivsize} and $Config{ivtype}
199 my $fetch_string = <<'EOT';
201 # Search for it in the big string
203 my($self, $key) = @_;
207 if ($seen_quotes{'"'}) {
208 # We need the full ' and " code
209 $fetch_string .= <<'EOT';
210 my $quote_type = "'";
211 my $marker = "$key=";
213 # Check for the common case, ' delimited
214 my $start = index($Config_SH_expanded, "\n$marker$quote_type");
215 # If that failed, check for " delimited
218 $start = index($Config_SH_expanded, "\n$marker$quote_type");
222 $fetch_string .= <<'EOT';
223 # We only have ' delimted.
224 my $start = index($Config_SH_expanded, "\n$key=\'");
227 $fetch_string .= <<'EOT';
228 # Start can never be -1 now, as we've rigged the long string we're
229 # searching with an initial dummy newline.
230 return undef if $start == -1;
232 $start += length($key) + 3;
235 if (!$seen_quotes{'"'}) {
236 # Don't need the full ' and " code, or the eval expansion.
237 $fetch_string .= <<'EOT';
238 my $value = substr($Config_SH_expanded, $start,
239 index($Config_SH_expanded, "'\n", $start)
243 $fetch_string .= <<'EOT';
244 my $value = substr($Config_SH_expanded, $start,
245 index($Config_SH_expanded, "$quote_type\n", $start)
248 # If we had a double-quote, we'd better eval it so escape
249 # sequences and such can be interpolated. Since the incoming
250 # value is supposed to follow shell rules and not perl rules,
251 # we escape any perl variable markers
252 if ($quote_type eq '"') {
253 $value =~ s/\$/\\\$/g;
254 $value =~ s/\@/\\\@/g;
255 eval "\$value = \"$value\"";
259 $fetch_string .= <<'EOT';
260 # So we can say "if $Config{'foo'}".
261 $value = undef if $value eq 'undef';
262 $self->{$key} = $value; # cache it
269 # Calculation for the keys for byteorder
270 # This is somewhat grim, but I need to run fetch_string here.
271 our $Config_SH_expanded = join "\n", '', @v_others;
273 my $t = fetch_string ({}, 'ivtype');
274 my $s = fetch_string ({}, 'ivsize');
276 # byteorder does exist on its own but we overlay a virtual
277 # dynamically recomputed value.
279 # However, ivtype and ivsize will not vary for sane fat binaries
281 my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
284 if ($s == 4 || $s == 8) {
285 my $list = join ',', reverse(2..$s);
287 $byteorder_code = <<"EOT";
290 foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 }
292 our \$byteorder = join('', unpack('$format', pack('$f', \$i)));
295 $byteorder_code = "our \$byteorder = '?'x$s;\n";
298 print CONFIG_HEAVY @non_v, "\n";
300 # copy config summary format from the myconfig.SH script
301 print CONFIG_HEAVY "our \$summary : unique = <<'!END!';\n";
302 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
303 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
304 do { print CONFIG_HEAVY $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
307 # NB. as $summary is unique, we need to copy it in a lexical variable
308 # before expanding it, because may have been made readonly if a perl
309 # interpreter has been cloned.
311 print CONFIG_HEAVY "\n!END!\n", <<'EOT';
312 my $summary_expanded;
315 return $summary_expanded if $summary_expanded;
316 ($summary_expanded = $summary) =~ s{\$(\w+)}
317 { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge;
325 print CONFIG_HEAVY join('', sort @v_others), "!END!\n";
327 # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
329 if ($Common{byteorder}) {
330 print CONFIG $byteorder_code;
332 print CONFIG_HEAVY $byteorder_code;
335 print CONFIG_HEAVY <<'EOT';
336 s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
338 my $config_sh_len = length $_;
340 our $Config_SH_expanded : unique = "\n$_" . << 'EOVIRTUAL';
343 foreach my $prefix (qw(ccflags ldflags)) {
344 my $value = fetch_string ({}, $prefix);
345 my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles");
346 $value =~ s/\Q$withlargefiles\E\b//;
347 print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
350 foreach my $prefix (qw(libs libswanted)) {
351 my $value = fetch_string ({}, $prefix);
353 = split(' ', fetch_string ({}, 'libswanted_uselargefiles'));
356 @lflibswanted{@lflibswanted} = ();
357 if ($prefix eq 'libs') {
358 my @libs = grep { /^-l(.+)/ &&
359 not exists $lflibswanted{$1} }
360 split(' ', fetch_string ({}, 'libs'));
361 $value = join(' ', @libs);
363 my @libswanted = grep { not exists $lflibswanted{$_} }
364 split(' ', fetch_string ({}, 'libswanted'));
365 $value = join(' ', @libswanted);
368 print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
371 print CONFIG_HEAVY "EOVIRTUAL\n";
373 print CONFIG_HEAVY $fetch_string;
375 print CONFIG <<'ENDOFEND';
378 my($self, $key) = @_;
380 # check for cached value (which may be undef so we use exists not defined)
381 return $self->{$key} if exists $self->{$key};
383 return $self->fetch_string($key);
387 print CONFIG_HEAVY <<'ENDOFEND';
393 substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
398 if ($seen_quotes{'"'}) {
399 print CONFIG_HEAVY <<'ENDOFEND';
400 # Find out how the current key's quoted so we can skip to its end.
401 my $quote = substr($Config_SH_expanded,
402 index($Config_SH_expanded, "=", $prevpos)+1, 1);
403 my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
406 # Just ' quotes, so it's much easier.
407 print CONFIG_HEAVY <<'ENDOFEND';
408 my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2;
411 print CONFIG_HEAVY <<'ENDOFEND';
412 my $len = index($Config_SH_expanded, "=", $pos) - $pos;
414 $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
418 return 1 if exists($_[0]->{$_[1]});
420 return(index($Config_SH_expanded, "\n$_[1]='") != -1
422 if ($seen_quotes{'"'}) {
423 print CONFIG_HEAVY <<'ENDOFEND';
424 or index($Config_SH_expanded, "\n$_[1]=\"") != -1
427 print CONFIG_HEAVY <<'ENDOFEND';
431 sub STORE { die "\%Config::Config is read-only\n" }
437 substr $Config_SH_expanded, 1, $config_sh_len;
442 return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
447 # implements -V:cfgvar option (see perlrun -V:)
449 # find optional leading, trailing colons; and query-spec
450 my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft,
451 # map colon-flags to print decorations
452 my $prfx = $notag ? '': "$qry="; # tag-prefix for print
453 my $lnend = $lncont ? ' ' : ";\n"; # line ending for print
455 # all config-vars are by definition \w only, any \W means regex
457 my @matches = config_re($qry);
458 print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag;
459 print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag;
461 my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
463 $v = 'undef' unless defined $v;
464 print "${prfx}'${v}'$lnend";
469 # Called by the real AUTOLOAD
472 goto \&$Config::AUTOLOAD;
479 print CONFIG <<'ENDOFSET';
482 my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m;
483 for (split ' ', $value) {
484 ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m;
485 $preconfig{$_} = $v eq 'undef' ? undef : $v;
488 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
489 sub TIEHASH { bless {%preconfig} }
491 # Extract the name of the DLL from the makefile to avoid duplication
492 my ($f) = grep -r, qw(GNUMakefile Makefile);
494 if (open my $fh, '<', $f) {
496 $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
499 print CONFIG <<ENDOFSET if $dll;
500 \$preconfig{dll_name} = '$dll';
503 print CONFIG <<'ENDOFSET';
510 foreach my $key (keys %Common) {
511 my $value = fetch_string ({}, $key);
512 # Is it safe on the LHS of => ?
513 my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'";
514 if (defined $value) {
515 # Quote things for a '' string
516 $value =~ s!\\!\\\\!g;
522 $Common{$key} = "$qkey => $value";
525 if ($Common{byteorder}) {
526 $Common{byteorder} = 'byteorder => $byteorder';
528 my $fast_config = join '', map { " $_,\n" } sort values %Common;
530 print CONFIG sprintf <<'ENDOFTIE', $fast_config;
535 require 'Config_heavy.pl';
537 die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
540 tie %%Config, 'Config', {
547 open(CONFIG_POD, ">lib/Config.pod") or die "Can't open lib/Config.pod: $!";
548 print CONFIG_POD <<'ENDOFTAIL';
551 Config - access Perl configuration information
556 if ($Config{usethreads}) {
557 print "has thread support\n"
560 use Config qw(myconfig config_sh config_vars config_re);
568 config_vars(qw(osname archname));
573 The Config module contains all the information that was available to
574 the C<Configure> program at Perl build time (over 900 values).
576 Shell variables from the F<config.sh> file (written by Configure) are
577 stored in the readonly-variable C<%Config>, indexed by their names.
579 Values stored in config.sh as 'undef' are returned as undefined
580 values. The perl C<exists> function can be used to check if a
581 named variable exists.
587 Returns a textual summary of the major perl configuration values.
588 See also C<-V> in L<perlrun/Switches>.
592 Returns the entire perl configuration information in the form of the
593 original config.sh shell variable assignment script.
595 =item config_re($regex)
597 Like config_sh() but returns, as a list, only the config entries who's
598 names match the $regex.
600 =item config_vars(@names)
602 Prints to STDOUT the values of the named configuration variable. Each is
603 printed on a separate line in the form:
607 Names which are unknown are output as C<name='UNKNOWN';>.
608 See also C<-V:name> in L<perlrun/Switches>.
614 Here's a more sophisticated example of using %Config:
621 unless($Config{sig_name} && $Config{sig_num}) {
624 my @names = split ' ', $Config{sig_name};
625 @sig_num{@names} = split ' ', $Config{sig_num};
627 $sig_name[$sig_num{$_}] ||= $_;
631 print "signal #17 = $sig_name[17]\n";
632 if ($sig_num{ALRM}) {
633 print "SIGALRM is $sig_num{ALRM}\n";
638 Because this information is not stored within the perl executable
639 itself it is possible (but unlikely) that the information does not
640 relate to the actual perl binary which is being used to access it.
642 The Config module is installed into the architecture and version
643 specific library directory ($Config{installarchlib}) and it checks the
644 perl version number when loaded.
646 The values stored in config.sh may be either single-quoted or
647 double-quoted. Double-quoted strings are handy for those cases where you
648 need to include escape sequences in the strings. To avoid runtime variable
649 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
650 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
651 or C<\@> in double-quoted strings unless you're willing to deal with the
652 consequences. (The slashes will end up escaped and the C<$> or C<@> will
653 trigger variable interpolation)
657 Most C<Config> variables are determined by the C<Configure> script
658 on platforms supported by it (which is most UNIX platforms). Some
659 platforms have custom-made C<Config> variables, and may thus not have
660 some of the variables described below, or may have extraneous variables
661 specific to that particular port. See the port specific documentation
666 if ($Opts{glossary}) {
667 open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!";
674 if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
675 my $c = substr $1, 0, 1;
676 unless ($seen{$c}++) {
677 print CONFIG_POD <<EOF if $text;
681 print CONFIG_POD <<EOF;
690 elsif (!$text || !/\A\t/) {
691 warn "Expected a Configure variable header",
692 ($text ? " or another paragraph of description" : () );
694 s/n't/n\00t/g; # leave can't, won't etc untouched
695 s/^\t\s+(.*)/\n$1/gm; # Indented lines ===> new paragraph
696 s/^(?<!\n\n)\t(.*)/$1/gm; # Not indented lines ===> text
697 s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
698 s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
699 s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
701 (?<! [\w./<\'\"] ) # Only standalone file names
702 (?! e \. g \. ) # Not e.g.
703 (?! \. \. \. ) # Not ...
705 (?! read/ ) # Not read/write
706 (?! etc\. ) # Not etc.
709 \$ ? # Allow leading $
710 [\w./]* [./] [\w./]* # Require . or / inside
712 (?<! \. (?= [\s)] ) ) # Do not include trailing dot
713 (?! [\w/] ) # Include all of it
715 (F<$1>)xg; # /usr/local
716 s/((?<=\s)~\w*)/F<$1>/g; # ~name
717 s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g; # UNISTD
718 s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
719 s/n[\0]t/n't/g; # undo can't, won't damage
722 if ($Opts{glossary}) {
723 <GLOS>; # Skip the "DO NOT EDIT"
724 <GLOS>; # Skip the preamble
731 print CONFIG_POD <<'ENDOFTAIL';
737 This module contains a good example of how to use tie to implement a
738 cache and an example of how to make a tied variable readonly to those
750 # Now create Cross.pm if needed
752 open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!";
754 # typical invocation:
755 # perl -MCross Makefile.PL
756 # perl -MCross=wince -V:cc
760 my ($package,$platform) = @_;
761 unless (defined $platform) {
762 # if $platform is not specified, then use last one when
763 # 'configpm; was invoked with --cross option
764 $platform = '***replace-marker***';
766 @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
767 $::Cross::platform = $platform;
772 $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
777 # Now do some simple tests on the Config.pm file we have created
782 die "$0: $Config_PM not valid"
783 unless $Config{'PERL_CONFIG_SH'} eq 'true';
785 die "$0: error processing $Config_PM"
786 if defined($Config{'an impossible name'})
787 or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
790 die "$0: error processing $Config_PM"
791 if eval '$Config{"cc"} = 1'
792 or eval 'delete $Config{"cc"}'
797 # Popularity of various entries in %Config, based on a large build and test
798 # run of code in the Fotango build system:
816 inc_version_list: 783
840 installsiteman1dir: 489
841 installsiteman3dir: 489
842 installvendorman1dir: 489
843 installvendorman3dir: 489
852 installprefixexp: 336
855 installvendorarch: 336
856 installvendorbin: 336
857 installvendorlib: 336