package urpm::select;

# $Id: select.pm 258637 2009-07-28 13:14:16Z cfergeau $

use strict;
use urpm::msg;
use urpm::util;
use urpm::sys;
use URPM;

my $default_priority_list = 'rpm,perl-URPM,perl-MDV-Distribconf,urpmi,meta-task,glibc,aria2';
my @priority_list = split(',', $default_priority_list);

my $evr_re = qr/[^\-]*-[^\-]*\.[^\.\-]*$/;


=head1 NAME

urpm::select - package selection routines for urpmi

=head1 SYNOPSIS

=head1 DESCRIPTION

=over

=cut


sub add_packages_to_priority_upgrade_list {
    @priority_list = uniq(@priority_list, @_);
}

sub set_priority_upgrade_option {
    my ($urpm, $previous) = @_;

    exists $urpm->{options}{'priority-upgrade'} and return;

    # comma-separated list of packages that should be installed first,
    # and that trigger an urpmi restart
    my $list = join(',', @priority_list);
    if ($previous) {
	if ($previous eq $list) {
	    $list = '';
	    $urpm->{log}(N("urpmi was restarted, and the list of priority packages did not change"));
	} else {
	    $urpm->{log}(N("urpmi was restarted, and the list of priority packages did change: %s vs %s", $previous, $list));
	}
    }
    $urpm->{options}{'priority-upgrade'} = $list;
}

sub _findindeps {
    my ($urpm, $found, $qv, $v, $caseinsensitive, $src) = @_;

    foreach (keys %{$urpm->{provides}}) {
	#- search through provides to find if a provide matches this one;
	#- but manage choices correctly (as a provides may be virtual or
	#- defined several times).
	/$qv/ || !$caseinsensitive && /$qv/i or next;

	my @list = grep { defined $_ } map {
	    my $pkg = $_;
	    $pkg && ($src ? $pkg->arch eq 'src' : $pkg->arch ne 'src')
	      ? $pkg->id : undef;
	} $urpm->packages_providing($_);
	@list > 0 and push @{$found->{$v}}, join '|', @list;
    }
}

sub pkg_in_searchmedia {
    my ($urpm, $pkg) = @_;

    foreach my $medium (grep { $_->{searchmedia} } @{$urpm->{media}}) {
	$medium->{start} <= $pkg->id
	  && $medium->{end} >= $pkg->id and return 1;
    }
    0;
}
sub searchmedia_idlist {
    my ($urpm) = @_;
    $urpm->{searchmedia} && [ 
	map { $_->{start} .. $_->{end} } 
	  grep { $_->{searchmedia} } @{$urpm->{media}}
    ];
}
sub build_listid_ {
    my ($urpm) = @_;
    $urpm->build_listid(undef, undef, searchmedia_idlist($urpm));
}

#- search packages registered by their names by storing their ids into the $packages hash.
#- Recognized options:
#-	all
#-	caseinsensitive
#-	fuzzy
#-      no_substring
#-	src
#-	use_provides
#-
#- side-effects: $packages, flag_skip
sub search_packages {
    my ($urpm, $packages, $names, %options) = @_;

    my ($name2ids, $result) = _search_packages($urpm, $names, %options) or return;

    foreach my $v (@$names) {
	my @ids = split /\|/, $name2ids->{$v};

	#- in case we have a substring match, we want individual selection (for urpmq --fuzzy)
	$packages->{$_} = 1 foreach $result eq 'substring' || $options{all} ? @ids : $name2ids->{$v};

	foreach (@ids) {
	    my $pkg = $urpm->{depslist}[$_] or next;
	    $urpm->{debug} and $urpm->{debug}("search_packages: found " . $pkg->fullname . " matching $v");
	    $pkg->set_flag_skip(0); #- reset skip flag as manually selected.
	}
    }
    $result;
}

