use strict; use YAML qw[LoadFile DumpFile]; use Data::Dumper; use File::Basename; use Cwd; use Config; BEGIN { use lib qw[bin]; require '_inc.pl'; protoconf->import(); } @ARGV or die 'Need at least one package'; for my $pkg (@ARGV) { my $meta = $Metactrl .'/'. $pkg; die "$pkg not installed -- dir '$meta' does not exist\n" unless -d $meta; my @list = LoadFile( $Available ); my @uninstalled = grep { $_->{package} ne $pkg } @list; ### check if we're even allowed to delete this, due to depends { my $info = LoadFile( $meta .'/'. $Metafile ); my $delete_ok = 1; for my $entry ( @list ) { for my $depends ( list_dependencies( $entry ) ) { ### check if this entry depends on /any/ of the items ### we provide if( dependency_satisfied_by( $depends, $info ) ) { ### if the dependency is also sastisfied by /another/ ### package, it's still safe to delete us, otherwise not if( !dependency_satisfied( $depends, \@uninstalled ) ) { warn "\t*** $entry->{package} depends on $pkg ***\n"; $delete_ok = 0; } } } } die "Not allowed to delete '$pkg'\n" unless $delete_ok; } ### uninstall the files ### XXX check dependencies open my $fh, $meta .'/'. $Fileslist or die $!; my $prerm = $meta . '/' . $Prerm; if( -e $prerm && -s _ ) { system( qq[ $^X $prerm ] ) and die $?; } while( <$fh> ) { chomp; -e $_ && system(qq[rm -rf $_]) and die $?; die "File '$_' not removed" if -e $_; } close $fh; ### XXX need status dir like dpkg my $postrm = $meta . '/' . $Postrm; if( -e $postrm && -s _ ) { system( qq[ $^X $postrm ] ) and die $?; } ### remove alternatives and relink if needed ### XXX doesn't do manpages yet ### XXX doens't check the AUTO flag yet for link management LINKING: { ### load in the alternatives collection my $href = LoadFile( $Altfile ); ### this package didn't provide any alternatives last LINKING unless $href->{$pkg}; ### XXX this should probably be done in one go, so we don't ### have a situation where no 'script' is available ### unlink all the script files for my $script ( @{ $href->{$pkg}->{bin} || [] } ) { 1 while unlink "$Bindir/$script"; 1 while unlink "$Alternatives/$script"; } ### see if there's any other package that's now the default ### for this module ### make sure we dont see ourselves again, so grep that out my $new_alt; { my $wanted = join '-', package_prefix( $pkg ), package_name( $pkg ); ### find all packages that provide: a - ### implementation; my @list = LoadFile( $Available ); my @maybe; for my $test ( grep { $_->{package} ne $pkg } @list ) { push @maybe, $test if grep { $_ eq $wanted } @{ $test->{provides} || [] }; } ### find the alternative with the highest version ### XXX this should be policy based! ($new_alt) = sort { $b->{version} <=> $a->{version } } @maybe; } ### no alt? bail! last LINKING unless $new_alt; my $my_bindir = "$Site/$new_alt->{package}/bin"; my @bins; print "\nRelinking scripts/manpages to $new_alt->{package}...\n"; for ( qx[find $my_bindir -type f] ) { chomp; ### link from altdir to install dir ### then from pathdir, to altdir my $script = basename($_); system( qq[ln -fs $_ $Alternatives/$script] ) and die $?; system( qq[ln -fs $Alternatives/$script $Bindir/$script ] ) and die $?; push @bins, $script; } ### add this package as being authorative for these links ### $href->{ $pkg } = { bin => \@bins }; ### dump out alternatives again DumpFile( $Altfile, $href ); } ### remove this package from the available list ### XXX temp file, then mv DumpFile( $Available, @uninstalled ); ### unisntall metadata system(qq[rm -rf $meta]) and die $?; print "\n\tPackage '$pkg' and associated metadata removed\n"; }