[p5sagit/p5-mst-13.2.git] / configpm

#!./miniperl -w

my $config_pm = $ARGV[0] || 'lib/Config.pm';
my $glossary = $ARGV[1] || 'Porting/Glossary';
@ARGV = "./config.sh";

# list names to put first (and hence lookup fastest)
@fast = qw(archname osname osvers prefix libs libpth
	dynamic_ext static_ext extensions dlsrc so
	sig_name sig_num cc ccflags cppflags
	privlibexp archlibexp installprivlib installarchlib
	sharpbang startsh shsharp
);

# names of things which may need to have slashes changed to double-colons
@extensions = qw(dynamic_ext static_ext extensions known_extensions);


open CONFIG, ">$config_pm" or die "Can't open $config_pm: $!\n";
$myver = sprintf "v%vd", $^V;

print CONFIG <<'ENDOFBEG_NOQ', <<"ENDOFBEG";
package Config;
use Exporter ();
@EXPORT = qw(%Config);
@EXPORT_OK = qw(myconfig config_sh config_vars);

# Define our own import method to avoid pulling in the full Exporter:
sub import {
  my $pkg = shift;
  @_ = @EXPORT unless @_;
  my @func = grep {$_ ne '%Config'} @_;
  local $Exporter::ExportLevel = 1;
  Exporter::import('Config', @func) if @func;
  return if @func == @_;
  my $callpkg = caller(0);
  *{"$callpkg\::Config"} = \%Config;
}

ENDOFBEG_NOQ
die "Perl lib version ($myver) doesn't match executable version (\$])"
    unless \$^V;

\$^V eq $myver
  or die "Perl lib version ($myver) doesn't match executable version (" .
    (sprintf "v%vd",\$^V) . ")";

# This file was created by configpm when Perl was built. Any changes
# made to this file will be lost the next time perl is built.

ENDOFBEG


@fast{@fast} = @fast;
@extensions{@extensions} = @extensions;
@non_v=();
@v_fast=();
@v_others=();
$in_v = 0;

