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";
300 if (fetch_string({},'userelocatableinc')) {
301 foreach my $what (qw(archlib archlibexp
306 vendorarch vendorarchexp
307 vendorlib vendorlibexp
309 push @need_relocation, $what if fetch_string({}, $what) =~ m!^\.\.\./!;
311 # This can have .../ anywhere:
312 push @need_relocation, 'otherlibdirs'
313 if fetch_string({}, 'otherlibdirs') =~ m!\.\.\./!;
317 @need_relocation{@need_relocation} = @need_relocation;
319 my $relocation_code = <<'EOT';
323 return $libdir unless $libdir =~ s!^\.\.\./!!;
325 if ($prefix =~ s!/[^/]*$!!) {
326 while ($libdir =~ m!^\.\./!) {
327 # Loop while $libdir starts "../" and $prefix still has a trailing
329 last unless $prefix =~ s!/([^/]+)$!!;
330 # but bail out if the directory we picked off the end of $prefix is .
332 if ($1 eq '.' or $1 eq '..') {
333 # Undo! This should be rare, hence code it this way rather than a
334 # check each time before the s!!! above.
335 $prefix = "$prefix/$1";
338 # Remove that leading ../ and loop again
339 substr ($libdir, 0, 3, '');
341 $libdir = "$prefix/$libdir";
347 if (@need_relocation) {
348 my $relocations_in_common;
349 foreach (@need_relocation) {
350 $relocations_in_common++ if $Common{$_};
352 if ($relocations_in_common) {
353 print CONFIG $relocation_code;
355 print CONFIG_HEAVY $relocation_code;
359 print CONFIG_HEAVY @non_v, "\n";
361 # copy config summary format from the myconfig.SH script
362 print CONFIG_HEAVY "our \$summary : unique = <<'!END!';\n";
363 open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
364 1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
365 do { print CONFIG_HEAVY $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
368 # NB. as $summary is unique, we need to copy it in a lexical variable
369 # before expanding it, because may have been made readonly if a perl
370 # interpreter has been cloned.
372 print CONFIG_HEAVY "\n!END!\n", <<'EOT';
373 my $summary_expanded;
376 return $summary_expanded if $summary_expanded;
377 ($summary_expanded = $summary) =~ s{\$(\w+)}
378 { my $c = $Config::Config{$1}; defined($c) ? $c : 'undef' }ge;
386 print CONFIG_HEAVY join('', sort @v_others), "!END!\n";
388 # Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
390 if ($Common{byteorder}) {
391 print CONFIG $byteorder_code;
393 print CONFIG_HEAVY $byteorder_code;
396 if (@need_relocation) {
397 print CONFIG_HEAVY 'foreach my $what (qw(', join (' ', @need_relocation),
399 s/^($what=)(['"])(.*?)\2/$1 . $2 . relocate_inc($3) . $2/me;
404 print CONFIG_HEAVY <<'EOT';
405 s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;
407 my $config_sh_len = length $_;
409 our $Config_SH_expanded : unique = "\n$_" . << 'EOVIRTUAL';
412 foreach my $prefix (qw(ccflags ldflags)) {
413 my $value = fetch_string ({}, $prefix);
414 my $withlargefiles = fetch_string ({}, $prefix . "_uselargefiles");
415 $value =~ s/\Q$withlargefiles\E\b//;
416 print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
419 foreach my $prefix (qw(libs libswanted)) {
420 my $value = fetch_string ({}, $prefix);
422 = split(' ', fetch_string ({}, 'libswanted_uselargefiles'));
425 @lflibswanted{@lflibswanted} = ();
426 if ($prefix eq 'libs') {
427 my @libs = grep { /^-l(.+)/ &&
428 not exists $lflibswanted{$1} }
429 split(' ', fetch_string ({}, 'libs'));
430 $value = join(' ', @libs);
432 my @libswanted = grep { not exists $lflibswanted{$_} }
433 split(' ', fetch_string ({}, 'libswanted'));
434 $value = join(' ', @libswanted);
437 print CONFIG_HEAVY "${prefix}_nolargefiles='$value'\n";
440 print CONFIG_HEAVY "EOVIRTUAL\n";
442 print CONFIG_HEAVY $fetch_string;
444 print CONFIG <<'ENDOFEND';
447 my($self, $key) = @_;
449 # check for cached value (which may be undef so we use exists not defined)
450 return $self->{$key} if exists $self->{$key};
452 return $self->fetch_string($key);
456 print CONFIG_HEAVY <<'ENDOFEND';
462 substr($Config_SH_expanded, 1, index($Config_SH_expanded, '=') - 1 );
467 if ($seen_quotes{'"'}) {
468 print CONFIG_HEAVY <<'ENDOFEND';
469 # Find out how the current key's quoted so we can skip to its end.
470 my $quote = substr($Config_SH_expanded,
471 index($Config_SH_expanded, "=", $prevpos)+1, 1);
472 my $pos = index($Config_SH_expanded, qq($quote\n), $prevpos) + 2;
475 # Just ' quotes, so it's much easier.
476 print CONFIG_HEAVY <<'ENDOFEND';
477 my $pos = index($Config_SH_expanded, qq('\n), $prevpos) + 2;
480 print CONFIG_HEAVY <<'ENDOFEND';
481 my $len = index($Config_SH_expanded, "=", $pos) - $pos;
483 $len > 0 ? substr($Config_SH_expanded, $pos, $len) : undef;
487 return 1 if exists($_[0]->{$_[1]});
489 return(index($Config_SH_expanded, "\n$_[1]='") != -1
491 if ($seen_quotes{'"'}) {
492 print CONFIG_HEAVY <<'ENDOFEND';
493 or index($Config_SH_expanded, "\n$_[1]=\"") != -1
496 print CONFIG_HEAVY <<'ENDOFEND';
500 sub STORE { die "\%Config::Config is read-only\n" }
506 substr $Config_SH_expanded, 1, $config_sh_len;
511 return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/,
516 # implements -V:cfgvar option (see perlrun -V:)
518 # find optional leading, trailing colons; and query-spec
519 my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft,
520 # map colon-flags to print decorations
521 my $prfx = $notag ? '': "$qry="; # tag-prefix for print
522 my $lnend = $lncont ? ' ' : ";\n"; # line ending for print
524 # all config-vars are by definition \w only, any \W means regex
526 my @matches = config_re($qry);
527 print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag;
528 print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag;
530 my $v = (exists $Config::Config{$qry}) ? $Config::Config{$qry}
532 $v = 'undef' unless defined $v;
533 print "${prfx}'${v}'$lnend";
538 # Called by the real AUTOLOAD
541 goto \&$Config::AUTOLOAD;
548 print CONFIG <<'ENDOFSET';
551 my ($value, $v) = $Config_SH_expanded =~ m/^used_aout='(.*)'\s*$/m;
552 for (split ' ', $value) {
553 ($v) = $Config_SH_expanded =~ m/^aout_$_='(.*)'\s*$/m;
554 $preconfig{$_} = $v eq 'undef' ? undef : $v;
557 $preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
558 sub TIEHASH { bless {%preconfig} }
560 # Extract the name of the DLL from the makefile to avoid duplication
561 my ($f) = grep -r, qw(GNUMakefile Makefile);
563 if (open my $fh, '<', $f) {
565 $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
568 print CONFIG <<ENDOFSET if $dll;
569 \$preconfig{dll_name} = '$dll';
572 print CONFIG <<'ENDOFSET';
579 foreach my $key (keys %Common) {
580 my $value = fetch_string ({}, $key);
581 # Is it safe on the LHS of => ?
582 my $qkey = $key =~ /^[A-Za-z_][A-Za-z0-9_]*$/ ? $key : "'$key'";
583 if (defined $value) {
584 # Quote things for a '' string
585 $value =~ s!\\!\\\\!g;
588 if ($need_relocation{$key}) {
589 $value = "relocate_inc($value)";
594 $Common{$key} = "$qkey => $value";
597 if ($Common{byteorder}) {
598 $Common{byteorder} = 'byteorder => $byteorder';
600 my $fast_config = join '', map { " $_,\n" } sort values %Common;
602 print CONFIG sprintf <<'ENDOFTIE', $fast_config;
607 require 'Config_heavy.pl';
609 die "&Config::AUTOLOAD failed on $Config::AUTOLOAD";
612 tie %%Config, 'Config', {
619 open(CONFIG_POD, ">lib/Config.pod") or die "Can't open lib/Config.pod: $!";
620 print CONFIG_POD <<'ENDOFTAIL';
623 Config - access Perl configuration information
628 if ($Config{usethreads}) {
629 print "has thread support\n"
632 use Config qw(myconfig config_sh config_vars config_re);
640 config_vars(qw(osname archname));
645 The Config module contains all the information that was available to
646 the C<Configure> program at Perl build time (over 900 values).
648 Shell variables from the F<config.sh> file (written by Configure) are
649 stored in the readonly-variable C<%Config>, indexed by their names.
651 Values stored in config.sh as 'undef' are returned as undefined
652 values. The perl C<exists> function can be used to check if a
653 named variable exists.
659 Returns a textual summary of the major perl configuration values.
660 See also C<-V> in L<perlrun/Switches>.
664 Returns the entire perl configuration information in the form of the
665 original config.sh shell variable assignment script.
667 =item config_re($regex)
669 Like config_sh() but returns, as a list, only the config entries who's
670 names match the $regex.
672 =item config_vars(@names)
674 Prints to STDOUT the values of the named configuration variable. Each is
675 printed on a separate line in the form:
679 Names which are unknown are output as C<name='UNKNOWN';>.
680 See also C<-V:name> in L<perlrun/Switches>.
686 Here's a more sophisticated example of using %Config:
693 unless($Config{sig_name} && $Config{sig_num}) {
696 my @names = split ' ', $Config{sig_name};
697 @sig_num{@names} = split ' ', $Config{sig_num};
699 $sig_name[$sig_num{$_}] ||= $_;
703 print "signal #17 = $sig_name[17]\n";
704 if ($sig_num{ALRM}) {
705 print "SIGALRM is $sig_num{ALRM}\n";
710 Because this information is not stored within the perl executable
711 itself it is possible (but unlikely) that the information does not
712 relate to the actual perl binary which is being used to access it.
714 The Config module is installed into the architecture and version
715 specific library directory ($Config{installarchlib}) and it checks the
716 perl version number when loaded.
718 The values stored in config.sh may be either single-quoted or
719 double-quoted. Double-quoted strings are handy for those cases where you
720 need to include escape sequences in the strings. To avoid runtime variable
721 interpolation, any C<$> and C<@> characters are replaced by C<\$> and
722 C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
723 or C<\@> in double-quoted strings unless you're willing to deal with the
724 consequences. (The slashes will end up escaped and the C<$> or C<@> will
725 trigger variable interpolation)
729 Most C<Config> variables are determined by the C<Configure> script
730 on platforms supported by it (which is most UNIX platforms). Some
731 platforms have custom-made C<Config> variables, and may thus not have
732 some of the variables described below, or may have extraneous variables
733 specific to that particular port. See the port specific documentation
738 if ($Opts{glossary}) {
739 open(GLOS, "<$Glossary") or die "Can't open $Glossary: $!";
746 if (s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m) {
747 my $c = substr $1, 0, 1;
748 unless ($seen{$c}++) {
749 print CONFIG_POD <<EOF if $text;
753 print CONFIG_POD <<EOF;
762 elsif (!$text || !/\A\t/) {
763 warn "Expected a Configure variable header",
764 ($text ? " or another paragraph of description" : () );
766 s/n't/n\00t/g; # leave can't, won't etc untouched
767 s/^\t\s+(.*)/\n$1/gm; # Indented lines ===> new paragraph
768 s/^(?<!\n\n)\t(.*)/$1/gm; # Not indented lines ===> text
769 s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
770 s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
771 s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
773 (?<! [\w./<\'\"] ) # Only standalone file names
774 (?! e \. g \. ) # Not e.g.
775 (?! \. \. \. ) # Not ...
777 (?! read/ ) # Not read/write
778 (?! etc\. ) # Not etc.
781 \$ ? # Allow leading $
782 [\w./]* [./] [\w./]* # Require . or / inside
784 (?<! \. (?= [\s)] ) ) # Do not include trailing dot
785 (?! [\w/] ) # Include all of it
787 (F<$1>)xg; # /usr/local
788 s/((?<=\s)~\w*)/F<$1>/g; # ~name
789 s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g; # UNISTD
790 s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
791 s/n[\0]t/n't/g; # undo can't, won't damage
794 if ($Opts{glossary}) {
795 <GLOS>; # Skip the "DO NOT EDIT"
796 <GLOS>; # Skip the preamble
803 print CONFIG_POD <<'ENDOFTAIL';
809 This module contains a good example of how to use tie to implement a
810 cache and an example of how to make a tied variable readonly to those
822 # Now create Cross.pm if needed
824 open CROSS, ">lib/Cross.pm" or die "Can not open >lib/Cross.pm: $!";
826 # typical invocation:
827 # perl -MCross Makefile.PL
828 # perl -MCross=wince -V:cc
832 my ($package,$platform) = @_;
833 unless (defined $platform) {
834 # if $platform is not specified, then use last one when
835 # 'configpm; was invoked with --cross option
836 $platform = '***replace-marker***';
838 @INC = map {/\blib\b/?(do{local $_=$_;s/\blib\b/xlib\/$platform/;$_},$_):($_)} @INC;
839 $::Cross::platform = $platform;
844 $cross =~ s/\*\*\*replace-marker\*\*\*/$Opts{cross}/g;
849 # Now do some simple tests on the Config.pm file we have created
854 die "$0: $Config_PM not valid"
855 unless $Config{'PERL_CONFIG_SH'} eq 'true';
857 die "$0: error processing $Config_PM"
858 if defined($Config{'an impossible name'})
859 or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
862 die "$0: error processing $Config_PM"
863 if eval '$Config{"cc"} = 1'
864 or eval 'delete $Config{"cc"}'
869 # Popularity of various entries in %Config, based on a large build and test
870 # run of code in the Fotango build system:
888 inc_version_list: 783
912 installsiteman1dir: 489
913 installsiteman3dir: 489
914 installvendorman1dir: 489
915 installvendorman3dir: 489
924 installprefixexp: 336
927 installvendorarch: 336
928 installvendorbin: 336
929 installvendorlib: 336