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.
553 lines
15 KiB
553 lines
15 KiB
@rem = '--*-Perl-*--
|
|
@echo off
|
|
if "%OS%" == "Windows_NT" goto WinNT
|
|
"C:\Perl\bin\perl.exe" -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
|
|
goto endofperl_ppminst
|
|
:WinNT
|
|
"C:\Perl\bin\perl.exe" -x -S %0 %*
|
|
if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl_ppminst
|
|
if %errorlevel% == 9009 echo You do not have Perl in your PATH.
|
|
if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
|
|
goto endofperl_ppminst
|
|
@rem ';
|
|
#!perl
|
|
#line 15
|
|
use strict;
|
|
use FindBin;
|
|
use lib "$FindBin::Bin/../lib";
|
|
use Data::Dumper;
|
|
use PPM::Config;
|
|
|
|
my $VERSION = '3.00';
|
|
|
|
my %INST;
|
|
my %CONF;
|
|
my %keys = (
|
|
ARCHITECTURE => 0,
|
|
CPU => 0,
|
|
OSVALUE => 0,
|
|
OSVERSION => 0,
|
|
PERLCORE => 0,
|
|
root => 1,
|
|
tempdir => 1,
|
|
TARGET_TYPE => 0,
|
|
VERSION => 0,
|
|
);
|
|
my $ERR;
|
|
|
|
#============================================================================
|
|
# Register a dummy object which implements the required interface.
|
|
#============================================================================
|
|
my $i = bless { }, "Implementation";
|
|
PPM::InstallerClient::init($ENV{PPM_PORT}, $i);
|
|
|
|
#============================================================================
|
|
# Command Implementors
|
|
#============================================================================
|
|
package Implementation;
|
|
@Implementation::ISA = qw(PPM::InstallerClient);
|
|
|
|
use Config;
|
|
use Fcntl qw(LOCK_SH LOCK_UN LOCK_EX);
|
|
use PPM::InstallerClient;
|
|
use PPM::PPD;
|
|
use PPM::Search;
|
|
use Data::Dumper;
|
|
|
|
# There's a bug in ExtUtils::Install in perl 5.6.1.
|
|
# Also exists in ActivePerl 522 (line 168)
|
|
BEGIN {
|
|
local $^W;
|
|
require ExtUtils::Install;
|
|
}
|
|
|
|
# Query installed packages: returns a list of records about the results.
|
|
sub query {
|
|
my $inst = shift;
|
|
my $query = shift;
|
|
my $case = shift;
|
|
|
|
load_pkgs();
|
|
my @ppds = map { $_->{ppd} } values %INST;
|
|
my @matches = PPM::PPD::Search->new($query, $case)->search(@ppds);
|
|
return map { $_->ppd } @matches;
|
|
}
|
|
|
|
sub properties {
|
|
my $inst = shift;
|
|
my $pkg = shift;
|
|
if (pkg_installed($pkg) && load_pkg($pkg)) {
|
|
return ($INST{$pkg}{ppd}->ppd,
|
|
$INST{$pkg}{pkg}{INSTDATE},
|
|
$INST{$pkg}{pkg}{LOCATION});
|
|
}
|
|
$ERR = "'$pkg' is not installed";
|
|
return ();
|
|
}
|
|
|
|
sub dependents {
|
|
my $inst = shift;
|
|
my $pkg = shift;
|
|
if (pkg_installed($pkg) && load_pkg($pkg)) {
|
|
return @{ $INST{$pkg}{pkg}{dependents} || [] };
|
|
}
|
|
undef;
|
|
}
|
|
|
|
sub remove {
|
|
my $inst = shift;
|
|
my $pkg = shift;
|
|
|
|
if (pkg_installed($pkg) && load_pkg($pkg)) {
|
|
my $packlist = $INST{$pkg}{pkg}{INSTPACKLIST};
|
|
(my $altpacklist = $packlist) =~ s<\Q$CONF{ARCHITECTURE}\E[\\/]><>i;
|
|
if (-f $packlist) {
|
|
eval {
|
|
ExtUtils::Install::uninstall($packlist, 1, 0);
|
|
};
|
|
}
|
|
elsif (-f $altpacklist) {
|
|
eval {
|
|
ExtUtils::Install::uninstall($altpacklist, 1, 0);
|
|
};
|
|
}
|
|
$ERR = "$@" and return 0 if $@;
|
|
|
|
# Update html table of contents, if ActivePerl::DocTools is installed:
|
|
if (eval { require ActivePerl::DocTools; 1 }) {
|
|
ActivePerl::DocTools::WriteTOC();
|
|
}
|
|
|
|
# Remove the package and references to it:
|
|
my $ppd_ref = $INST{$pkg}{ppd};
|
|
for my $impl ($ppd_ref->implementations) {
|
|
my $match = 1;
|
|
for my $field (keys %$impl) {
|
|
next if ref($field);
|
|
my $value = $inst->config_get($field);
|
|
next unless defined $value;
|
|
$match &&= ($value eq $impl->{$field});
|
|
}
|
|
if ($match == 1) {
|
|
del_dependent($_->name, $ppd_ref->name)
|
|
for $impl->prereqs;
|
|
last;
|
|
}
|
|
}
|
|
purge_pkg($pkg);
|
|
}
|
|
else {
|
|
$ERR = "package '$pkg' not installed.";
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
sub precious {
|
|
return @{$CONF{precious}};
|
|
}
|
|
|
|
sub bundled {
|
|
return @{$CONF{bundled}};
|
|
}
|
|
|
|
sub upgrade {
|
|
my ($inst, $pkg, $ppmpath, $ppd, $repos) = @_;
|
|
remove($inst, $pkg);
|
|
install($inst, $pkg, $ppmpath, $ppd, $repos);
|
|
}
|
|
|
|
sub install {
|
|
my ($inst, $pkg, $ppmpath, $ppd, $repos) = @_;
|
|
use Cwd qw(getcwd);
|
|
my $cwd = getcwd();
|
|
|
|
# Install:
|
|
# 1. chdir to temp directory
|
|
chdir $ppmpath or do {
|
|
$ERR = "can't chdir to $ppmpath: $!";
|
|
return 0;
|
|
};
|
|
chdir $pkg; # this is expected to fail!
|
|
reloc_perl('.') if $Config{osname} ne 'MSWin32';
|
|
|
|
# 2. use ExtUtils::MakeMaker to install the blib
|
|
my $inst_archlib = $Config{installsitearch};
|
|
my $inst_root = $Config{prefix};
|
|
my $packlist = MM->catfile("$inst_archlib/auto",
|
|
split(/-/, $pkg), ".packlist");
|
|
|
|
# Copied from ExtUtils::Install
|
|
my $INST_LIB = MM->catdir(MM->curdir, "blib", "lib");
|
|
my $INST_ARCHLIB = MM->catdir(MM->curdir, "blib", "arch");
|
|
my $INST_BIN = MM->catdir(MM->curdir, "blib", "bin");
|
|
my $INST_SCRIPT = MM->catdir(MM->curdir, "blib", "script");
|
|
my $INST_MAN1DIR = MM->catdir(MM->curdir, "blib", "man1");
|
|
my $INST_MAN3DIR = MM->catdir(MM->curdir, "blib", "man3");
|
|
my $INST_HTMLDIR = MM->catdir(MM->curdir, "blib", "html");
|
|
my $INST_HTMLHELPDIR = MM->catdir(MM->curdir, "blib", "htmlhelp");
|
|
|
|
my $inst_script = $Config{installscript};
|
|
my $inst_man1dir = $Config{installman1dir};
|
|
my $inst_man3dir = $Config{installman3dir};
|
|
my $inst_bin = $Config{installbin};
|
|
my $inst_htmldir = $Config{installhtmldir};
|
|
my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
|
|
my $inst_lib = $Config{installsitelib};
|
|
|
|
# For some reason, some boxes don't have installhtml* in Config.pm:
|
|
$inst_htmldir ||= "$inst_bin/../html";
|
|
$inst_htmlhelpdir ||= "$inst_bin/../html";
|
|
|
|
if ($CONF{root} && $CONF{root} !~ /^\Q$inst_root\E$/i) {
|
|
my $root = $CONF{root};
|
|
$packlist =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_lib =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_archlib =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_bin =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_script =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_man1dir =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_man3dir =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_htmldir =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_htmlhelpdir =~ s/\Q$inst_root/$root\E/i;
|
|
$inst_root = $root;
|
|
}
|
|
|
|
while (1) {
|
|
eval {
|
|
ExtUtils::Install::install({
|
|
"read" => $packlist, "write" => $packlist,
|
|
$INST_LIB => $inst_lib, $INST_ARCHLIB => $inst_archlib,
|
|
$INST_BIN => $inst_bin, $INST_SCRIPT => $inst_script,
|
|
$INST_MAN1DIR => $inst_man1dir, $INST_MAN3DIR => $inst_man3dir,
|
|
$INST_HTMLDIR => $inst_htmldir,
|
|
$INST_HTMLHELPDIR => $inst_htmlhelpdir},0,0,0);
|
|
};
|
|
# install might have croaked in another directory
|
|
chdir $cwd;
|
|
# Can't remove some DLLs, but we can rename them and try again.
|
|
if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
|
|
my $oldname = $1;
|
|
$oldname =~ s/:$//;
|
|
my $newname = $oldname . "." . time();
|
|
unless (rename($oldname, $newname)) {
|
|
$ERR = "renaming $oldname to $newname: $!";
|
|
return 0;
|
|
}
|
|
}
|
|
# Some other error
|
|
elsif($@) {
|
|
$ERR = "$@";
|
|
return 0;
|
|
}
|
|
else { last; }
|
|
}
|
|
|
|
# Update html table of contents, if ActivePerl::DocTools is installed:
|
|
if (eval { require ActivePerl::DocTools; 1 }) {
|
|
ActivePerl::DocTools::WriteTOC();
|
|
}
|
|
|
|
# XXX: Run the install script if it exists
|
|
|
|
# Add the package to the list of installed packages
|
|
my $ppd_ref = PPM::PPD->new($ppd);
|
|
$INST{$pkg} = {
|
|
pkg => {
|
|
INSTDATE => scalar localtime,
|
|
LOCATION => $repos,
|
|
INSTROOT => $CONF{root},
|
|
INSTPACKLIST => $packlist,
|
|
},
|
|
ppd => $ppd_ref,
|
|
};
|
|
save_pkg($pkg);
|
|
|
|
# "Register" the package as dependent on each prerequisite:
|
|
# Note: because the PPM::PPD package's find_impl() is designed to use a
|
|
# PPM::Installer() object, we can't use it. Instead, we have to do the
|
|
# work ourselves, here:
|
|
for my $impl ($ppd_ref->implementations) {
|
|
my $match = 1;
|
|
for my $field (keys %$impl) {
|
|
next if ref($field);
|
|
my $value = $inst->config_get($field);
|
|
next unless defined $value;
|
|
$match &&= ($value eq $impl->{$field});
|
|
}
|
|
if ($match == 1) {
|
|
add_dependent($_->name, $pkg)
|
|
for $impl->prereqs;
|
|
last;
|
|
}
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
sub config_keys {
|
|
map { [$_, $keys{$_}] } keys %keys;
|
|
}
|
|
|
|
sub _str {
|
|
my $a = shift;
|
|
return '' unless defined $a;
|
|
$a;
|
|
}
|
|
|
|
sub config_info {
|
|
map { [$_, _str($CONF{$_})] } keys %keys;
|
|
}
|
|
|
|
sub config_set {
|
|
my $inst = shift;
|
|
my ($key, $val) = @_;
|
|
unless (defined $keys{$key}) {
|
|
$ERR = "unknown config key '$key'";
|
|
return 0;
|
|
}
|
|
|
|
$CONF{$key} = $val;
|
|
return 1;
|
|
}
|
|
|
|
sub config_get {
|
|
my $inst = shift;
|
|
my $key = shift;
|
|
unless (defined $key and exists $keys{$key}) {
|
|
$key = '' unless defined $key;
|
|
$ERR = "unknown config key '$key'";
|
|
return undef;
|
|
}
|
|
_str($CONF{$key});
|
|
}
|
|
|
|
sub error_str {
|
|
defined $ERR ? $ERR : 'No error';
|
|
}
|
|
|
|
#----------------------------------------------------------------------------
|
|
# Utilities
|
|
#----------------------------------------------------------------------------
|
|
|
|
# This can deal with files as well as directories
|
|
sub abspath {
|
|
use Cwd qw(abs_path);
|
|
my ($path, $file) = shift;
|
|
if (-f $path) {
|
|
my @p = split '/', $path;
|
|
$path = join '/', @p[0..$#p-1]; # can't use -2 in a range
|
|
$file = $p[-1];
|
|
}
|
|
$path = abs_path($path);
|
|
return ($path, $file, defined $file ? join '/', $path, $file : ())
|
|
if wantarray;
|
|
return defined $file ? join '/', $path, $file : $path;
|
|
}
|
|
|
|
#============================================================================
|
|
# Relocate Perl (stolen from PPM::RelocPerl)
|
|
#============================================================================
|
|
my $frompath_default;
|
|
BEGIN {
|
|
# We have to build up this variable, otherwise
|
|
# PPM will mash it when it upgrades itself.
|
|
$frompath_default =
|
|
('/tmp' .
|
|
'/.ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZpErLZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZperl'
|
|
);
|
|
}
|
|
my ($topath, $frompath);
|
|
|
|
sub wanted {
|
|
if (-l) {
|
|
return; # do nothing for symlinks
|
|
}
|
|
elsif (-B) {
|
|
check_for_frompath($_, 1); # binary file edit
|
|
}
|
|
elsif (-e && -s && -f) {
|
|
check_for_frompath($_, 0); # text file edit
|
|
}
|
|
}
|
|
|
|
sub check_for_frompath {
|
|
my ($file, $binmode) = @_;
|
|
local(*F, $_);
|
|
open(F, "<$file") or die "Can't open `$file': $!";
|
|
binmode F if $binmode;
|
|
while (<F>) {
|
|
if (/\Q$frompath\E/o) {
|
|
close F;
|
|
edit_it($file, $binmode);
|
|
last;
|
|
}
|
|
}
|
|
# implicit close of F;
|
|
}
|
|
|
|
sub edit_it
|
|
{
|
|
my ($file, $binmode) = @_;
|
|
my $nullpad = length($frompath) - length($topath);
|
|
$nullpad = "\0" x $nullpad;
|
|
|
|
local $/;
|
|
# Force the file to be writable
|
|
my $mode = (stat($file))[2] & 07777;
|
|
chmod $mode | 0222, $file;
|
|
open(F, "+<$file") or die "Couldn't open $file: $!";
|
|
binmode(F) if $binmode;
|
|
my $dat = <F>;
|
|
if ($binmode) {
|
|
$dat =~ s|\Q$frompath\E(.*?)\0|$topath$1$nullpad\0|gs;
|
|
} else {
|
|
$dat =~ s|\Q$frompath\E|$topath|gs;
|
|
}
|
|
seek(F, 0, 0) or die "Couldn't seek on $file: $!";
|
|
truncate(F, 0);
|
|
print F $dat;
|
|
close(F);
|
|
# Restore the permissions
|
|
chmod $mode, $file;
|
|
}
|
|
|
|
use File::Find;
|
|
sub reloc_perl
|
|
{
|
|
my ($dir, $opt_topath, $opt_frompath) = @_;
|
|
$topath = defined $opt_topath ? $opt_topath : $Config{'prefix'};
|
|
$frompath = defined $opt_frompath ? $opt_frompath : $frompath_default;
|
|
|
|
find(\&wanted, $dir);
|
|
}
|
|
|
|
#============================================================================
|
|
# Settings and packages
|
|
#============================================================================
|
|
my ($conf_dir, $conf, $conf_obj);
|
|
BEGIN {
|
|
# By putting an invalid package character in the directory, we're making
|
|
# sure no real package could overwrite our settings, and vice versa.
|
|
$conf_dir = join '/', $Config{sitelib}, 'ppm-conf';
|
|
$conf = join '/', $conf_dir, 'ppm.cfg';
|
|
}
|
|
|
|
# Loads the configuration file and populates %CONF
|
|
sub load_conf {
|
|
$conf_obj = PPM::Config->new($conf);
|
|
%CONF = $conf_obj->config;
|
|
|
|
# Special values; set them here
|
|
$CONF{ARCHITECTURE} = $Config{archname};
|
|
$CONF{PERLCORE} = $Config{version};
|
|
$CONF{TARGET_TYPE} = "perl";
|
|
$CONF{VERSION} = '3.00';
|
|
}
|
|
|
|
# Saves %CONF to the configuration file
|
|
sub save_conf {
|
|
$conf_obj->merge(\%CONF);
|
|
$conf_obj->save;
|
|
}
|
|
|
|
# Loads the given package into $INST{$pkg}. Returns true if the package could
|
|
# be loaded, false otherwise.
|
|
sub load_pkg {
|
|
my $pkg = shift;
|
|
|
|
return 1 if exists $INST{$pkg};
|
|
|
|
return 0 unless -f "$conf_dir/$pkg.ppd";
|
|
return 0 unless -f "$conf_dir/$pkg.pkg";
|
|
|
|
my $ppdref = PPM::PPD->new("$conf_dir/$pkg.ppd");
|
|
my $pkgfile = "$conf_dir/$pkg.pkg";
|
|
my $pkgref = PPM::Config->new($pkgfile);
|
|
|
|
$INST{$pkg}{ppd} = $ppdref;
|
|
$INST{$pkg}{pkg} = $pkgref->config;
|
|
return 1;
|
|
}
|
|
|
|
# Saves the given package from $INST{$pkg}.
|
|
sub save_pkg {
|
|
my $pkg = shift;
|
|
return 0 unless exists $INST{$pkg};
|
|
|
|
# The PPD file:
|
|
my $ppdfile = "$conf_dir/$pkg.ppd";
|
|
if (-f $ppdfile) {
|
|
unlink $ppdfile or die "$0: can't delete $ppdfile: $!";
|
|
}
|
|
open PPD, "> $ppdfile" or die "$0: can't write $ppdfile: $!";
|
|
print PPD $INST{$pkg}{ppd}->ppd;
|
|
close PPD or die "$0: can't close $ppdfile: $!";
|
|
|
|
# the PKG file:
|
|
my $c = PPM::Config->new;
|
|
$c->load($INST{$pkg}{pkg});
|
|
$c->save("$conf_dir/$pkg.pkg");
|
|
return 1;
|
|
}
|
|
|
|
sub add_dependent {
|
|
my $package = shift;
|
|
my $dependent = shift;
|
|
return 0 unless load_pkg($package);
|
|
push @{$INST{$package}{pkg}{dependents}}, $dependent;
|
|
save_pkg($package);
|
|
}
|
|
|
|
sub del_dependent {
|
|
my $package = shift;
|
|
my $dependent = shift;
|
|
return 0 unless load_pkg($package);
|
|
@{$INST{$package}{pkg}{dependents}}
|
|
= grep { $_ ne $dependent }
|
|
@{$INST{$package}{pkg}{dependents}};
|
|
save_pkg($package);
|
|
}
|
|
|
|
sub purge_pkg {
|
|
my $pkg = shift;
|
|
|
|
# The PPD file:
|
|
my $ppdfile = "$conf_dir/$pkg.ppd";
|
|
if (-f $ppdfile) {
|
|
unlink $ppdfile or die "$0: can't delete $ppdfile: $!";
|
|
}
|
|
|
|
# The %INST entry:
|
|
delete $INST{$pkg};
|
|
|
|
# The PKG file:
|
|
my $pkgfile = "$conf_dir/$pkg.pkg";
|
|
if (-f $pkgfile) {
|
|
unlink $pkgfile or die "$0: can't delete $pkgfile: $!";
|
|
}
|
|
|
|
return 1;
|
|
}
|
|
|
|
# Load all packages: only needed when doing an advanced query
|
|
sub load_pkgs {
|
|
my @pkgs = map { s/\.ppd$//; s!.*/([^/]+)$!$1!g; $_ } #!
|
|
glob "$conf_dir/*.ppd";
|
|
load_pkg($_) for @pkgs;
|
|
}
|
|
|
|
sub pkg_installed {
|
|
my $pkg = shift;
|
|
return -f "$conf_dir/$pkg.ppd" && -f "$conf_dir/$pkg.pkg";
|
|
}
|
|
|
|
BEGIN {
|
|
load_conf();
|
|
}
|
|
END {
|
|
save_conf();
|
|
}
|
|
|
|
__END__
|
|
:endofperl_ppminst
|