#!/usr/bin/perl

# Copyright (C) 1999,2002 MandrakeSoft <pixel@linux-mandrake.com>
#                                      <fpons@mandrakesoft.com>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

#We only make good software ;-)
#use strict;

#use strict qw(subs vars refs);
use URPM;
use URPM::Resolve;
use urpm;

#- get I18N translation method.
import urpm _;

my ($auto, $matches, $maymatch, @l, @m, @toremove, %base);
my $askok = _("Is this OK?");
my $askrm = _("Remove them all?");
# Translator: Add here the keys which might be pressed in the "No"-case.
my $noexpr = _("Nn");
# Translator: Add here the keys which might be pressed in the "Yes"-case.
my $yesexpr = _("Yy");

local $_ = ' ' . join(' ', @ARGV) . ' ';

if ( / --?h/ || @ARGV == 0 ) {
    print STDERR _("usage: urpme [-a] [--auto] <packages...>\n");
    exit(0);
}

$matches = / -a /;
$auto = / --?auto /;

$urpm = new urpm;
$state = {};

#- open database to examine packages...
{
    my $db = URPM::DB::open('/', 0); #- open in read/write mode directly (so open it only once).

    @l = grep { !/^-/ } @ARGV;
    if (!$matches) {
	foreach (@l) {
	    my ($n, $found);

	    #- check if name-version-release may have been given.
	    if (($n) = /^(.*)-[^\-]*-[^\-]*\.[^\.\-]*$/) {
		$db->traverse_tag('name', [ $n ], sub {
				      my ($p) = @_;
				      $p->fullname eq $_ or return;
				      $urpm->resolve_closure_ask_remove($db, $state, $p);
				      push @m, join('-', ($p->fullname)[0..2]);
				      $found = 1;
				  });
		$found and next;
	    }

	    #- check if name-version-release may have been given.
	    if (($n) = /^(.*)-[^\-]*-[^\-]*$/) {
		$db->traverse_tag('name', [ $n ], sub {
				      my ($p) = @_;
				      join('-', ($p->fullname)[0..2]) eq $_ or return;
				      $urpm->resolve_closure_ask_remove($db, $state, $p);
				      push @m, join('-', ($p->fullname)[0..2]);
				      $found = 1;
				  });
		$found and next;
	    }

	    #- check if name-version may have been given.
	    if (($n) = /^(.*)-[^\-]*$/) {
		$db->traverse_tag('name', [ $n ], sub {
				      my ($p) = @_;
				      join('-', ($p->fullname)[0..1]) eq $_ or return;
				      $urpm->resolve_closure_ask_remove($db, $state, $p);
				      push @m, join('-', ($p->fullname)[0..2]);
				      $found = 1;
				  });
		$found and next;
	    }

	    #- check if only name may have been given.
	    $db->traverse_tag('name', [ $_ ], sub {
				  my ($p) = @_;
				  $p->name eq $_ or return;
				  $urpm->resolve_closure_ask_remove($db, $state, $p);
				  push @m, join('-', ($p->fullname)[0..2]);
				  $found = 1;
			      });
	    $found and next;

	    #- nothing has been found for the given name.
	    $maymatch .= ($maymatch && ", ") . $_;
	}
	if ($maymatch) {
	    my $msg = $maymatch =~ /, / ? _("unknown packages ") : _("unknown package ");
	    $msg =~ /\s$/ or $msg .= ' '; #- add trailing space to avoid fixing bad translator (too late now for 9.0).
	    $maymatch = "$msg$maymatch\n";
	}
	$maymatch && ($auto || @l > 1) and die $maymatch;
    }
    if ($matches || $maymatch) {
	my $match = join "|", map { quotemeta } @l;

	#- reset what has been already found.
	$state = {};
	@m = ();

	#- search for package that matches, and perform closure again.
	$db->traverse(sub {
			  my ($p) = @_;
			  $p->fullname =~ /$match/ or return;
			  $urpm->resolve_closure_ask_remove($db, $state, $p);
			  push @m, join('-', ($p->fullname)[0..2]);
		      });

	if ($maymatch) {
	    @m or die $maymatch;
	    my $msg = _("Using \"%s\" as a substring, I found", $match);
	    print STDOUT "$msg:\n@m\n$askrm" . _(" (y/N) ");
	    <STDIN> =~ /[$yesexpr]/ or exit 1;
	}
    }

    #- if nothing need to be removed.
    unless (%{$state->{ask_remove} || {}}) {
	print _("Nothing to remove.\n");
	exit(0);
    }

    my @base = qw(basesystem);
    my %basepackages;

    #- check if a package to be removed is a part of basesystem requires.
    while (defined($_ = shift @base)) {
	exists $basepackages{$_} and next;
	$db->traverse_tag(/^\// ? 'path' : 'whatprovides', [ $_ ], sub {
			      my ($p) = @_;
			      push @{$basepackages{$_} ||= []}, join '-', ($p->fullname)[0..2];
			      push @base, $p->requires_nosense;
			  });
    }

    foreach (values %basepackages) {
	my $n = @$_;
	foreach (@$_) {
	    $base{$_} = \$n;
	}
    }
}

my $base_str = '';
my @toremove = keys %{$state->{ask_remove}};
foreach (@toremove) {
    my $rn = $base{$_};
    if ($rn) {
	$$rn == 1 and $base_str .= _("removing package %s will break your system\n", $_);
	--$$rn;
    }
}
$base_str and die $base_str;

if (@toremove > @l && !$auto) {
    my $sum = 0;
    foreach (@toremove) {
	$sum += $state->{ask_remove}{$_}{size};
    }
    my $msg = _("To satisfy dependencies, the following packages are going to be removed (%d MB)", toMb($sum));
    print STDOUT "$msg:\n@toremove\n$askok" . _(" (Y/n) ");
    <STDIN> =~ /[$noexpr]/ and exit 0;
}

$urpm->install(\@toremove, {}, {});

sub toMb {
    my $nb = $_[0] / 1024 / 1024;
    int $nb + 0.5;
}