#- side-effects: none
sub _search_packages {
    my ($urpm, $names, %options) = @_;
    my (%exact, %exact_a, %exact_ra, %found, %foundi);
    foreach my $v (@$names) {
	my $qv = quotemeta $v;
	my @found;
	$qv = '(?i)' . $qv if $options{caseinsensitive};

	if (!$options{fuzzy}) {
	    #- try to search through provides.
	    if (my @l = map {
		    $_
		    && ($options{src} ? $_->arch eq 'src' : $_->is_arch_compat)
		    && ($options{use_provides} || $_->name eq $v)
		    && defined($_->id)
		    && (!$urpm->{searchmedia} || pkg_in_searchmedia($urpm, $_))
		    ? $_ : @{[]};
		} $urpm->packages_providing($v))
	    {
		$exact{$v} = _search_packages_keep_best($v, \@l, $options{all});
		next;
	    }
	} elsif ($options{use_provides}) {
	    _findindeps($urpm, \%found, $qv, $v, $options{caseinsensitive}, $options{src});
	}

	foreach my $id (build_listid_($urpm)) {
	    my $pkg = $urpm->{depslist}[$id];
	    ($options{src} ? $pkg->arch eq 'src' : $pkg->is_arch_compat) or next;
	    my $pack_name = $pkg->name;
	    my $pack_ra = $pack_name . '-' . $pkg->version;
	    my $pack_a = "$pack_ra-" . $pkg->release;
	    my $pack = "$pack_a." . $pkg->arch;
	    if (!$options{fuzzy}) {
		if ($pack eq $v) {
		    $exact{$v} = $id;
		    next;
		} elsif ($pack_a eq $v) {
		    push @{$exact_a{$v}}, $id;
		    next;
		} elsif ($pack_ra eq $v || $options{src} && $pack_name eq $v) {
		    push @{$exact_ra{$v}}, $id;
		    next;
		}
	    }
	    if ($pack =~ /$qv/) {
		next if member($pack, @found);
		push @found, $pack;
		push @{$found{$v}}, $id;
	    }
	    next if !$options{caseinsensitive};
	    if ($pack =~ /$qv/i) {
		next if member($pack, @found);
		push @found, $pack;
		push @{$foundi{$v}}, $id;
	    }
	}
    }

    my $result = 1;
    my %name2ids;
    foreach my $v (@$names) {
	if (defined $exact{$v}) {  
	    $name2ids{$v} = $exact{$v};
	} else {
	    #- at this level, we need to search the best package given for a given name,
	    #- always prefer already found package.
	    my %l;
	    foreach (@{$exact_a{$v} || $exact_ra{$v} || $found{$v} || $foundi{$v} || []}) {
		my $pkg = $urpm->{depslist}[$_];
		push @{$l{$pkg->name}}, $pkg;
	    }
	    #- non-exact match?
	    my $is_substring_match = !@{$exact_a{$v} || $exact_ra{$v} || []};

	    if (values(%l) == 0
		  || !$options{all} && (values(%l) > 1 || $is_substring_match && $options{no_substring})) {
		$urpm->{error}(N("No package named %s", $v));
		values(%l) != 0 and $urpm->{error}(
		    N("The following packages contain %s: %s",
			$v, urpm::util::formatList(4, sort { $a cmp $b } keys %l)) . "\n" . 
		    N("You should use \"-a\" to use all of them")
		);
		$result = 0;
	    } else {
		$is_substring_match and $result = 'substring';

		$name2ids{$v} = join('|', map {
		    my $best;
		    foreach (@$_) {
			if ($best && $best != $_) {
			    $_->compare_pkg($best) > 0 and $best = $_;
			} else {
			    $best = $_;
			}
		    }
		    map { $_->id } grep { $_->fullname eq $best->fullname } @$_;
		} values %l);
	    }
	}
    }

    #- return 0 if error, 'substring' if fuzzy match, 1 if ok
    \%name2ids, $result;
}

#- side-effects: none
sub _search_packages_keep_best {
    my ($name, $pkgs, $all) = @_;

    #- find the lowest value of is_arch_compat
    my ($noarch, $arch) = partition { $_->arch eq 'noarch' } @$pkgs;
    my %compats;
    push @{$compats{$_->is_arch_compat}}, $_ foreach @$arch;
    
    delete $compats{0};		#- means not compatible
    #- if there are pkgs matching arch, prefer them
    if (%compats && !$all) {
	my $best_arch = min(keys %compats);
	%compats = ($best_arch => $compats{$best_arch});
    }
    my @l = %compats ? (@$noarch, map { @$_ } values %compats) : @$pkgs;

    #- we assume that if there is at least one package providing
    #- the resource exactly, this should be the best one; but we
    #- first check if one of the packages has the same name as searched.
    if (my @l2 = grep { $_->name eq $name } @l) {
	@l = @l2;
    }
    join('|', map { $_->id } @l);
}

