@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