path: root/usr.sbin/pkg_add/pkg_delete

#!/usr/bin/perl
# ex:ts=8 sw=4:
# $OpenBSD: pkg_delete,v 1.40 2004/08/10 12:05:52 espie Exp $
#
# Copyright (c) 2003-2004 Marc Espie <espie@openbsd.org>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

use strict;
use warnings;
use Getopt::Std;
use OpenBSD::PackingList;
use OpenBSD::PackingOld;
use OpenBSD::PackageInfo;
use OpenBSD::RequiredBy;
use OpenBSD::Logger;
use OpenBSD::Vstat;
use OpenBSD::PackageInfo;

our %forced = ();


sub ensure_ldconfig
{
	my $verbose = shift;
	return unless defined $OpenBSD::PackingElement::Lib::todo;
	print "running ldconfig -R\n" if $verbose;
	system(@OpenBSD::PackingElement::Lib::ldconfig, "-R");
	undef $OpenBSD::PackingElement::Lib::todo;
}

sub erase_alldirrms
{
	my $db = {};
	my @list = installed_packages();
	for my $e (@list) {
		my $plist = OpenBSD::PackingList->fromfile(installed_info($e).CONTENTS, \&OpenBSD::PackingList::DirrmOnly) or next;
		for my $item (@{$plist->{items}}) {
			$item->erase_dir($e, $db);
		}
	}
	return $db;
}

sub remove_dirs
{
	my $state = shift;

	my $h = $state->{dirs_to_rm};
	return unless defined $h;

	my $remaining = erase_alldirrms();

	for my $d (sort {$b cmp $a} keys %$h) {
		my $realname = $state->{destdir}.$d;
		if ($remaining->{$realname}) {
			for my $i (@{$h->{$d}}) {
				$i->reload($state);
			}
		} else {
			for my $i (@{$h->{$d}}) {
				$i->cleanup($state);
			}
			if (!rmdir $realname) {
				    print "Error deleting directory $realname: $!\n";
			}
		}
	}
}


package OpenBSD::PackingElement;
sub delete
{
}

sub erase_dir
{
}

sub cleanup
{
}

sub reload
{
}

sub log_pkgname
{
	my ($self, $state) = @_;
	if (defined $state->{pkgname_tolog}) {
		OpenBSD::Logger::log
		    "# package ", $state->{pkgname_tolog}, "\n";
	$state->{pkgname_tolog} = undef;
	}
}


package OpenBSD::PackingElement::DirBase;
sub erase_dir
{
	my ($self, $pkgname, $db) = @_;
	my $k = $self->fullname();
	$db->{$k} = 1;
}

sub delete
{
	my ($self, $state) = @_;

	my $name = $self->fullname();

	if ($state->{verbose} or $state->{not}) {
		print "dirrm: $name\n";
	}

	$state->{dirs_to_rm} = {} unless defined $state->{dirs_to_rm};

	my $h = $state->{dirs_to_rm};
	$h->{$name} = [] unless defined $h->{$name};
	push(@{$h->{$name}}, $self->clone());
}

package OpenBSD::PackingElement::DirRm;
sub erase_dir
{
	&OpenBSD::PackingElement::DirBase::erase_dir;
}

sub delete
{
	&OpenBSD::PackingElement::DirBase::delete;
}

package OpenBSD::PackingElement::Unexec;
sub delete
{
	my ($self, $state) = @_;
	my $cmd = $self->{expanded};
	main::ensure_ldconfig($state->{verbose}) unless $state->{not};
	if ($state->{verbose} or $state->{not}) {
		print "unexec: $cmd\n";
	}
	return if $state->{not};
	system('/bin/sh', '-c', $cmd);
}

package OpenBSD::PackingElement::FileBase;
use OpenBSD::md5;
sub delete
{
	my ($self, $state) = @_;
	my $name = $self->fullname();
	my $realname = $state->{destdir}.$name;
	if (-l $realname) {
		if ($state->{verbose} or $state->{not}) {
			print "deleting symlink: $realname\n";
		}
	} else {
		if (! -f $realname) {
			print "File $realname does not exist\n";
			return;
		}
		unless (defined($self->{link}) or $self->{nochecksum} or $state->{quick}) {
			if (!defined $self->{md5}) {
				print "Problem: $name does not have an md5 checksum\n";
				print "NOT deleting: $realname\n";
				$self->log_pkgname($state);
				OpenBSD::Logger::log "rm $state->{destdirname}$name\n";
				return;
			}
			my $md5 = OpenBSD::md5::fromfile($realname);
			if ($md5 ne $self->{md5}) {
				print "Problem: md5 doesn't match for $name\n";
				print "NOT deleting: $realname\n";
				$self->log_pkgname($state);
				OpenBSD::Logger::log "rm $state->{destdirname}$name #MD5\n";
				return;
			}
		}
		if ($state->{verbose} or $state->{not}) {
			print "deleting: $realname\n";
		}
	}
	return if $state->{not};
	if (!unlink $realname) {
		print "Problem deleting $realname\n";
		$self->log_pkgname($state);
		OpenBSD::Logger::log "rm $state->{destdirname}$name\n";
	}
}