#- Resolves dependencies between requested packages (and auto selection if any).
#- handles parallel option if any.
#- The return value is true if program should be restarted (in order to take
#- care of important packages being upgraded (priority upgrades)
#- %options :
#-	auto_select
#-	install_src
#-	priority_upgrade
#- %options passed to ->resolve_requested:
#-	callback_choices
#-	keep
#-	nodeps
#-	no_suggests
sub resolve_dependencies {
    #- $state->{selected} will contain the selection of packages to be
    #- installed or upgraded
    my ($urpm, $state, $requested, %options) = @_;
    my $need_restart;

    if ($urpm->{parallel_handler}) {
	require urpm::parallel; #- help perl_checker;
	urpm::parallel::resolve_dependencies($urpm, $state, $requested, %options);
    } else {
	my $db = urpm::db_open_or_die_($urpm);

	my $sig_handler = sub { undef $db; exit 3 };
	local $SIG{INT} = $sig_handler;
	local $SIG{QUIT} = $sig_handler;

	#- auto select package for upgrading the distribution.
	if ($options{auto_select}) {
	    $urpm->request_packages_to_upgrade($db, $state, $requested, requested => undef,
					       $urpm->{searchmedia} ? (idlist => searchmedia_idlist($urpm)) : (),
					   );
	}

	if ($options{priority_upgrade} && !$urpm->{env_rpmdb}) {
	    #- first check if a priority_upgrade package is requested
	    #- (it should catch all occurences in --auto-select mode)
	    #- (nb: a package "foo" may appear twice, and only one will be set flag_upgrade)
	    $need_restart = resolve_priority_upgrades_after_auto_select($urpm, $db, $state, $requested, %options);
	}

	if (!$need_restart) {
	    $urpm->resolve_requested($db, $state, $requested, %options);

	    #- now check if a priority_upgrade package has been required
	    #- by a requested package
	    if (my @l = grep { $state->{selected}{$_->id} } _priority_upgrade_pkgs($urpm, $options{priority_upgrade})) {
		$need_restart = _resolve_priority_upgrades($urpm, $db, $state, $state->{selected}, \@l, %options);
	    }
	}
    }
    $need_restart;
}

sub select_replacepkgs {
    my ($urpm, $state, $requested) = @_;

    my $db = urpm::db_open_or_die_($urpm);
    foreach my $id (keys %$requested) {
	my @pkgs = $urpm->find_candidate_packages_($id);
	if (my ($pkg) = grep { URPM::is_package_installed($db, $_) } @pkgs) {
		$urpm->{debug_URPM}("selecting replacepkg " . $pkg->fullname) if $urpm->{debug_URPM};
		$pkg->set_flag_requested;
		$state->{selected}{$pkg->id} = undef;
	} else {
	    $urpm->{fatal}(1, N("found package(s) %s in urpmi db, but none are installed", join(', ', map { scalar($_->fullname) } @pkgs)));
	}
    }
}

sub _priority_upgrade_pkgs {
    my ($urpm, $priority_upgrade_string) = @_;

    map {
	$urpm->packages_by_name($_);
    } split(/,/, $priority_upgrade_string);
}


sub resolve_priority_upgrades_after_auto_select {
    my ($urpm, $db, $state, $selected, %options) = @_;

    my $need_restart;

    if (my @l = grep { $_->flag_upgrade } _priority_upgrade_pkgs($urpm, $options{priority_upgrade})) {
	$need_restart = _resolve_priority_upgrades($urpm, $db, $state, $selected, \@l, %options);
    }
    $need_restart;
}

