#! /usr/bin/perl
# $Id: install,v 1.9.2.8 1998/05/06 21:38:14 asm21 Exp $

use diagnostics;
use strict;

use IO::Handle;

# extract the directory containing the binary files, and read a global set of
# routines from a file in that directory.
my $bindir;
BEGIN {
    my @path=split("/",$0);
    $#path--;
    $bindir=join("/",@path);
    do "$bindir/generic" or die "Failed to execute generic routine library $bindir/generic: $!\n";
}

boldecho "Install from a mountable filesystem\n";

my $vardir=$ARGV[0];
my $method=$ARGV[1];
my $option=$ARGV[2];

chdir("$vardir/methods/mountable");

do options or die "Couldn't read configuration file (re-choose under Access)";

my $debug=0;
if ($option eq "debug") {
    local $^W = 0;
    eval 'sub syscmd { my $cmd=shift; echo($cmd); }';
    $debug=1;
}

my @errorlist=();
my %errortext;
my %oldver;
my %newver;
my %file;
my %md5sum;

# we want to redirect dpkg output etc here, too, so we can't really leave it
# open all the time.
my $logopen=0;
sub logopen {
    unless ($logopen) {
	if (!$debug) {
	    open(LOGF,">>$::logfile") or die "Cannot open logfile $::logfile. Aborting.\n";
	} else {
	    open(LOGF,">-");
	}
    }
    $logopen=1;
}
sub logclose {
    close(LOGF) or die "Error closing logfile $::logfile. Aborting.\n" if $logopen;
    $logopen=0;
}
sub logprint {
    my $s=shift;
    my $lo=0;
    
    if (!$logopen) {
	$lo=1;
	logopen();
    }
    print LOGF "LOG> " if ($debug);
    print LOGF $s;
    logclose() if ($lo);
}

# umount things, print error lists, etc
sub tidyup {
    doumount();
    if (@errorlist) {
	my $e;
	logopen();
	print("\nFailed to install the following packages:\n");
	logprint("\n\nFailed to install the following packages:\n");
	for $e (@errorlist) {
	    print(" $e: $errortext{$e}\n");
	    logprint(" $e: $errortext{$e}\n");
	}
	print("\n");
    }
    logclose();
}

sub errorinpackage {
    my ($pkg,$stage)=@_;
    delete $file{$pkg} if (defined($file{$pkg}));
    @errorlist=(@errorlist,$pkg);
    $errortext{$pkg}=$stage;
}

# print a nice message
sub errinnotinstalled {
    my $pkg=$_;

    # we seem to get this sometimes, so at least give a reasonable error
    # message.
    $pkg='<unknown>' unless defined($pkg);
    
    my $m="ERROR: dpkg-mountable has detected an error in a package $pkg\n".
    "which was not installed during the current run. This almost\n".
    "certainly means that dpkg exited with an error code, but failed\n".
    "to give a summary of the problems it encountered. Please check\n".
    "the log file $::logfile to confirm this.\n\n".
    "If this is case but you cannot tell why dpkg failed to produce\n".
    "this list, please do not file a bug, but send the logfile\n".
    "(including logs for both this run and the preceding one) to the\n".
    "maintainer, Andy Mortimer <andy.mortimer\@poboxes.com>. If you\n".
    "work out why it happened, I would very much like to know!\n\n";
    print($m);
    logprint($m);
    die "Aborting.\n";
}
    
# parse a log file, and return a list of packages which had errors, as printed
# by dpkg (ie, don't do any extra parsing)
sub parselogerrs {
    my $gotlist=0;
    my @errs;
    my $file=shift;
    
    logclose();
    
    open(LOGFILE,"<$file") or die;

    while (<LOGFILE>) {
	if (/^[^ \t\n\r]/) {
	    $gotlist=0;
	}
	if ($gotlist) {
	    s/[ \t\n\r]*$//;
	    s/^[ \t\n\r]*//;
	    @errs=(@errs,$_);
	}
	if (/^Errors were encountered while processing:/) {
	    @errs=();
	    $gotlist=1;
	}
    }

    close(LOGFILE);

    return @errs;
}

