Leaked source code of windows server 2003
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

232 lines
5.0 KiB

###############################################################################
#
# Script: config.pl
# Purpose: Fix up Config.pm after a binary installation
# Author: Michael Smith <[email protected]>
#
# 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";
my %replacements = (
archlib => "'$prefix\\lib'",
archlibexp => "'$prefix\\lib'",
bin => "'$prefix\\bin'",
binexp => "'$prefix\\bin'",
cf_by => "'$user'",
cf_email => "'$user\@localhost'",
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'",
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(0600, $file)
or warn "Unable to chmod(0600, $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>;
}
###############################################################################
# Config.pm values to propogate when doing an upgrade installation
###############################################################################
my @propagateThese = qw(
ar
awk
bash
bin
binexp
bison
byacc
cat
cc
cf_by
cf_email
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;
}