sub _resolve_priority_upgrades {
    my ($urpm, $db, $state, $selected, $priority_pkgs, %options) = @_;

    my ($need_restart, %priority_state);
 
    my %priority_requested = map { $_->id => undef } @$priority_pkgs;

    $urpm->resolve_requested($db, \%priority_state, \%priority_requested, %options);
    if (grep { ! exists $priority_state{selected}{$_} } keys %priority_requested) {
	#- some packages which were selected previously have not been selected, strange!
    } elsif (grep { ! exists $priority_state{selected}{$_} } keys %$selected) {
	#- there are other packages to install after this priority transaction.
	%$state = %priority_state;
	$need_restart = 1;
    }
    $need_restart;
}

sub cooked_prefer {
    my ($urpm, $cmdline_prefer) = @_;

    $urpm->{prefer_regexps} ||= [
	map {
	    m!^/(.*)/$! ? "($1)" : '^' . quotemeta($_) . '$';
	} map { @$_ }
	  urpm::sys::get_packages_list($urpm->{prefer_list}, $cmdline_prefer),
	  urpm::sys::get_packages_list($urpm->{prefer_vendor_list})
    ];
    @{$urpm->{prefer_regexps}};
}

sub get_preferred {
    my ($urpm, $choices, $cmdline_prefer) = @_;

    my @prefer;
    my @l = @$choices;
    foreach my $re (cooked_prefer($urpm, $cmdline_prefer)) {
	my ($prefer, $other) = partition { $_->name =~ $re } @l;
	push @prefer, @$prefer;
	@l = @$other;

	if (@$prefer) {
	    my $prefer_s = join(',', map { $_->name } @$prefer);
	    my $other_s     = join(',', map { $_->name } @l);
	    $urpm->{log}("preferring $prefer_s over $other_s");
	}
    }
    
    #- only keep the best prefered
    #- then put the other prefered packages first 
    my $best = shift @prefer; 
    $best ? [$best] : [], [@prefer, @l];
}

my $fullname2name_re = qr/^(.*)-[^\-]*-[^\-]*\.[^\.\-]*$/;

#- find packages to remove.
#- options:
#-	callback_base
#-	callback_fuzzy
#-	callback_notfound
#-	force
#-	matches
#-	test
sub find_packages_to_remove {
    my ($urpm, $state, $l, %options) = @_;

    if ($urpm->{parallel_handler}) {
	#- invoke parallel finder.
	$urpm->{parallel_handler}->parallel_find_remove($urpm, $state, $l, %options, find_packages_to_remove => 1);
    } else {
	my $db = urpm::db_open_or_die_($urpm);
	my (@m, @notfound);

	if (!$options{matches}) {
	    foreach (@$l) {
		my ($n, $found);

		$db->traverse_tag('nvra', [ $_ ], sub {
			my ($p) = @_;
			$urpm->resolve_rejected($db, $state, $p, removed => 1);
			push @m, scalar $p->fullname;
			$found = 1;
		    });
		$found and next;

		push @notfound, $_;
	    }
	    if (!$options{force} && @notfound && @$l > 1) {
		$options{callback_notfound} && $options{callback_notfound}->($urpm, @notfound)
		  or return ();
	    }
	}
	if ($options{matches} || @notfound) {
	    my $match = join "|", map { quotemeta } @$l;
	    my $qmatch = qr/$match/;

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

	    $urpm->{log}(qq(going through installed packages looking for "$match"...));
	    #- search for packages that match, and perform closure again.
	    $db->traverse(sub {
		    my ($p) = @_;
		    my $f = scalar $p->fullname;
		    $f =~ $qmatch or return;
		    $urpm->resolve_rejected($db, $state, $p, removed => 1);
		    push @m, $f;
		});
	    $urpm->{log}("...done, packages found [" . join(' ', @m) . "]");

	    if (!$options{force} && @notfound) {
		if (@m) {
		    $options{callback_fuzzy} && $options{callback_fuzzy}->($urpm, @$l > 1 ? $match : $l->[0], @m)
		      or return ();
		} else {
		    $options{callback_notfound} && $options{callback_notfound}->($urpm, @notfound)
		      or return ();
		}
	    }
	    if (!@m) {
		$options{callback_notfound} && $options{callback_notfound}->($urpm, @$l)
		  or return ();
	    }
	}

	#- check if something needs to be removed.
	find_removed_from_basesystem($urpm, $db, $state, $options{callback_base})
	    or return ();
    }
    removed_packages($urpm, $state);
}