package OpenBSD::PackingElement::Sample;
use OpenBSD::md5;
sub delete
{
	my ($self, $state) = @_;
	my $name = $self->{name};
	my $realname = $state->{destdir}.$name;

	my $orig = $self->{copyfrom};
	if (!defined $orig) {
		die "\@sample element does not reference a valid file\n";
	}
	my $origname = $state->{destdir}.$orig->fullname();
	if (! -e $realname) {
		print "Config file $realname does not exist\n";
		return;
	}
	if (! -f $realname) {
		print "Config file $realname is not a file\n";
		return;
	}
	if (!defined $orig->{md5}) {
		print "Problem: config file $name does not have an md5 checksum\n";
		print "NOT deleting: $realname\n";
		$self->log_pkgname($state);
		OpenBSD::Logger::log "rm $state->{destdirname}$name\n";
		return;
	}

	if ($state->{quick}) {
		unless ($state->{extra}) {
			print "NOT'deleting config file $realname\n";
			return;
		}
	} else {
		my $md5 = OpenBSD::md5::fromfile($realname);
		if ($md5 eq $orig->{md5}) {
			print "Config file $realname identical to sample\n";
		} else {
			print "Config file $realname NOT identical to sample\n";
			unless ($state->{extra}) {
				print "NOT deleting $realname\n";
				return;
			}
		}
	}
	return if $state->{not};
	print "deleting $realname\n";
	if (!unlink $realname) {
		print "Problem deleting $realname\n";
		$self->log_pkgname($state);
		OpenBSD::Logger::log "rm $state->{destdirname}$name\n";
	}
}
		

package OpenBSD::PackingElement::InfoFile;
use File::Basename;
sub delete
{
	my ($self, $state) = @_;
	unless ($state->{not}) {
	    my $fullname = $state->{destdir}.$self->fullname();
	    system("install-info", "--delete", "--info-dir=".dirname($fullname), $fullname);
	}
	$self->SUPER::delete($state);
}

package OpenBSD::PackingElement::Extra;
sub delete
{
	my ($self, $state) = @_;
	return unless $state->{extra};
	my $name = $self->fullname();
	my $realname = $state->{destdir}.$name;
	if ($state->{verbose} or $state->{not}) {
		print "deleting extra file: $realname\n";
	}
	return if $state->{not};
	return unless -e $realname;
	unlink($realname) or 
	    print "problem deleting extra file $realname\n";
}

package OpenBSD::PackingElement::Extradir;
sub delete
{
	my ($self, $state) = @_;
	return unless $state->{extra};
	return unless -e $state->{destdir}.$self->fullname();
	$self->SUPER::delete($state);
}

package OpenBSD::PackingElement::Mandir;
sub cleanup
{
	my ($self, $state) = @_;
	my $fullname = $state->{destdir}.$self->fullname();
	print "You may wish to remove ", $fullname, " from man.conf\n";
	unlink("$fullname/whatis.db");
}

package OpenBSD::PackingElement::Fontdir;
sub cleanup
{
	my ($self, $state) = @_;
	my $fullname = $state->{destdir}.$self->fullname();
	print "You may wish to remove ", $fullname, " from your font path\n";
	unlink("$fullname/fonts.alias");
	unlink("$fullname/fonts.dir");
	unlink("$fullname/fonts.cache-1");
}

package OpenBSD::PackingElement::ExtraUnexec;
sub delete
{
	my ($self, $state) = @_;
	return unless $state->{extra};

	my $cmd = $self->{expanded};
	main::ensure_ldconfig($state->{verbose}) unless $state->{not};
	if ($state->{verbose} or $state->{not}) {
		print "unexec: $cmd\n";
	}
	return if $state->{not};
	system($cmd);
}

