#!/usr/bin/perl
#
# Copyright (c) 2003 Stefan Walter <sw@gegenunendlich.de>
#
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
#
# THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.
#
# $FreeBSD: ports/sysutils/pkg_cutleaves/src/pkg_cutleaves,v 1.5 2004/02/08 22:25:19 pav Exp $

# Interactive script for deinstalling "leaf" packages;
# requires the portupgrade tools
#
# Syntax: pkg_cutleaves [-c] [-F] [-l] [-R] [-x]
# Options:
#   -c: Show comments, too; only works with '-l' (ignored otherwise)
#   -F: Fix package db after each deinstallation run (via 'pkgdb -F')
#   -l: List leaf packages only, don't ask if they should be deinstalled
#   -R: Run 'pkg_deinstall -R' instead of plain 'pkg_deinstall'
#   -x: Honor exclude list in $excludefile

use strict;

my $dbdir = "/var/db/pkg";
my $excludefile = "/usr/local/etc/pkg_leaves.exclude";
my $pkgdeinstall = "/usr/local/sbin/pkg_deinstall";
my @pkgdb_args = ("/usr/local/sbin/pkgdb", "-F");
my ($opt_comments, $opt_listonly, $opt_excludelist, $opt_recursive, $opt_pkgdb);
my $exclpattern;