sub find_removed_from_basesystem {
    my ($urpm, $db, $state, $callback_base) = @_;
    $callback_base or return 1;

    if (my @l = _prohibit_packages_that_would_be_removed($urpm, $db, $state)) {
	$callback_base->($urpm, @l);
    } else {
	1;
    }

}
sub _prohibit_packages_that_would_be_removed {
    my ($urpm, $db, $state) = @_;

    my @to_remove = removed_packages($urpm, $state) or return 1;

    my @dont_remove = ('basesystem', 'basesystem-minimal', 
		       split /,\s*/, $urpm->{global_config}{'prohibit-remove'});
    my (@base_fn, %base);
    $db->traverse_tag('whatprovides', \@dont_remove, sub {
	my ($p) = @_;
	$base{$p->name} = 1;
	push @base_fn, scalar $p->fullname;
    });

    grep {
	! grep { $base{$_} } rejected_unsatisfied($state, $_);
    } intersection(\@to_remove, \@base_fn);
}

#- misc functions to help finding ask_unselect and ask_remove elements with their reasons translated.
sub unselected_packages {
    my (undef, $state) = @_;
    grep { $state->{rejected}{$_}{backtrack} } keys %{$state->{rejected} || {}};
}

#- misc functions to help finding ask_unselect and ask_remove elements with their reasons translated.
sub already_installed {
    my ($state) = @_;
    uniq(map { scalar $_->fullname } values %{$state->{rejected_already_installed} || {}});
}

sub translate_already_installed {
    my ($state) = @_;

    my @l = already_installed($state) or return;

    @l == 1 ?
      N("Package %s is already installed", join(', ', @l)) :
      N("Packages %s are already installed", join(', ', @l));
}

sub translate_why_unselected {
    my ($urpm, $state, @fullnames) = @_;

    join("\n", map { translate_why_unselected_one($urpm, $state, $_) } sort @fullnames);
}

sub translate_why_unselected_one {
    my ($urpm, $state, $fullname) = @_;

    my $obj = $state->{rejected}{$fullname};
    my $rb = $obj->{backtrack};
    my @unsatisfied = @{$rb->{unsatisfied} || []};
    my @conflicts = @{$rb->{conflicts} || []};
    my $s = join ", ", (
	(map { N("due to conflicts with %s", $_) } @conflicts),
	(map { N("due to unsatisfied %s", $_) } uniq(map {
	    #- XXX in theory we shouldn't need this, dependencies (and not ids) should
	    #- already be present in @unsatisfied. But with biarch packages this is
	    #- not always the case.
	    /\D/ ? $_ : scalar($urpm->{depslist}[$_]->fullname);
	} @unsatisfied)),
	$rb->{promote} && !$rb->{keep} ? N("trying to promote %s", join(", ", @{$rb->{promote}})) : (),
	$rb->{keep} ? N("in order to keep %s", join(", ", @{$rb->{keep}})) : (),
    );
    $fullname . ($s ? " ($s)" : '');
}

sub selected_packages_providing {
    my ($urpm, $state, $name) = @_;
    map { $urpm->{depslist}[$_] } grep { $state->{selected}{$_} } keys %{$urpm->{provides}{$name} || {}};
}

sub was_pkg_name_installed {
    my ($rejected, $name) = @_;

    foreach (keys %$rejected) {
	/^\Q$name\E-$evr_re/ or next;
	$rejected->{$_}{obsoleted} and return 1;
    }
    0;
}

sub removed_packages {
    my (undef, $state) = @_;
    grep {
	$state->{rejected}{$_}{removed} && !$state->{rejected}{$_}{obsoleted};
    } keys %{$state->{rejected} || {}};
}
sub rejected_closure {
    my ($state, $fullname) = @_;
    $state->{rejected} && $state->{rejected}{$fullname} && $state->{rejected}{$fullname}{closure};
}
sub rejected_unsatisfied {
    my ($state, $fullname) = @_;
    my $closure = rejected_closure($state, $fullname) or return;
    map { $_ ? @$_ : () } map { $_->{unsatisfied} } values %$closure;
}