package OpenBSD::PackingElement::Lib;

sub delete
{
	my ($self, $state) = @_;
	$self->SUPER::delete($state);
	$self->mark_ldconfig_directory($state->{destdir});
}

package OpenBSD::PackingElement::FREQUIRE;
use OpenBSD::PackageInfo;
sub delete
{
	my ($self, $state) = @_;

	my $dir = $state->{dir};
	my $opt_v = $state->{verbose};
	my $opt_n = $state->{not};
	my $pkgname = $state->{pkgname};

	main::ensure_ldconfig($opt_v) unless $opt_n;
	print "Require script: $dir",REQUIRE," $pkgname DEINSTALL\n" if $opt_v or $opt_n;
	unless ($opt_n) {
		chmod 0755, $dir.REQUIRE;
		system($dir.REQUIRE, $pkgname, "DEINSTALL") == 0 or 
		    die "Require script borked";
	}
}

package OpenBSD::PackingElement::FDEINSTALL;
use OpenBSD::PackageInfo;
sub delete
{
	my ($self, $state) = @_;

	my $dir = $state->{dir};
	my $opt_v = $state->{verbose};
	my $opt_n = $state->{not};
	my $pkgname = $state->{pkgname};
	main::ensure_ldconfig($opt_v) unless $opt_n;
	print "Deinstall script: $dir",DEINSTALL ," $pkgname DEINSTALL\n" if $opt_v or $opt_n;
	unless ($opt_n) {
		chmod 0755, $dir.DEINSTALL;
		system($dir.DEINSTALL, $pkgname, "DEINSTALL") == 0 or 
		    die "deinstall script borked";
	}
}

package main;

our ($opt_v, $opt_D, $opt_d, $opt_n, $opt_f, $opt_q, $opt_p, $opt_c, $opt_L, $opt_B);

sub remove_packing_info
{
	my $dir = shift;

	for my $fname (info_names()) {
		unlink($dir.$fname);
	}
	rmdir($dir) or die "Can't finish removing directory $dir: $!";
}

sub manpages_unindex
{
	my ($plist, $destdir) = @_;
	return unless defined $plist->{state}->{mandirs};
	require OpenBSD::Makewhatis;

	while (my ($k, $v) = each %{$plist->{state}->{mandirs}}) {
		my @l = map { $destdir.$_ } @$v;
		eval { OpenBSD::Makewhatis::remove($destdir.$k, \@l); };
		if ($@) {
			print STDERR "Error in makewhatis: $@\n";
		}
	}
}

sub delete_package
{
	my ($pkgname, $state) = @_;
	$state->{pkgname} = $pkgname;
	my $dir = installed_info($pkgname);
	$state->{dir} = $dir;
	my $plist = OpenBSD::PackingList->fromfile($dir.CONTENTS) or 
	    die "Bad package";
	if (!defined $plist->pkgname()) {
		die "Package $pkgname has no name";
	}
	if ($plist->pkgname() ne $pkgname) {
		die "Package $pkgname real name does not match";
	}

	my $problems = 0;
	for my $item (@{$plist->{items}}) {
		next unless $item->IsFile();
		my $fname = $item->fullname();
		my $s = OpenBSD::Vstat::remove($fname, $item->{size});
		next unless defined $s;
		if ($s->{ro}) {
			print "Error: ", $s->{mnt}, " is read-only ($fname)\n";
			$problems++;
		}
	}
	die if $problems;

	$ENV{'PKG_PREFIX'} = $plist->pkgbase();
	if ($plist->has(REQUIRE)) {
		$plist->get(REQUIRE)->delete($state);
	}
	if ($plist->has(DEINSTALL)) {
		$plist->get(DEINSTALL)->delete($state);
	} 
	manpages_unindex($plist, $state->{destdir});
	for my $item (@{$plist->{items}}) {
		$item->delete($state);
	}
	# guard against duplicate pkgdep
	my $removed = {};
	for my $item (@{$plist->{pkgdep}}) {
		my $name = $item->{name};
		next if defined $removed->{$name};
		print "remove dependency in $name\n" if $opt_v or $opt_n;
		local $@;
		eval { OpenBSD::RequiredBy->new($name)->delete($pkgname) unless $opt_n; };
		if ($@) {
			print STDERR "$@\n";
		}
		$removed->{$name} = 1;
	}
	remove_packing_info($dir) unless $opt_n;
}

