source: trunk/essentials/dev-lang/perl/configpm@ 3951

#!./miniperl -w
use strict;
use vars qw(%Config $Config_SH_expanded);

my $how_many_common = 22;

# commonly used names to precache (and hence lookup fastest)
my %Common;

while ($how_many_common--) {
    $_ = <DATA>;
    chomp;
    /^(\S+):\s*(\d+)$/ or die "Malformed line '$_'";
    $Common{$1} = $1;
}

# names of things which may need to have slashes changed to double-colons
my %Extensions = map {($_,$_)}
                 qw(dynamic_ext static_ext extensions known_extensions);

# allowed opts as well as specifies default and initial values
my %Allowed_Opts = (
    'cross'    => '', # --cross=PLATFORM - crosscompiling for PLATFORM
    'glossary' => 1,  # --no-glossary  - no glossary file inclusion,
                      #                  for compactness
    'heavy' => '',   # pathname of the Config_heavy.pl file
);

sub opts {
    # user specified options
    my %given_opts = (
        # --opt=smth
        (map {/^--([\-_\w]+)=(.*)$/} @ARGV),
        # --opt --no-opt --noopt
        (map {/^no-?(.*)$/i?($1=>0):($_=>1)} map {/^--([\-_\w]+)$/} @ARGV),
    );

    my %opts = (%Allowed_Opts, %given_opts);

    for my $opt (grep {!exists $Allowed_Opts{$_}} keys %given_opts) {
        die "option '$opt' is not recognized";
    }
    @ARGV = grep {!/^--/} @ARGV;

    return %opts;
}


my %Opts = opts();

my ($Config_PM, $Config_heavy);
my $Glossary = $ARGV[1] || 'Porting/Glossary';

if ($Opts{cross}) {
  # creating cross-platform config file
  mkdir "xlib";
  mkdir "xlib/$Opts{cross}";
  $Config_PM = $ARGV[0] || "xlib/$Opts{cross}/Config.pm";
}
else {
  $Config_PM = $ARGV[0] || 'lib/Config.pm';
}
if ($Opts{heavy}) {
  $Config_heavy = $Opts{heavy};
}
else {
  ($Config_heavy = $Config_PM) =~ s!\.pm$!_heavy.pl!;
  die "Can't automatically determine name for Config_heavy.pl from '$Config_PM'"
    if $Config_heavy eq $Config_PM;
}

open CONFIG, ">$Config_PM" or die "Can't open $Config_PM: $!\n";
open CONFIG_HEAVY, ">$Config_heavy" or die "Can't open $Config_heavy: $!\n";

print CONFIG_HEAVY <<'ENDOFBEG';
# 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.

package Config;
use strict;
# use warnings; Pulls in Carp
# use vars pulls in Carp
ENDOFBEG

my $myver = sprintf "v%vd", $^V;

printf CONFIG <<'ENDOFBEG', ($myver) x 3;
# 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.

package Config;
use strict;
# use warnings; Pulls in Carp
# use vars pulls in Carp
@Config::EXPORT = qw(%%Config);
@Config::EXPORT_OK = qw(myconfig config_sh config_vars config_re);

# Need to stub all the functions to make code such as print Config::config_sh
# keep working

sub myconfig;
sub config_sh;
sub config_vars;
sub config_re;

my %%Export_Cache = map {($_ => 1)} (@Config::EXPORT, @Config::EXPORT_OK);

our %%Config;

# Define our own import method to avoid pulling in the full Exporter:
sub import {
    my $pkg = shift;
    @_ = @Config::EXPORT unless @_;

    my @funcs = grep $_ ne '%%Config', @_;
    my $export_Config = @funcs < @_ ? 1 : 0;

    no strict 'refs';
    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};
    }

    *{"$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) . ")";

ENDOFBEG


my @non_v    = ();
my @v_others = ();
my $in_v     = 0;
my %Data     = ();