while (<>) {
    next if m:^#!/bin/sh:;
    # Catch PERL_CONFIG_SH=true and PERL_VERSION=n line from Configure.
    s/^(\w+)=(true|\d+)\s*$/$1='$2'\n/;
    my ($k,$v) = ($1,$2);
    # grandfather PATCHLEVEL and SUBVERSION and CONFIG
    if ($k) {
	if ($k eq 'PERL_VERSION') {
	    push @v_others, "PATCHLEVEL='$v'\n";
	}
	elsif ($k eq 'PERL_SUBVERSION') {
	    push @v_others, "SUBVERSION='$v'\n";
	}
	elsif ($k eq 'PERL_CONFIG_SH') {
	    push @v_others, "CONFIG='$v'\n";
	}
    }
    # We can delimit things in config.sh with either ' or ". 
    unless ($in_v or m/^(\w+)=(['"])(.*\n)/){
	push(@non_v, "#$_"); # not a name='value' line
	next;
    }
    $quote = $2;
    if ($in_v) { $val .= $_;             }
    else       { ($name,$val) = ($1,$3); }
    $in_v = $val !~ /$quote\n/;
    next if $in_v;
    if ($extensions{$name}) { s,/,::,g }
    if (!$fast{$name}){ push(@v_others, "$name=$quote$val"); next; }
    push(@v_fast,"$name=$quote$val");
}

foreach(@non_v){ print CONFIG $_ }

print CONFIG "\n",
    "my \$config_sh = <<'!END!';\n",
    join("", @v_fast, sort @v_others),
    "!END!\n\n";

# copy config summary format from the myconfig.SH script

print CONFIG "my \$summary = <<'!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;

sub myconfig {
	return $summary if $summary_expanded;
	$summary =~ s{\$(\w+)}
		     { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
	$summary_expanded = 1;
	$summary;
}
EOT

# ----

print CONFIG <<'ENDOFEND';

sub FETCH { 
    # check for cached value (which may be undef so we use exists not defined)
    return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});

    # Search for it in the big string 
    my($value, $start, $marker, $quote_type);

    $quote_type = "'";
    # Virtual entries.
    if ($_[1] eq 'byteorder') {
	# byteorder does exist on its own but we overlay a virtual
	# dynamically recomputed value. 
        my $t = $Config{ivtype};
        my $s = $Config{ivsize};
        my $f = $t eq 'long' ? 'L!' : $s == 8 ? 'Q': 'I';
        if ($s == 4 || $s == 8) {
	    my $i = 0;
    	    foreach my $c (reverse(2..$s)) { $i |= ord($c); $i <<= 8 }
	    $i |= ord(1);
            $value = join('', unpack('a'x$s, pack($f, $i)));
        } else {
            $value = '?'x$s;
        }
    } elsif ($_[1] =~ /^((?:cc|ld)flags|libs(?:wanted)?)_nolargefiles/) {
	# These are purely virtual, they do not exist, but need to
	# be computed on demand for largefile-incapable extensions.
	my $key = "${1}_uselargefiles";
	$value = $Config{$1};
	my $withlargefiles = $Config{$key};
	if ($key =~ /^(?:cc|ld)flags_/) {
	    $value =~ s/\Q$withlargefiles\E\b//;
	} elsif ($key =~ /^libs/) {
	    my @lflibswanted = split(' ', $Config{libswanted_uselargefiles});
	    if (@lflibswanted) {
		my %lflibswanted;
		@lflibswanted{@lflibswanted} = ();
		if ($key =~ /^libs_/) {
		    my @libs = grep { /^-l(.+)/ &&
                                      not exists $lflibswanted{$1} }
		                    split(' ', $Config{libs});
		    $Config{libs} = join(' ', @libs);
		} elsif ($key =~ /^libswanted_/) {
		    my @libswanted = grep { not exists $lflibswanted{$_} }
		                          split(' ', $Config{libswanted});
		    $Config{libswanted} = join(' ', @libswanted);
		}
	    }
	}
    } else {
	$marker = "$_[1]=";
	# return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
	# Check for the common case, ' delimeted
	$start = index($config_sh, "\n$marker$quote_type");
	# If that failed, check for " delimited
	if ($start == -1) {
	    $quote_type = '"';
	    $start = index($config_sh, "\n$marker$quote_type");
	}
	return undef if ( ($start == -1) &&  # in case it's first 
			  (substr($config_sh, 0, length($marker)) ne $marker) );
	if ($start == -1) { 
	    # It's the very first thing we found. Skip $start forward
	    # and figure out the quote mark after the =.
	    $start = length($marker) + 1;
	    $quote_type = substr($config_sh, $start - 1, 1);
	} 
	else { 
	    $start += length($marker) + 2;
	}
	$value = substr($config_sh, $start, 
			index($config_sh, "$quote_type\n", $start) - $start);
    }
    # If we had a double-quote, we'd better eval it so escape
    # sequences and such can be interpolated. Since the incoming
    # value is supposed to follow shell rules and not perl rules,
    # we escape any perl variable markers
    if ($quote_type eq '"') {
	$value =~ s/\$/\\\$/g;
	$value =~ s/\@/\\\@/g;
	eval "\$value = \"$value\"";
    }
    #$value = sprintf($value) if $quote_type eq '"';
    # So we can say "if $Config{'foo'}".
    $value = undef if $value eq 'undef';
    $_[0]->{$_[1]} = $value; # cache it
    return $value;
}
 
my $prevpos = 0;

sub FIRSTKEY {
    $prevpos = 0;
    # my($key) = $config_sh =~ m/^(.*?)=/;
    substr($config_sh, 0, index($config_sh, '=') );
    # $key;
}

sub NEXTKEY {
    # Find out how the current key's quoted so we can skip to its end.
    my $quote = substr($config_sh, index($config_sh, "=", $prevpos)+1, 1);
    my $pos = index($config_sh, qq($quote\n), $prevpos) + 2;
    my $len = index($config_sh, "=", $pos) - $pos;
    $prevpos = $pos;
    $len > 0 ? substr($config_sh, $pos, $len) : undef;
}

sub EXISTS { 
    # exists($_[0]->{$_[1]})  or  $config_sh =~ m/^$_[1]=/m;
    exists($_[0]->{$_[1]}) or
    index($config_sh, "\n$_[1]='") != -1 or
    substr($config_sh, 0, length($_[1])+2) eq "$_[1]='" or
    index($config_sh, "\n$_[1]=\"") != -1 or
    substr($config_sh, 0, length($_[1])+2) eq "$_[1]=\"" or
    $_[1] =~ /^(?:(?:cc|ld)flags|libs(?:wanted)?)_nolargefiles$/;
}

sub STORE  { die "\%Config::Config is read-only\n" }
sub DELETE { &STORE }
sub CLEAR  { &STORE }


sub config_sh {
    $config_sh
}

sub config_re {
    my $re = shift;
    my @matches = ($config_sh =~ /^$re=.*\n/mg);
    @matches ? (print @matches) : print "$re: not found\n";
}

sub config_vars {
    foreach(@_){
	config_re($_), next if /\W/;
	my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
	$v='undef' unless defined $v;
	print "$_='$v';\n";
    }
}

ENDOFEND

if ($^O eq 'os2') {
  print CONFIG <<'ENDOFSET';
my %preconfig;
if ($OS2::is_aout) {
    my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
    for (split ' ', $value) {
        ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
        $preconfig{$_} = $v eq 'undef' ? undef : $v;
    }
}
$preconfig{d_fork} = undef unless $OS2::can_fork; # Some funny cases can't
sub TIEHASH { bless {%preconfig} }
ENDOFSET
} else {
  print CONFIG <<'ENDOFSET';
sub TIEHASH { bless {} }
ENDOFSET
}

print CONFIG <<'ENDOFTAIL';

# avoid Config..Exporter..UNIVERSAL search for DESTROY then AUTOLOAD
sub DESTROY { }

tie %Config, 'Config';

1;
__END__

=head1 NAME

Config - access Perl configuration information

=head1 SYNOPSIS

    use Config;
    if ($Config{'cc'} =~ /gcc/) {
	print "built by gcc\n";
    } 

    use Config qw(myconfig config_sh config_vars);

    print myconfig();

    print config_sh();

    config_vars(qw(osname archname));


=head1 DESCRIPTION

The Config module contains all the information that was available to
the C<Configure> program at Perl build time (over 900 values).

Shell variables from the F<config.sh> file (written by Configure) are
stored in the readonly-variable C<%Config>, indexed by their names.

Values stored in config.sh as 'undef' are returned as undefined
values.  The perl C<exists> function can be used to check if a
named variable exists.

=over 4

=item myconfig()

Returns a textual summary of the major perl configuration values.
See also C<-V> in L<perlrun/Switches>.

=item config_sh()

Returns the entire perl configuration information in the form of the
original config.sh shell variable assignment script.

=item config_vars(@names)

Prints to STDOUT the values of the named configuration variable. Each is
printed on a separate line in the form:

  name='value';

Names which are unknown are output as C<name='UNKNOWN';>.
See also C<-V:name> in L<perlrun/Switches>.

=back

=head1 EXAMPLE

Here's a more sophisticated example of using %Config:

    use Config;
    use strict;

    my %sig_num;
    my @sig_name;
    unless($Config{sig_name} && $Config{sig_num}) {
	die "No sigs?";
    } else {
	my @names = split ' ', $Config{sig_name};
	@sig_num{@names} = split ' ', $Config{sig_num};
	foreach (@names) {
	    $sig_name[$sig_num{$_}] ||= $_;
	}   
    }

    print "signal #17 = $sig_name[17]\n";
    if ($sig_num{ALRM}) { 
	print "SIGALRM is $sig_num{ALRM}\n";
    }   

=head1 WARNING

Because this information is not stored within the perl executable
itself it is possible (but unlikely) that the information does not
relate to the actual perl binary which is being used to access it.

The Config module is installed into the architecture and version
specific library directory ($Config{installarchlib}) and it checks the
perl version number when loaded.

The values stored in config.sh may be either single-quoted or
double-quoted. Double-quoted strings are handy for those cases where you
need to include escape sequences in the strings. To avoid runtime variable
interpolation, any C<$> and C<@> characters are replaced by C<\$> and
C<\@>, respectively. This isn't foolproof, of course, so don't embed C<\$>
or C<\@> in double-quoted strings unless you're willing to deal with the
consequences. (The slashes will end up escaped and the C<$> or C<@> will
trigger variable interpolation)

=head1 GLOSSARY

Most C<Config> variables are determined by the C<Configure> script
on platforms supported by it (which is most UNIX platforms).  Some
platforms have custom-made C<Config> variables, and may thus not have
some of the variables described below, or may have extraneous variables
specific to that particular port.  See the port specific documentation
in such cases.

ENDOFTAIL

open(GLOS, "<$glossary") or die "Can't open $glossary: $!";
%seen = ();
$text = 0;
$/ = '';

sub process {
  s/\A(\w*)\s+\(([\w.]+)\):\s*\n(\t?)/=item C<$1>\n\nFrom F<$2>:\n\n/m;
  my $c = substr $1, 0, 1;
  unless ($seen{$c}++) {
    print CONFIG <<EOF if $text;
=back

EOF
    print CONFIG <<EOF;
=head2 $c

=over 4

EOF
    $text = 1;
  }
  s/n't/n\00t/g;		# leave can't, won't etc untouched
  s/^\t\s+(.*)/\n\t$1\n/gm;	# Indented lines ===> paragraphs
  s/^(?<!\n\n)\t(.*)/$1/gm;	# Not indented lines ===> text
  s{([\'\"])(?=[^\'\"\s]*[./][^\'\"\s]*\1)([^\'\"\s]+)\1}(F<$2>)g; # '.o'
  s{([\'\"])([^\'\"\s]+)\1}(C<$2>)g; # "date" command
  s{\'([A-Za-z_\- *=/]+)\'}(C<$1>)g; # 'ln -s'
  s{
     (?<! [\w./<\'\"] )		# Only standalone file names
     (?! e \. g \. )		# Not e.g.
     (?! \. \. \. )		# Not ...
     (?! \d )			# Not 5.004
     ( [\w./]* [./] [\w./]* )	# Require . or / inside
     (?<! \. (?= \s ) )		# Do not include trailing dot
     (?! [\w/] )		# Include all of it
   }
   (F<$1>)xg;			# /usr/local
  s/((?<=\s)~\w*)/F<$1>/g;	# ~name
  s/(?<![.<\'\"])\b([A-Z_]{2,})\b(?![\'\"])/C<$1>/g;	# UNISTD
  s/(?<![.<\'\"])\b(?!the\b)(\w+)\s+macro\b/C<$1> macro/g; # FILE_cnt macro
  s/n[\0]t/n't/g;		# undo can't, won't damage
}

<GLOS>;				# Skip the preamble
while (<GLOS>) {
  process;
  print CONFIG;
}

print CONFIG <<'ENDOFTAIL';

=back

=head1 NOTE

This module contains a good example of how to use tie to implement a
cache and an example of how to make a tied variable readonly to those
outside of it.

=cut

ENDOFTAIL

close(CONFIG);
close(GLOS);

# Now do some simple tests on the Config.pm file we have created
unshift(@INC,'lib');
require $config_pm;
import Config;

die "$0: $config_pm not valid"
	unless $Config{'PERL_CONFIG_SH'} eq 'true';

die "$0: error processing $config_pm"
	if defined($Config{'an impossible name'})
	or $Config{'PERL_CONFIG_SH'} ne 'true' # test cache
	;

die "$0: error processing $config_pm"
	if eval '$Config{"cc"} = 1'
	or eval 'delete $Config{"cc"}'
	;


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