getopts('vcDdnf:qpS:L:B:');
$opt_B = $ENV{'PKG_DESTDIR'} unless defined $opt_B;
$opt_B = '' unless defined $opt_B;
if ($opt_B ne '') {
	$opt_B.='/' unless $opt_B =~ m/\/$/;
}
$ENV{'PKG_DESTDIR'} = $opt_B;

$opt_L = '/usr/local' unless defined $opt_L;

if (defined $opt_p) {
	die "Option p is obsolete";
}
if (defined $opt_d) {
	die "Option d is obsolete";
}

if ($opt_f) {
	%forced = map {($_, 1)} split(/,/, $opt_f);
}

if ($< && !$forced{nonroot}) {
	die "$0 must be run as root";
}

my %done;
my $removed;

my $state = {};
$state->{not} = $opt_n;
$state->{quick} = $opt_q;
$state->{verbose} = $opt_v;
$state->{extra} = $opt_c;
$ENV{'PKG_DELETE_EXTRA'} = $state->{extra} ? "Yes" : "No";

# First, resolve pkg names

my @realnames;
my $bad;

for my $pkgname (@ARGV) {
    $pkgname =~ s/\.tgz$//;
    if (is_installed($pkgname)) {
	push(@realnames, installed_name($pkgname));
    } else {
	if (OpenBSD::PackageName::is_stem($pkgname)) {
	    my @l = OpenBSD::PackageName::findstem($pkgname, 
		installed_packages());
	    if (@l == 0) {
		print "Can't resolve $pkgname to an installed package name\n";
		$bad = 1 unless $forced{uninstalled};
	    } elsif (@l == 1) {
		push(@realnames, $l[0]);
	    } elsif (@l != 0) {
		print "Ambiguous: $pkgname could be ", join(' ', @l),"\n";
		if ($forced{ambiguous}) {
		    print "(removing them all)\n";
		    push(@realnames, @l);
		} else {
		    $bad = 1;
		}
	    }
	}
    }
}

# Then check that dependencies are okay
my (%toremove, %extra_rm);
my @todo;
for my $pkgname (@realnames) {
	$toremove{$pkgname} = 1;
}

push(@todo, @realnames);

OpenBSD::Logger::log_as("pkg_delete");

while (my $pkgname = pop @todo) {
	my $deps = OpenBSD::RequiredBy->new($pkgname)->list();
	if (@$deps > 0) {
		for my $dep (@$deps) {
			next if defined $toremove{$dep};
			next if defined $extra_rm{$dep};
			$extra_rm{$dep}=$pkgname;
			push(@todo, $dep);
		}
	}
}

if (keys(%extra_rm) != 0) {
	print "Can't remove ", join(' ', @ARGV), " without also removing:\n",
	    join(' ', keys(%extra_rm)), "\n";
	if ($forced{dependencies}) {
		print "(removing them as well)\n";
		push(@realnames, keys(%extra_rm));
	} else {
		$bad = 1;
	}
}

if ($bad) {
	exit(1);
}

$state->{destdir} = $opt_B;
if ($opt_B eq '') {
    $state->{destdirname} = '';
} else {
    OpenBSD::Logger::annotate("PKG_DESTDIR=\"$opt_B\"; export PKG_DESTDIR\n");
    $state->{destdirname} = '${PKG_DESTDIR}';
}

# and finally, handle the removal
{ do {
	$removed = 0;
	for my $pkgname (@realnames) {
		next if $done{$pkgname};
		unless (is_installed($pkgname)) {
			print "$pkgname was not installed\n";
			$done{$pkgname} = 1;
			$removed++;
			next;
		}
		my $deps = OpenBSD::RequiredBy->new($pkgname)->list();
		next if @$deps > 0;
		print $opt_n ? "Pretending to delete " : "Deleting ", 
		    "$pkgname\n";
		$state->{pkgname_tolog} = $pkgname;
		delete_package($pkgname, $state);
		delete_installed($pkgname);
		$done{$pkgname} = 1;
		$removed++;
	}
	# we're not actually doing anything, so we can't expect this loop 
	# to ever finish
	last if $opt_n;
} while ($removed); }

ensure_ldconfig($opt_v) unless $opt_n;
# delayed directory removal
remove_dirs($state);
OpenBSD::PackingElement::Fontdir::finish_fontdirs();

my $logname = OpenBSD::Logger::logname();
if (defined $logname) {
	print "Problems logged as $logname\n";
}