#
# Read the exclude list if the file exists
# Parameter: path of the exclude file
#
sub get_excl_pattern {
	my $excl_file = shift;
	my $excl_pattern;
	# Does the exclude file exist?
	if (($excl_file) && (-f $excl_file) && (-T $excl_file)) {
		# Read the patterns to be excluded
		my @excludes;
		open(EXCLFILE, $excl_file)
			or die "Couldn't open $excl_file!";
		while(my $exclude = <EXCLFILE>) {
			chomp($exclude);
			# Ignore comments and empty lines, add others as regular expressions
			unless (($exclude =~ m/(^ *#)|(^ *$)/)) {
				$exclude = "^" . $exclude . ".*";
				push @excludes, $exclude;
			}
		}
		close(EXCLFILE);
		# Provide a dummy exclusion pattern if @excludes is empty
		$excl_pattern = scalar(@excludes) ? join("|", @excludes) : " ";
	} else {
		# Dummy exclusion pattern -> doesn't exclude anything
		$excl_pattern = " ";
	}
	return $excl_pattern;
}

#
# Get a hash (name => comment) of all leaves
# Parameters: - path to package database
#             - pattern of packages to exclude
#
sub get_leaves {
	my $db_dir = shift;
	my $excl_pattern = shift;
	my %leaves;
	opendir(DBDIR, $db_dir)
		or die "Can't open package db directory $db_dir!";
	while(defined(my $file = readdir(DBDIR))) {
		my $path = $db_dir . '/' . $file;
		my $reqlist = $path . '/+REQUIRED_BY';
		my $commentfile = $path . '/+COMMENT';
		# Exclude non-directories, "." and ".."
		if (($file ne ".") && ($file ne "..") && (-d $path) && (!-s $reqlist)) {
			# Exclude packages matching exclude pattern, if requested
			unless ($file =~ m/$excl_pattern/) {
				# Read package's short description/comment
				my $comment;
				if ((-s $commentfile) && (open(COMMENT, $commentfile))) {
					$comment = <COMMENT>;
					chomp($comment);
					close(COMMENT);
				} else {
					$comment = "No short description";
				}
				$leaves{$file} = $comment;
			}
		}
	}
	closedir(DBDIR);
	return %leaves;
}

# Examine command line arguments
while(@ARGV) {
	my $arg = shift(@ARGV);
	if ($arg eq "-c") {
		$opt_comments = 1;
	}
	elsif ($arg eq "-F") {
		$opt_pkgdb = 1;
	}
	elsif ($arg eq "-l") {
		$opt_listonly = 1;
	}
	elsif ($arg eq "-R") {
		$opt_recursive = 1;
	}
	elsif ($arg eq "-x") {
		$opt_excludelist = 1;
	} else {
		warn "Unrecognized command line argument $arg ignored.\n";
	}
}

# Exclusion requested?
if ($opt_excludelist) {
	# Get exclusion pattern
	$exclpattern = get_excl_pattern($excludefile);
} else {
	# Spaces don't appear in package names -> this doesn't exclude anything
	$exclpattern = " ";
}

if ($opt_listonly) {
	# Just print out the list of leaves, one per line
	my %leaves = get_leaves($dbdir, $exclpattern);
	foreach my $leaf (sort keys %leaves) {
		if ($opt_comments) {
			print "$leaf - $leaves{$leaf}\n";
		} else {
			print "$leaf\n";
		}
	}
} else {
	my %leavestokeep;
	my %leavestocut;
	my @cutleaves;
	my ($nleaves, $i);
	# Loop while the user wants to
	my $again = "y";
	ROUND: while($again eq "y") {
		# Get list of leaf packages and put them into a hash
		my %leaves = get_leaves($dbdir, $exclpattern);
		# Ignore all leaves the user already told us to keep
		foreach my $leaf (keys %leavestokeep) {
			if ($leaves{$leaf}) {
				delete $leaves{$leaf};
			}
		}
		# Any leaves left?
		$nleaves = keys %leaves;
		if ($nleaves == 0) {
			# If not, don't go on, there's nothing left to do.
			print "Didn't find any new leaves, exiting.\n";
			last ROUND;
		}
		# Always start with an empty list of leaves to cut
		%leavestocut = ();
		# Initialize counter for progress status
		$i = 1;

		LEAVESLOOP: foreach my $leaf (sort keys %leaves) {
			print "Package $i of $nleaves:\n";
			print "$leaf - $leaves{$leaf}\n";
			print "$leaf - [keep]/(d)elete/(f)lush marked pkgs/(a)bort? ";
			# Get first character of input, without leading whitespace
			my ($answer) = (lc(<STDIN>) =~ m/(\S)/);
			if ($answer eq "d") {
				print "** Marking $leaf for removal.\n\n";
				$leavestocut{$leaf} = 1;
			}
			elsif ($answer eq "f") {
				print "\n";
				last LEAVESLOOP;
			}
			elsif ($answer eq "a") {
				print "\n";
				last ROUND;
			}
			else {
				print "** Keeping $leaf.\n\n";
				$leavestokeep{$leaf} = 1;
			}
			$i++;
		} # LEAVESLOOP

		# Initialize 'progress meter'
		my $ncuts = keys %leavestocut;
		my $noff = 0;
		# loop through packages marked for removal and pkg_deinstall them
		foreach my $leaf (sort keys %leavestocut) {
			$noff++;
			print "Deleting $leaf (package $noff of $ncuts).\n";
			my @deinstall_args;
			if ($opt_recursive) {
				@deinstall_args = ($pkgdeinstall, '-R', $leaf);
			} else {
				@deinstall_args = ($pkgdeinstall, $leaf);
			}
			if ((my $status = system(@deinstall_args) >> 8) != 0) {
				print STDERR "\n\n$0: pkg_deinstall returned $status - exiting, fix this first.\n\n";
				last ROUND;
			}
			push @cutleaves, $leaf;
		}

		# Run 'pkgdb -F' if requested
		if ($opt_pkgdb) {
			print "Running 'pkgdb -F'.\n";
			if ((my $status = system(@pkgdb_args) >> 8) != 0) {
				print STDERR "\n\n$0: pkgdb returned $status - exiting, fix this first.\n\n";
				last ROUND;
			}
		}

		print "Go on with new leaf packages ((y)es/[no])? ";
		# Get first character of input, without leading whitespace
		($again) = (lc(<STDIN>) =~ m/(\S)/);
		print "\n";
	} # ROUND

	# print list of removed packages, sorted lexically, and their number
	print "** Deinstalled packages:\n";
	foreach my $cutleaf (sort @cutleaves) {
		print "$cutleaf\n";
	}
	my $noff = @cutleaves;
	print "** Number of deinstalled packages: $noff\n";
}