# if the list of packages to install is empty, stop.
sub stopifdone {
    if (!scalar(%file)) {
	echo("No packages left to install!");
	logprint("No packages remain on install list. Stopping.\n");
	tidyup();
	exit 1;
    }
}

sub findpackage {
    my $fname=shift;
    
    if ( -r $::localpath . "/" . $fname ) {
	return $::localpath . "/" . $fname;
    } elsif ( -r $::rootpath . "/" . $fname ) {
	return $::rootpath . "/" . $fname;
    } else {
	# catch-lots case: if it's not in one of the obvious places, try
	# chopping off directories until we hit it. If this doesn't turn
	# it up, it's probably not there ...
	my $d;
	my @namelist;

	# calculate a list of filenames, with progressively fewer /s in.
	{
	    my $f=$fname;
	    while ($f =~ m{/}) {
		push @namelist,$f;
		$f=~s{^[^/]*/}{};
	    }
	    push @namelist,$f; # necessary if $f doesn't include any /
	}
	
      DIRS: for $d (@::dirlist) {
	  my $f;
	  for $f (@namelist) {
	      my $try;
	      for $try ("$::localpath/$f", "$::localpath/$d/$f",
			"$::rootpath/$f", "$::rootpath/$d/$f") {
		  if ( -r "$try" ) {
		      return "$try";
		      last DIRS;
		  }
	      }
	  }
      }
    }
    # OK, give up.
    return undef;
}

# list of files to install

echo "Log in $::logfile\n";

domount();

logopen();
logprint("\n\n".("="x75)."\ndpkg-mountable, run on ".localtime(time)."\n\n");

# get dpkg to spawn a new shell rather than backgrounding
$ENV{'DPKG_NO_TSTP'}="yes";

# before making nice lists, but after all the initialisation, check for
# predependencies.
{
    my $predep;
    my $aupmsg="NB: If this error is occurring as part of an upgrade to hamm, it is STRONGLY\n".
	       "    recommended that you see the autoup.sh script, which can be found on\n".
	       "    <http://debian.vicnet.net.au/autoup>, and should also hopefully be\n".
	       "    somewhere on your Debian CD.\n";

    sub abortpredep {
	my $error=shift;
	my $m="The above-listed package(s) were reported by dpkg as being required in order\n".
	      "to fulfill pre-dependencies for one or more of the other packages which I am\n".
	      "going to install. However, I'm afraid that the somewhat rudimentary support\n".
	      "which I have for predependencies appears to have failed, so please either:\n".
	      "  (a)  Install the package yourself by hand, or\n".
	      "  (b)  Use one of the other dpkg installation methods.\n".
	      "Sorry.\n\n".$aupmsg;
	      

        logprint("Predepends error $error\n\n$m\n");
	
	echo $predep;
	boldecho "Predepends not yet supported!";
	echo "\nError: $error\n\n$m";
	
	tidyup;
	exit 1;
    }

    #
    # this code is untested. Disable it unless the user really wants it.
    #
    unless (defined($ENV{'DPKG_MOUNTABLE_PREDEP_SUPPORT'})) {
        my $predep=`dpkg --predep-package`;
        if ($predep ne "") {
	    print("\n$predep\n");
	    boldecho "Predepends not yet supported!";
	    echo "The above-listed package(s) were reported by dpkg as being required in order\n".
	         "to fulfill pre-dependencies for one or more of the other packages which I am\n".
		 "going to install. However, I'm afraid that I don't currently have support for\n".
		 "predependencies, so please either:\n".
		 "  (a)  Install the package yourself by hand, or\n".
		 "  (b)  Use one of the other dpkg installation methods.\n".
		 "Sorry.\n\n".
		 "The output above can also be found in the logs, $::logfile\n\n".$aupmsg;
	    logprint($predep);
	    logprint("\nPredepends disabled and predependency found (above), aborting\n");
	    tidyup;
	    exit 1;
	}
    } else {
        my $chkpkg=undef;
        while ($predep=`dpkg --predep-package`, $predep ne "") {
	    logprint("\n".$predep."\n");
            # this is an available-file entry for a package which needs to be
	    # installed. Don't bother parsing it properly, cos I'm too lazy.
	    $predep =~ m/^Package: ([^\n]*)\n/m;
	    my $pkg=$1;    
	    $predep =~ m/^Filename: ([^\n]*)\n/m;
	    my $fname=$1;    
	    abortpredep("Cannot parse dpkg output") unless (defined($pkg) and defined($fname));

            if (defined($chkpkg)) {
	        if ($chkpkg eq $pkg) {
		    abortpredep("Predependency on installed (or so I thought) package $pkg");
		}
	    }
	    $chkpkg=$pkg;
	    
            echo "Found unsatisfied predependency $pkg\n";
	    logprint("Found unsatisfied predependency $pkg\n");
	
	    my $file=findpackage($fname);
	    abortpredep("Cannot find predepended-on file $fname for $pkg\n")
	        unless defined($fname);

            logclose();

            logprint("Installing predependency $pkg from $fname\n");
	
	    my $dpkgargs="--admindir=$vardir --refuse-downgrade --auto-deconfigure --install";
	    $dpkgargs = "--refuse-overwrite ".$dpkgargs unless $::allowoverwrite;
	    if (!syscmd("$bindir/logcmd -aq -f $::logfile -- dpkg $dpkgargs $file")) {
	        abortpredep("dpkg exited with an error status. Aborting run.");
	    
                tidyup();
		exit 1;
	    }
	}
    }
}