my %seen_quotes;
{
  my ($name, $val);
  open(CONFIG_SH, 'config.sh') || die "Can't open config.sh: $!";
  while (<CONFIG_SH>) {
    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/ or m/^(\w+)='(.*)'$/;
    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;
    }
    my $quote = $2;
    if ($in_v) { 
        $val .= $_;
    }
    else { 
        ($name,$val) = ($1,$3); 
    }
    $in_v = $val !~ /$quote\n/;
    next if $in_v;

    s,/,::,g if $Extensions{$name};

    $val =~ s/$quote\n?\z//;

    my $line = "$name=$quote$val$quote\n";
    push(@v_others, $line);
    $seen_quotes{$quote}++;
  }
  close CONFIG_SH;
}

# This is somewhat grim, but I want the code for parsing config.sh here and
# now so that I can expand $Config{ivsize} and $Config{ivtype}

my $fetch_string = <<'EOT';

# Search for it in the big string
sub fetch_string {
    my($self, $key) = @_;

EOT

if ($seen_quotes{'"'}) {
    # We need the full ' and " code
    $fetch_string .= <<'EOT';
    my $quote_type = "'";
    my $marker = "$key=";

    # Check for the common case, ' delimited
    my $start = index($Config_SH_expanded, "\n$marker$quote_type");
    # If that failed, check for " delimited
    if ($start == -1) {
        $quote_type = '"';
        $start = index($Config_SH_expanded, "\n$marker$quote_type");
    }
EOT
} else {
    $fetch_string .= <<'EOT';
    # We only have ' delimted.
    my $start = index($Config_SH_expanded, "\n$key=\'");
EOT
}
$fetch_string .= <<'EOT';
    # Start can never be -1 now, as we've rigged the long string we're
    # searching with an initial dummy newline.
    return undef if $start == -1;

    $start += length($key) + 3;

EOT
if (!$seen_quotes{'"'}) {
    # Don't need the full ' and " code, or the eval expansion.
    $fetch_string .= <<'EOT';
    my $value = substr($Config_SH_expanded, $start,
                       index($Config_SH_expanded, "'\n", $start)
                       - $start);
EOT
} else {
    $fetch_string .= <<'EOT';
    my $value = substr($Config_SH_expanded, $start,
                       index($Config_SH_expanded, "$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\"";
    }
EOT
}
$fetch_string .= <<'EOT';
    # So we can say "if $Config{'foo'}".
    $value = undef if $value eq 'undef';
    $self->{$key} = $value; # cache it
}
EOT

eval $fetch_string;
die if $@;

# Calculation for the keys for byteorder
# This is somewhat grim, but I need to run fetch_string here.
our $Config_SH_expanded = join "\n", '', @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);
our \$byteorder = join('', unpack('$format', pack('$f', \$i)));
EOT
} else {
    $byteorder_code = "our \$byteorder = '?'x$s;\n";
}

print CONFIG_HEAVY @non_v, "\n";

# copy config summary format from the myconfig.SH script
print CONFIG_HEAVY "our \$summary = <<'!END!';\n";
open(MYCONFIG,"<myconfig.SH") || die "open myconfig.SH failed: $!";
1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
do { print CONFIG_HEAVY $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
close(MYCONFIG);

print CONFIG_HEAVY "\n!END!\n", <<'EOT';
my $summary_expanded;

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

local *_ = \my $a;
$_ = <<'!END!';
EOT

print CONFIG_HEAVY join('', sort @v_others), "!END!\n";

# Only need the dynamic byteorder code in Config.pm if 'byteorder' is one of
# the precached keys
if ($Common{byteorder}) {
    print CONFIG $byteorder_code;
} else {
    print CONFIG_HEAVY $byteorder_code;
}

print CONFIG_HEAVY <<'EOT';
s/(byteorder=)(['"]).*?\2/$1$2$Config::byteorder$2/m;

my $config_sh_len = length $_;

our $Config_SH_expanded = "\n$_" . << 'EOVIRTUAL';
EOT