sub conflicting_packages_msg_ {
    my ($removed_packages_msgs) = @_;

    my $list = join("\n", @$removed_packages_msgs) or return;
    @$removed_packages_msgs == 1 ? 
        N("The following package has to be removed for others to be upgraded:\n%s", $list)
	: N("The following packages have to be removed for others to be upgraded:\n%s", $list);
}
sub conflicting_packages_msg {
    my ($urpm, $state) = @_;
    conflicting_packages_msg_([ removed_packages_msgs($urpm, $state) ]);
}

sub removed_packages_msgs {
    my ($urpm, $state) = @_;
    map { translate_why_removed_one($urpm, $state, $_) } sort(removed_packages($urpm, $state));
}

sub translate_why_removed {
    my ($urpm, $state, @fullnames) = @_;
    join("\n", map { translate_why_removed_one($urpm, $state, $_) } sort @fullnames);
}
sub translate_why_removed_one {
    my ($urpm, $state, $fullname) = @_;

    my $closure = rejected_closure($state, $fullname) or return $fullname;

    my ($from) = keys %$closure;
    my ($whyk) = keys %{$closure->{$from}};
    my $whyv = $closure->{$from}{$whyk};
    my $frompkg = $urpm->search($from, strict_fullname => 1);
    my $s = do {
	if ($whyk =~ /old_requested/) {
	    N("in order to install %s", $frompkg ? scalar $frompkg->fullname : $from);
	} elsif ($whyk =~ /unsatisfied/) {
	    join(",\n  ", map {
		if (/([^\[\s]*)(?:\[\*\])?(?:\[|\s+)([^\]]*)\]?$/ && $2 ne '*') {
		    N("due to unsatisfied %s", "$1 $2");
		} else {
		    N("due to missing %s", $_);
		}
	    } @$whyv);
	} elsif ($whyk =~ /conflicts/) {
	    N("due to conflicts with %s", $whyv);
	} else {
	    $whyk;
	}
    };
    #- now insert the reason if available.
    $fullname . ($s ? "\n ($s)" : '');
}

sub _libdb_version { $_[0] =~ /libdb-(\S+)\.so/ ? version->new("v$1") : () }
sub _rpm_version() { `rpm --version` =~ /version ([0-9.]+)$/ ? version->new("v$1") : () }

sub should_we_migrate_back_rpmdb_db_version {
    my ($urpm, $state) = @_;

    my ($pkg) = urpm::select::selected_packages_providing($urpm, $state, 'rpm') or return;
    urpm::select::was_pkg_name_installed($state->{rejected}, 'rpm') and return;
    my ($rooted_librpm_version) = map { _libdb_version($_) } $pkg->requires; # perl_checker: $self = revision
    my $rooted_rpm_version = version->new("v" . $pkg->version); # perl_checker: $self = revision

    my $urpmi_librpm_version = _libdb_version(scalar `ldd /bin/rpm`); # perl_checker: $self = revision

    if (_rpm_version() ge v4.9.0) { # perl_checker: $self = revision
	if ($rooted_rpm_version && $rooted_rpm_version ge v4.9) {
	    $urpm->{debug} and $urpm->{debug}("chrooted db version used by librpm is at least as good as non-rooted one");
	} else {
	    $urpm->{need_migrate_rpmdb} = '4.8';
	    return 1;
	}
    } elsif ($urpmi_librpm_version ge v4.6) {
	if ($rooted_librpm_version && $rooted_librpm_version ge v4.6) {
	    $urpm->{debug} and $urpm->{debug}("chrooted db version used by librpm is at least as good as non-rooted one");
	} else {
	    foreach my $bin ('db_dump', 'db42_load') {
		urpm::sys::whereis_binary($bin) 
		  or $urpm->{error}("can not migrate rpm db from Hash version 9 to Hash version 8 without $bin"), 
		    return;
	    }
	    $urpm->{need_migrate_rpmdb} = '4.6';
	    return 1;
	}
    }
    0;
}

1;

=back

=cut