# made to this file will be lost the next time perl is built.
package Config;
-use Exporter ();
@EXPORT = qw(%%Config);
-@EXPORT_OK = qw(myconfig config_sh config_vars);
+@EXPORT_OK = qw(myconfig config_sh config_vars config_re);
+
+my %%Export_Cache = map {($_ => 1)} (@EXPORT, @EXPORT_OK);
# Define our own import method to avoid pulling in the full Exporter:
sub import {
- my $pkg = shift;
- @_ = @EXPORT unless @_;
+ my $pkg = shift;
+ @_ = @EXPORT unless @_;
- my @func = grep {$_ ne '%%Config'} @_;
- local $Exporter::ExportLevel = 1;
- Exporter::import('Config', @func) if @func;
+ my @funcs = grep $_ ne '%%Config', @_;
+ my $export_Config = @funcs < @_ ? 1 : 0;
- return if @func == @_;
+ my $callpkg = caller(0);
+ foreach my $func (@funcs) {
+ die sprintf qq{"%%s" is not exported by the %%s module\n},
+ $func, __PACKAGE__ unless $Export_Cache{$func};
+ *{$callpkg.'::'.$func} = \&{$func};
+ }
- my $callpkg = caller(0);
- *{"$callpkg\::Config"} = \%%Config;
+ *{"$callpkg\::Config"} = \%%Config if $export_Config;
+ return;
}
die "Perl lib version (%s) doesn't match executable version ($])"
unless $^V;
$^V eq %s
- or die "Perl lib version (%s) doesn't match executable version (" .
- (sprintf "v%vd",$^V) . ")";
+ or die "Perl lib version (%s) doesn't match executable version (" .
+ sprintf("v%%vd",$^V) . ")";
ENDOFBEG
my $quote_type = "'";
my $marker = "$key=";
- # Check for the common case, ' delimeted
+ # Check for the common case, ' delimited
my $start = index($Config_SH, "\n$marker$quote_type");
# If that failed, check for " delimited
if ($start == -1) {
next if m:^#!/bin/sh:;
# Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
- my($k, $v) = s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
+ s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/ or m/^(\w+)='(.*)'$/;
+ my($k, $v) = ($1, $2);
# grandfather PATCHLEVEL and SUBVERSION and CONFIG
if ($k) {
}
close CONFIG_SH;
+# Calculation for the keys for byteorder
+# This is somewhat grim, but I need to run fetch_string here.
+our $Config_SH = join "\n", @v_fast, @v_others;
+
+my $t = fetch_string ({}, 'ivtype');
+my $s = fetch_string ({}, 'ivsize');
+
+# byteorder does exist on its own but we overlay a virtual
+# dynamically recomputed value.
+
+# However, ivtype and ivsize will not vary for sane fat binaries
+
+my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
+
+my $byteorder_code;
+if ($s == 4 || $s == 8) {
+ my $list = join ',', reverse(2..$s);
+ my $format = 'a'x$s;
+ $byteorder_code = <<"EOT";
+my \$i = 0;
+foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 }
+\$i |= ord(1);
+my \$byteorder = join('', unpack('$format', pack('$f', \$i)));
+EOT
+} else {
+ $byteorder_code = "my \$byteorder = '?'x$s;\n";
+}
+
print CONFIG @non_v, "\n";
# copy config summary format from the myconfig.SH script
-print CONFIG "my \$summary = <<'!END!';\n";
+print CONFIG "our \$summary : unique = <<'!END!';\n";
open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
close(MYCONFIG);
-print CONFIG "\n!END!\n", <<'EOT';
-my $summary_expanded = 0;
+# NB. as $summary is unique, we need to copy it in a lexical variable
+# before expanding it, because may have been made readonly if a perl
+# interpreter has been cloned.
+
+print CONFIG "\n!END!\n", $byteorder_code, <<'EOT';
+my $summary_expanded;
sub myconfig {
- return $summary if $summary_expanded;
- $summary =~ s{\$(\w+)}
- { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
- $summary_expanded = 1;
- $summary;
+ return $summary_expanded if $summary_expanded;
+ ($summary_expanded = $summary) =~ s{\$(\w+)}
+ { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
+ $summary_expanded;
}
-our $Config_SH : shared = <<'!END!';
+local *_ = \my $a;
+$_ = <<'!END!';
EOT
print CONFIG join("", @v_fast, sort @v_others);
-print CONFIG "!END!\n", $fetch_string;
+print CONFIG <<'EOT';
+!END!
+s/(byteorder=)(['"]).*?\2/$1$2$byteorder$2/m;
+our $Config_SH : unique = $_;
+EOT
+
+print CONFIG $fetch_string;
print CONFIG <<'ENDOFEND';
sub config_re {
my $re = shift;
- my @matches = grep /^$re=/, split /^/, $Config_SH;
- @matches ? (print @matches) : print "$re: not found\n";
+ return map { chomp; $_ } grep eval{ /^(?:$re)=/ }, split /^/, $Config_SH;
}
sub config_vars {
- foreach(@_){
- config_re($_), next if /\W/;
- my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
- $v='undef' unless defined $v;
- print "$_='$v';\n";
+ foreach (@_) {
+ my ($notag,$qry,$lncont) = m/^(:)?(.*?)(:)?$/; # flags fore and aft,
+ my $prfx = $notag ? '': "$qry="; # prefix for print
+ my $lnend = $lncont ? ' ' : ";\n"; # ending for print
+
+ if ($qry =~ /\W/) {
+ my @matches = config_re($qry);
+ print map "$_$lnend", @matches ? @matches : "$qry: not found" if !$notag;
+ print map { s/\w+=//; "$_$lnend" } @matches ? @matches : "$qry: not found" if $notag;
+ } else {
+ my $v = (exists $Config{$qry}) ? $Config{$qry} : 'UNKNOWN';
+ $v = 'undef' unless defined $v;
+ print "${prfx}'${v}'$lnend";
+ }
}
}
ENDOFEND
if ($^O eq 'os2') {
- print CONFIG <<'ENDOFSET';
+ print CONFIG <<'ENDOFSET';
my %preconfig;
if ($OS2::is_aout) {
my ($value, $v) = $Config_SH =~ m/^used_aout='(.*)'\s*$/m;
$preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
sub TIEHASH { bless {%preconfig} }
ENDOFSET
- # Extract the name of the DLL from the makefile to avoid duplication
- my ($f) = grep -r, qw(GNUMakefile Makefile);
- my $dll;
- if (open my $fh, '<', $f) {
- while (<$fh>) {
- $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
+ # Extract the name of the DLL from the makefile to avoid duplication
+ my ($f) = grep -r, qw(GNUMakefile Makefile);
+ my $dll;
+ if (open my $fh, '<', $f) {
+ while (<$fh>) {
+ $dll = $1, last if /^PERL_DLL_BASE\s*=\s*(\S*)\s*$/;
+ }
}
- }
- print CONFIG <<ENDOFSET if $dll;
+ print CONFIG <<ENDOFSET if $dll;
\$preconfig{dll_name} = '$dll';
ENDOFSET
} else {
- print CONFIG <<'ENDOFSET';
+ print CONFIG <<'ENDOFSET';
sub TIEHASH {
bless $_[1], $_[0];
}
ENDOFSET
}
-
-# Calculation for the keys for byteorder
-# This is somewhat grim, but I need to run fetch_string here.
-our $Config_SH = join "\n", @v_fast, @v_others;
-
-my $t = fetch_string ({}, 'ivtype');
-my $s = fetch_string ({}, 'ivsize');
-
-# byteorder does exist on its own but we overlay a virtual
-# dynamically recomputed value.
-
-# However, ivtype and ivsize will not vary for sane fat binaries
-
-my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
-
-my $byteorder_code;
-if ($s == 4 || $s == 8) {
-
- my $list = join ',', reverse(2..$s);
- my $format = 'a'x$s;
- $byteorder_code = <<"EOT";
-my \$i = 0;
-foreach my \$c ($list) { \$i |= ord(\$c); \$i <<= 8 }
-\$i |= ord(1);
-my \$value = join('', unpack('$format', pack('$f', \$i)));
-EOT
-} else {
- $byteorder_code = "\$value = '?'x$s;\n";
-}
-
my $fast_config = join '', map { " $_,\n" }
- values (%v_fast), 'byteorder => $value' ;
+ sort values (%v_fast), 'byteorder => $byteorder' ;
-print CONFIG sprintf <<'ENDOFTIE', $byteorder_code, $fast_config;
+print CONFIG sprintf <<'ENDOFTIE', $fast_config;
# avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
sub DESTROY { }
-%s
-
tie %%Config, 'Config', {
%s
};
=head1 SYNOPSIS
use Config;
- if ($Config{'cc'} =~ /gcc/) {
- print "built by gcc\n";
+ if ($Config{usethreads}) {
+ print "has thread support\n"
}
- use Config qw(myconfig config_sh config_vars);
+ use Config qw(myconfig config_sh config_vars config_re);
print myconfig();
print config_sh();
+ print config_re();
+
config_vars(qw(osname archname));
Returns the entire perl configuration information in the form of the
original config.sh shell variable assignment script.
+=item config_re($regex)
+
+Like config_sh() but returns, as a list, only the config entries who's
+names match the $regex.
+
=item config_vars(@names)
Prints to STDOUT the values of the named configuration variable. Each is
projects / p5sagit/p5-mst-13.2.git / blobdiff