sub getpkglist {
    boldecho "Constructing list of packages to install:";
    echo "$bindir/updated-packages $vardir/status $vardir/methods/mountable/available";
    open(FUPD,"$bindir/updated-packages $vardir/status $vardir/methods/mountable/available|")
	or die "Error parsing package list";

    my $fcount=0;

    while (<FUPD>) {
	chop;
	my ($pkg,$fname,$oldver,$newver,$md5sum)=split(/\t/,$_);
	$fcount++;
	if ( $fname eq '' ) {
	    echo "Error: package $pkg does not have a filename! Skipping.";
	    logprint("Package $pkg has no filename, skipping.\n");
	    errorinpackage($pkg, "package has no filename");
	} else {
	    my $realfn;
	    $realfn=findpackage($fname);

	    if (defined($realfn)) {
		$file{$pkg}=$realfn;
	    } else {
		logprint("Package $pkg version $newver (file $fname) cannot be found. Skipping.\n");
		echo "Warning: package $pkg, version $newver not available for installation. Skipping.";
		errorinpackage($pkg, "package file not found");
	    }
	}

	$newver{$pkg}=$newver;
	$oldver{$pkg}=$oldver;
	$md5sum{$pkg}=$md5sum;
    }
    close(FUPD);

    if ($fcount == 0) {
	boldecho 'Nothing to do.';
	logprint("\nNo packages need installing or upgrading.\n");
	tidyup();
	exit 0;
    }

    if (!defined(%file)) {
	logprint("\nThere are packages marked for install/upgrade, but none are available.\n");
	echo('None of the requested files are yet available. Sorry.');
	tidyup();
	waitkey();
	exit 0;
    }
}
getpkglist();

sub md5sum {
    my $file=shift;
    open(MD5,"md5sum $file|") or return '';
    my ($md5sum,$fname)=split(/[ \t]+/,<MD5>);
    close(MD5);
    return $md5sum;
}

