PC World 2003 March/PCWorld_2003-03_cd.bin/Software/Topware/activeperl/ActivePerl/Perl/bin/config.pl

Text File | 2002-06-02 | 5.4 KB | 243 lines

###############################################################################
#
# Script:    config.pl
# Purpose:    Fix up Config.pm after a binary installation
# Author:    Michael Smith <[e-mail]>
#
# Copyright ⌐ 1999-2001 ActiveState Tool Corp.
#
###############################################################################

my $prefix = shift;
# get prefix from script location, ignoring the last two components
$prefix = $1 if !$prefix and $0 =~ m#^(.*)([\\/][^\\/]+){2}$#;
$prefix =~ s{[\\/]$}{};
my $libpth = $ENV{LIB};
my $user   = $ENV{USERNAME};
my $file   = $prefix . '\lib\Config.pm';
my $oldfile = $prefix . '\lib\Config.pm~';

$tmp = $ENV{'TEMP'} || $ENV{'tmp'};
if ($^O =~ /MSWin/) {
    $tmp ||= 'c:/temp';
}
else {
    $tmp ||= '/tmp';
}

print 'Configuring Perl ... ' . "\n";

# Remove the "command" value from the file association to prevent the MSI
# "Repair" feature from triggering once an included extension has been
# upgraded by PPM.
if ($^O =~ /MSWin/) {
    require Win32::Registry;
    $::HKEY_CLASSES_ROOT->Open('Perl\shell\Open\command', my $command);
    $command->DeleteValue('command') if $command;
}

my %replacements = (
    archlib            => "'$prefix\\lib'",
    archlibexp        => "'$prefix\\lib'",
    bin            => "'$prefix\\bin'",
    binexp            => "'$prefix\\bin'",
    cf_by            => "'ActiveState'",
    installarchlib        => "'$prefix\\lib'",
    installbin        => "'$prefix\\bin'",
    installhtmldir        => "'$prefix\\html'",
    installhtmlhelpdir     => "'$prefix\\htmlhelp'",
    installman1dir        => "''",
    installman3dir        => "''",
    installprefix        => "'$prefix'",
    installprefixexp    => "'$prefix'",
    installprivlib        => "'$prefix\\lib'",
    installscript        => "'$prefix\\bin'",
    installsitearch        => "'$prefix\\site\\lib'",
    installsitebin        => "'$prefix\\bin'",
    installsitelib        => "'$prefix\\site\\lib'",
    libpth            => q('") . join(q(" "), split(/;/, $libpth), $prefix . "\\lib\\CORE") . q("'),
    man1dir            => "''",
    man1direxp        => "''",
    man3dir            => "''",
    man3direxp        => "''",
    perlpath        => "'$prefix\\bin\\perl.exe'",
    prefix            => "'$prefix'",
    prefixexp        => "'$prefix'",
    privlib            => "'$prefix\\lib'",
    privlibexp        => "'$prefix\\lib'",
    scriptdir        => "'$prefix\\bin'",
    scriptdirexp        => "'$prefix\\bin'",
    sitearch        => "'$prefix\\site\\lib'",
    sitearchexp        => "'$prefix\\site\\lib'",
    sitebin            => "'$prefix\\site\\bin'",
    sitebinexp        => "'$prefix\\site\\bin'",
    sitelib            => "'$prefix\\site\\lib'",
    sitelibexp        => "'$prefix\\site\\lib'",
    siteprefix        => "'$prefix\\site'",
    siteprefixexp        => "'$prefix\\site'",
);

my $pattern = '^(' . join('|', keys %replacements) . ')=.*';

chmod(0644, $file)
    or warn "Unable to chmod(0644, $file) : $!";

if(open(FILE, "+<$file")) {
    my @Config;
    while(<FILE>) {
    s/$pattern/$1=$replacements{$1}/;
    push(@Config, $_);
    }

    seek(FILE, 0, 0);
    truncate(FILE, 0);
    print FILE @Config;
    close(FILE);
}
else {
    print "Unable to open $file : $!\n\n";
    print "Press [Enter] to continue:\n";
    <STDIN>;
    exit 1;
}

###############################################################################
# Config.pm values to propogate when doing an upgrade installation
###############################################################################
my @propagateThese = qw(
    ar
    awk
    bash
    bin
    binexp
    bison
    byacc
    cat
    cc
    cp
    cryptlib
    csh
    date
    echo
    egrep
    emacs
    expr
    find
    flex
    full_csh
    full_sed
    gccversion
    glibpth
    gzip
    incpath
    inews
    ksh
    ld
    lddlflags
    ldflags
    less
    libc
    libpth
    ln
    lns
    loincpth
    lolibpth
    lp
    lpr
    ls
    mail
    mailx
    make
    mkdir
    more
    mv
    mydomain
    myhostname
    myuname
    pager
    rm
    rmail
    sed
    sendmail
    sh
    tar
    touch
    tr
    usrinc
    vi
    xlibpth
    zcat
    zip
);

if(-f $oldfile) {
    mergeConfig($oldfile, $file);
}

###############################################################################
#
###############################################################################
sub mergeConfig {
    my $file1 = shift;
    my $file2 = shift;

    open(FILE1, "<$file1")
    || do {
        warn "Could not open file $file1 : $!";
        return -1;
    };

    my $foundConfigBegin = 0;
    my $foundConfigEnd = 0;
    my %Config1 = ();
    while(<FILE1>) {
    chomp;
    if (!$foundConfigBegin && /^my \$config_sh = <<'!END!';$/) {
        $foundConfigBegin = 1;
        next;
    }
    elsif (!$foundConfigEnd && /^!END!$/) {
        last;
    }
    next if(!$foundConfigBegin);
    my ($name, $value) = split(/=/, $_, 2);
    if(grep(/$name/, @propagateThese)) {
        $Config1{$name} = $value;
    }
    }
    close(FILE1);

    open(FILE2, "+<$file2")
    || do {
        warn "Could not open file $file2 : $!";
        return -1;
    };

    $foundConfigBegin = 0;
    $foundConfigEnd = 0;
    my @Config2 = ();
    while(<FILE2>) {
    my $line = $_;
    chomp($line);
    if (!$foundConfigBegin && $line =~ /^my \$config_sh = <<'!END!';$/) {
        $foundConfigBegin = 1;
    }
    elsif (!$foundConfigEnd && $line =~ /^!END!$/) {
        $foundConfigEnd = 1;
    }
    elsif ($foundConfigBegin && !$foundConfigEnd) {
        my ($name, $value) = split(/=/, $line, 2);
        if(exists $Config1{$name} && length($Config1{$name}) > 0) {
        $line = "$name=$Config1{$name}";
        }
    }
    push(@Config2, $line . "\n");
    }
    truncate(FILE2, 0);
    seek(FILE2, 0, 0);
    print FILE2 (@Config2);
    close(FILE2);
    return;
}