# print a list of files we're upgrading, to give them something to look at.
# Check MD5 checksums of .debs, while we're at it, if required.
sub printpkglist {
    my $p;
    print LOGF ("-"x75)."\nRun details:\n\n";
    for $p (sort(keys(%file))) {
	if ($oldver{$p} eq '') {
	    print "Will install package $p version $newver{$p} ";
	    print LOGF "Installing package $p version $newver{$p} from $file{$p}\n";
	} else {
	    print "Will upgrade $p from $oldver{$p} to $newver{$p} ";
	    print LOGF "Upgrading $p from $oldver{$p} to $newver{$p} from $file{$p}\n";
	}
	# check MD5 checksums
	if ($::checkmd5) {
	    my $md5sum;
	    STDOUT->flush();
	    if ($md5sum{$p} eq '' ||
		($md5sum=md5sum($file{$p})) eq '') {
		echo "(no MD5 checksum or error)";
		logprint("No MD5 checksum in packages file or cannot calculate checksum. Not checked.\n");
	    } elsif ($md5sum{$p} eq $md5sum) {
		echo "(MD5 checksum OK)";
		logprint("MD5 checksum $md5sum matches.\n");
	    } else {
		echo "BAD MD5 CHECKSUM.";
		logprint("Checksum $md5sum of file does not match\n   checksum $md5sum{$p} in Packages file.\n");
		errorinpackage($p,"bad MD5 checksum");
	    }
	} else {
	    print "\n";
	}
    }
}
printpkglist();

stopifdone();
    
# unpack the files, but don't configure them yet

sub unpackdebs {
# can we use join() here too? It doesn't look like it, but ...
    my $flist='';
    my $f;
    my %pkgfile;
    for $f (sort(keys(%file))) {
	if ($flist ne '') {
	    $flist.=' ';
	}
	$flist .= $file{$f};
	$pkgfile{$file{$f}}=$f;
    }

    logclose();

    my $dpkgargs="--admindir=$vardir --refuse-downgrade --skip-same-version --auto-deconfigure --unpack";
    $dpkgargs = "--refuse-overwrite ".$dpkgargs unless $::allowoverwrite;
    if (!syscmd("$bindir/logcmd -aq -f $::logfile -- dpkg $dpkgargs $flist")) {
	# parse the list of problematical files, and remove them from our list,
	# then carry on.
	logprint("dpkg exited with an error status.\n");
	my @errors=parselogerrs($::logfile);
	# remove the entries from the file hash
	for $f (@errors) {
	    errinnotinstalled () if (!defined($pkgfile{$f}));
	    delete $file{$pkgfile{$f}};
	    logprint("Error unpacking $pkgfile{$f} ($f)\n");
	    errorinpackage($pkgfile{$f},"dpkg error in unpacking");
	}
    }
}

boldecho "\nUnpacking requested files:";
logprint("\n".("-"x75)."\nUnpacking stage:\n\n");
unpackdebs();
stopifdone();

# only configure the files we just installed, rather than doing --pending --configure
sub configure {
    if (!syscmd("$bindir/logcmd -aq -f $::logfile -- dpkg --admindir=$vardir --configure " . join(" ", sort(keys(%file))))) {
	# we don't really need this information to operate with, but it's nice to
	# get the list at the end, so se gather it anyway.
	logprint("dpkg returned an error status.\n");
	my @errors=parselogerrs($::logfile);
	my $f;
	for $f (@errors) {
	    errinnotinstalled ()  if (!defined($file{$f}));
	    logprint("Error configuring $f version $newver{$f}\n");
	    errorinpackage($f,"dpkg error in configuring");
	}
	# and exit if there's nothing left to do
	if (!scalar(%file)) {
	    echo("\ndpkg errors in all packages, stopping.");
	    logprint("errors for all packages, stopped.\n");
	    tidyup();
	    exit 1;
	} else {
	    echo("dpkg errors with some packages, continuing anyway.");
	}
    }
}

boldecho("\nConfiguring requested files:");
logprint("\n".("-"x75)."\nConfiguration stage:\n\n");
configure();
stopifdone();

tidyup();

exit 1 if (@errorlist);		# even if stopifdone() didn't exit, we want to give an error code if there were any
				# problems

waitkey("\nDone.");

exit 0;
