package URPM; #package URPM::Resolve; #use URPM; # $Id: Resolve.pm 270395 2010-07-30 00:55:59Z nanardon $ use strict; use warnings; use Config; # perl_checker: require URPM #- a few functions from MDK::Common copied here: sub listlength { my (@l) = @_; scalar @l; } sub uniq { my (@l) = @_; my %l; $l{$_} = 1 foreach @l; grep { delete $l{$_} } @l; } sub find(&@) { my $f = shift; $f->($_) and return $_ foreach @_; undef; } #- property2name* functions below parse things like "mageia-release[>= 1]" #- which is the format returned by URPM.xs for ->requires, ->provides, ->conflicts... sub property2name { my ($property) = @_; $property =~ /^([^\s\[]*)/ && $1; } sub property2name_range { my ($property) = @_; $property =~ /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/; } sub property2name_op_version { my ($property) = @_; $property =~ /^([^\s\[]*)(?:\[\*\])?\s*\[?([^\s\]]*)\s*([^\s\]]*)/; } #- wrappers around $state (cf "The $state object" in "perldoc URPM") sub packages_to_remove { my ($state) = @_; grep { $state->{rejected}{$_}{removed} && !$state->{rejected}{$_}{obsoleted}; } keys %{$state->{rejected} || {}}; } sub removed_or_obsoleted_packages { my ($state) = @_; grep { $state->{rejected}{$_}{removed} || $state->{rejected}{$_}{obsoleted}; } keys %{$state->{rejected} || {}}; } #- Find candidates packages from a require string (or id). #- Takes care of choices using the '|' separator. #- (nb: see also find_required_package()) #- #- side-effects: none sub find_candidate_packages_ { my ($urpm, $id_prop, $o_rejected) = @_; my @packages; foreach (split /\|/, $id_prop) { if (/^\d+$/) { my $pkg = $urpm->{depslist}[$_]; $pkg->flag_skip and next; $pkg->arch eq 'src' || $pkg->is_arch_compat or next; $o_rejected && exists $o_rejected->{$pkg->fullname} and next; push @packages, $pkg; } elsif (my $name = property2name($_)) { my $property = $_; foreach (keys %{$urpm->{provides}{$name} || {}}) { my $pkg = $urpm->{depslist}[$_]; $pkg->flag_skip and next; $pkg->is_arch_compat or next; $o_rejected && exists $o_rejected->{$pkg->fullname} and next; #- check if at least one provide of the package overlap the property. !$urpm->{provides}{$name}{$_} || $pkg->provides_overlap($property, 1) and push @packages, $pkg; } } } @packages; } #- deprecated, use find_candidate_packages_() directly #- #- side-effects: none sub find_candidate_packages { my ($urpm, $id_prop, $o_rejected) = @_; my %packages; foreach (find_candidate_packages_($urpm, $id_prop, $o_rejected)) { push @{$packages{$_->name}}, $_; } \%packages; } #- returns the "arch" of package $n in rpm db sub get_installed_arch { my ($db, $n) = @_; my $arch; $db->traverse_tag('name', [ $n ], sub { $arch = $_[0]->arch }); $arch; } #- is "strict-arch" wanted? (cf "man urpmi") #- since it's slower we only force it on bi-arch sub strict_arch { my ($urpm) = @_; defined $urpm->{options}{'strict-arch'} ? $urpm->{options}{'strict-arch'} : $Config{archname} =~ /x86_64|sparc64|ppc64/; } my %installed_arch; #- checks wether $pkg could be installed under strict-arch policy #- (ie check wether $pkg->name with different arch is not installed) #- #- side-effects: none (but uses a cache) sub strict_arch_check_installed { my ($db, $pkg) = @_; if ($pkg->arch ne 'src' && $pkg->arch ne 'noarch') { my $n = $pkg->name; defined $installed_arch{$n} or $installed_arch{$n} = get_installed_arch($db, $n); if ($installed_arch{$n} && $installed_arch{$n} ne 'noarch') { $pkg->arch eq $installed_arch{$n} or return; } } 1; } #- check wether $installed_pkg and $pkg have same arch #- (except for src/noarch of course) #- #- side-effects: none sub strict_arch_check { my ($installed_pkg, $pkg) = @_; if ($pkg->arch ne 'src' && $pkg->arch ne 'noarch') { if ($installed_pkg->arch ne 'noarch') { $pkg->arch eq $installed_pkg->arch or return; } } 1; } #- is $pkg->name installed? #- #- side-effects: none sub is_package_installed { my ($db, $pkg) = @_; my $found; $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; $found ||= $p->fullname eq $pkg->fullname; }); $found; } sub _is_selected_or_installed { my ($urpm, $db, $name) = @_; (grep { $_->flag_available } $urpm->packages_providing($name)) > 0 || $db->traverse_tag('name', [ $name ], undef) > 0; } #- finds $pkg "provides" that matches $provide_name, and returns the version provided #- eg: $pkg provides "a = 3", $provide_name is "a > 1", returns "3" sub provided_version_that_overlaps { my ($pkg, $provide_name) = @_; my $version; foreach my $property ($pkg->provides) { my ($n, undef, $v) = property2name_op_version($property) or next; $n eq $provide_name or next; if ($version) { $version = $v if URPM::rpmvercmp($v, $version) > 0; } else { $version = $v; } } $version; } #- deprecated function, use find_required_package() sub find_chosen_packages { &find_required_package } #- find the package (or packages) to install matching $id_prop #- returns (list ref of matches, list ref of preferred matches) #- (see also find_candidate_packages_()) #- #- side-effects: flag_install, flag_upgrade (and strict_arch_check_installed cache) sub find_required_package { my ($urpm, $db, $state, $id_prop) = @_; my (%packages, %provided_version); my $strict_arch = strict_arch($urpm); my $may_add_to_packages = sub { my ($pkg) = @_; if (my $p = $packages{$pkg->name}) { $pkg->flag_requested > $p->flag_requested || $pkg->flag_requested == $p->flag_requested && $pkg->compare_pkg($p) > 0 and $packages{$pkg->name} = $pkg; } else { $packages{$pkg->name} = $pkg; } }; #- search for possible packages, try to be as fast as possible, backtrack can be longer. foreach (split /\|/, $id_prop) { if (/^\d+$/) { my $pkg = $urpm->{depslist}[$_]; $pkg->arch eq 'src' || $pkg->is_arch_compat or next; $pkg->flag_skip || $state->{rejected}{$pkg->fullname} and next; #- determine if this package is better than a possibly previously chosen package. $pkg->flag_selected || exists $state->{selected}{$pkg->id} and return [$pkg]; !$strict_arch || strict_arch_check_installed($db, $pkg) or next; $may_add_to_packages->($pkg); } elsif (my $name = property2name($_)) { my $property = $_; foreach (sort { $a <=> $b } keys %{$urpm->{provides}{$name} || {}}) { my $pkg = $urpm->{depslist}[$_]; $pkg->is_arch_compat or next; $pkg->flag_skip || $state->{rejected}{$pkg->fullname} and next; #- check if at least one provide of the package overlaps the property if (!$urpm->{provides}{$name}{$_} || $pkg->provides_overlap($property)) { #- determine if this package is better than a possibly previously chosen package. $pkg->flag_selected || exists $state->{selected}{$pkg->id} and return [$pkg]; !$strict_arch || strict_arch_check_installed($db, $pkg) or next; $provided_version{$pkg} = provided_version_that_overlaps($pkg, $name); $may_add_to_packages->($pkg); } } } } my @packages = values %packages; if (@packages > 1) { #- packages should be preferred if one of their provides is referenced #- in the "requested" hash, or if the package itself is requested (or #- required). #- If there is no preference, choose the first one by default (higher #- probability of being chosen) and ask the user. #- Packages with more compatibles architectures are always preferred. #- Puts the results in @chosen. Other are left unordered. foreach my $pkg (@packages) { _set_flag_installed_and_upgrade_if_no_newer($db, $pkg); } if (my @kernel_source = _find_required_package__kernel_source($urpm, $db, \@packages)) { $urpm->{debug_URPM}("packageCallbackChoices: kernel source chosen " . join(",", map { $_->name } @kernel_source) . " in " . join(",", map { $_->name } @packages)) if $urpm->{debug_URPM}; return \@kernel_source, \@kernel_source; } if (my @kmod = _find_required_package__kmod($urpm, $db, \@packages)) { $urpm->{debug_URPM}("packageCallbackChoices: kmod packages " . join(",", map { $_->name } @kmod) . " in " . join(",", map { $_->name } @packages)) if $urpm->{debug_URPM}; return \@kmod, \@kmod; } _find_required_package__sort($urpm, $db, \@packages, \%provided_version); } else { \@packages; } } # nb: _set_flag_installed_and_upgrade_if_no_newer must be done on $packages sub _find_required_package__sort { my ($urpm, $db, $packages, $provided_version) = @_; my ($best, @other) = sort { $a->[1] <=> $b->[1] #- we want the lowest (ie preferred arch) || $b->[2] <=> $a->[2]; #- and the higher score } map { my $score = 0; $score += 2 if $_->flag_requested; $score += $_->flag_upgrade ? 1 : -1 if $_->flag_installed; [ $_, $_->is_arch_compat, $score ]; } @$packages; my @chosen_with_score = ($best, grep { $_->[1] == $best->[1] && $_->[2] == $best->[2] } @other); my @chosen = map { $_->[0] } @chosen_with_score; #- return immediately if there is only one chosen package if (@chosen == 1) { return \@chosen } #- if several packages were selected to match a requested installation, #- and if --more-choices wasn't given, trim the choices to the first one. if (!$urpm->{options}{morechoices} && $chosen_with_score[0][2] == 3) { return [ $chosen[0] ]; } if ($urpm->{media}) { @chosen_with_score = sort { $a->[2] != $b->[2] ? $a->[0]->id <=> $b->[0]->id : $b->[1] <=> $a->[1] || $b->[0]->compare_pkg($a->[0]); } map { [ $_, _score_for_locales($urpm, $db, $_), pkg2media($urpm->{media}, $_) ] } @chosen; } else { # obsolete code which should not happen, kept just in case $urpm->{debug_URPM}("can't sort choices by media") if $urpm->{debug_URPM}; @chosen_with_score = sort { $b->[1] <=> $a->[1] || $b->[0]->compare_pkg($a->[0]) || $a->[0]->id <=> $b->[0]->id; } map { [ $_, _score_for_locales($urpm, $db, $_) ] } @chosen; } if (!$urpm->{options}{morechoices}) { if (my @valid_locales = grep { $_->[1] } @chosen_with_score) { #- get rid of invalid locales @chosen_with_score = @valid_locales; } } # propose to select all packages for installed locales my @prefered = grep { $_->[1] == 3 } @chosen_with_score; @chosen = map { $_->[0] } @chosen_with_score; if (%$provided_version) { # highest provided version first # (nb: this sort overrules the sort on media (cf ->id above)) @chosen = sort { URPM::rpmvercmp($provided_version->{$b} || 0, $provided_version->{$a} || 0) } @chosen; } \@chosen, [ map { $_->[0] } @prefered ]; } #- prefer the pkgs corresponding to installed/selected kernels sub _find_required_package__kernel_source { my ($urpm, $db, $choices) = @_; $choices->[0]->name =~ /^kernel-(.*source-|.*-devel-)/ or return; grep { if ($_->name =~ /^kernel-.*source-stripped-(.*)/) { my $version = quotemeta($1); find { $_->name =~ /-$version$/ && ($_->flag_installed || $_->flag_selected); } $urpm->packages_providing('kernel'); } elsif ($_->name =~ /(kernel-.*)-devel-(.*)/) { my $kernel = "$1-$2"; _is_selected_or_installed($urpm, $db, $kernel); } elsif ($_->name =~ /^kernel-.*source-/) { #- hopefully we don't have a media with kernel-source but not kernel-source-stripped nor kernel-.*-devel 0; } else { $urpm->{debug_URPM}("unknown kernel-source package " . $_->fullname) if $urpm->{debug_URPM}; 0; } } @$choices; } #- prefer the pkgs corresponding to installed/selected kernels sub _find_required_package__kmod { my ($urpm, $db, $choices) = @_; $choices->[0]->name =~ /^dkms-|-kernel-\d\./ or return; grep { if (my ($_name, $version, $flavor, $release) = $_->name =~ /(.*)-kernel-(\d\..*)-(.*)-(.*)/) { my $kernel = "kernel-$flavor-$version-$release"; _is_selected_or_installed($urpm, $db, $kernel); } elsif ($_->name =~ /^dkms-/) { 0; # we prefer precompiled dkms } else { $urpm->{debug_URPM}("unknown kmod package " . $_->fullname) if $urpm->{debug_URPM}; 0; } } @$choices; } #- Packages that require locales-xxx when the corresponding locales are #- already installed should be preferred over packages that require locales #- which are not installed. #- #- eg: locales-fr & locales-de are installed, #- prefer firefox-fr & firefox-de which respectively require locales-fr & locales-de sub _score_for_locales { my ($urpm, $db, $pkg) = @_; my @r = $pkg->requires_nosense; if (my ($specific_locales) = grep { /locales-(?!en)/ } @r) { if (_is_selected_or_installed($urpm, $db, $specific_locales)) { 3; # good locale } else { 0; # bad locale } } elsif (grep { /locales-en/ } @r) { 2; # } else { 1; } } #- side-effects: $properties, $choices #- + those of backtrack_selected ($state->{backtrack}, $state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) sub _choose_required { my ($urpm, $db, $state, $dep, $properties, $choices, $diff_provides, %options) = @_; #- take the best choice possible. my ($chosen, $prefered) = find_required_package($urpm, $db, $state, $dep->{required}); #- If no choice is found, this means that nothing can be possibly selected #- according to $dep, so we need to retry the selection, allowing all #- packages that conflict or anything similar to see which strategy can be #- tried. Backtracking is used to avoid trying multiple times the same #- packages. If multiple packages are possible and properties is not #- empty, postpone the choice for a later time as one of the packages #- may be selected for another reason. Otherwise simply ask the user which #- one to choose; else take the first one available. if (!@$chosen) { $urpm->{debug_URPM}("no packages match " . _dep_to_name($urpm, $dep) . " (it is either in skip.list or already rejected)") if $urpm->{debug_URPM}; unshift @$properties, backtrack_selected($urpm, $db, $state, $dep, $diff_provides, %options); return; #- backtrack code choose to continue with same package or completely new strategy. } elsif (@$chosen > 1) { if (@$properties) { unshift @$choices, $dep; return; } elsif ($options{callback_choices}) { my @l = grep { ref $_ } $options{callback_choices}->($urpm, $db, $state, $chosen, _dep_to_name($urpm, $dep), $prefered); $urpm->{debug_URPM}("replacing " . _dep_to_name($urpm, $dep) . " with " . join(' ', map { $_->name } @l)) if $urpm->{debug_URPM}; unshift @$properties, map { +{ required => $_->id, _choices => $dep->{required}, exists $dep->{from} ? (from => $dep->{from}) : @{[]}, exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, }; } @l; return; #- always redo according to choices. } } #- now do the real work, select the package. my $pkg = shift @$chosen; if ($urpm->{debug_URPM} && $pkg->name ne _dep_to_name($urpm, $dep)) { $urpm->{debug_URPM}("chosen " . $pkg->fullname . " for " . _dep_to_name($urpm, $dep)); @$chosen and $urpm->{debug_URPM}(" (it could also have chosen " . join(' ', map { scalar $_->fullname } @$chosen)); } $pkg; } sub pkg2media { my ($mediums, $p) = @_; my $id = $p->id; #- || 0 to avoid undef, but is it normal to have undef ? find { $id >= ($_->{start} || 0) && $id <= ($_->{end} || 0) } @$mediums; } sub whatrequires { my ($urpm, $state, $property_name) = @_; map { $urpm->{depslist}[$_] } whatrequires_id($state, $property_name); } sub whatrequires_id { my ($state, $property_name) = @_; keys %{$state->{whatrequires}{$property_name} || {}}; } #- return unresolved requires of a package (a new one or an existing one). #- #- side-effects: none (but uses a $state->{cached_installed}) sub unsatisfied_requires { my ($urpm, $db, $state, $pkg, %options) = @_; my %unsatisfied; #- all requires should be satisfied according to selected packages or installed packages, #- or the package itself. REQUIRES: foreach my $prop ($pkg->requires) { my ($n, $s) = property2name_range($prop) or next; if (defined $options{name} && $n ne $options{name}) { #- allow filtering on a given name (to speed up some search). } elsif (exists $unsatisfied{$prop}) { #- avoid recomputing the same all the time. } else { #- check for installed packages in the installed cache. foreach (keys %{$state->{cached_installed}{$n} || {}}) { exists $state->{rejected}{$_} and next; next REQUIRES; } #- check on the selected package if a provide is satisfying the resolution (need to do the ops). foreach (grep { exists $state->{selected}{$_} } keys %{$urpm->{provides}{$n} || {}}) { my $p = $urpm->{depslist}[$_]; !$urpm->{provides}{$n}{$_} || $p->provides_overlap($prop, 1) and next REQUIRES; } #- check if the package itself provides what is necessary. $pkg->provides_overlap($prop) and next REQUIRES; #- check on installed system if a package which is not obsoleted is satisfying the require. my $satisfied = 0; if ($n =~ m!^/!) { $db->traverse_tag('path', [ $n ], sub { my ($p) = @_; exists $state->{rejected}{$p->fullname} and return; $state->{cached_installed}{$n}{$p->fullname} = undef; ++$satisfied; }); } else { $db->traverse_tag('whatprovides', [ $n ], sub { my ($p) = @_; exists $state->{rejected}{$p->fullname} and return; foreach ($p->provides) { if (my ($pn, $ps) = property2name_range($_)) { $ps or $state->{cached_installed}{$pn}{$p->fullname} = undef; $pn eq $n or next; URPM::ranges_overlap($ps, $s, 1) and ++$satisfied; } } }); } #- if nothing can be done, the require should be resolved. $satisfied or $unsatisfied{$prop} = undef; } } keys %unsatisfied; } #- this function is "suggests vs requires" safe: #- 'whatrequires' will give both requires & suggests, but unsatisfied_requires #- will check $p->requires and so filter out suggests #- side-effects: only those done by $do sub with_db_unsatisfied_requires { my ($urpm, $db, $state, $name, $do) = @_; $db->traverse_tag('whatrequires', [ $name ], sub { my ($p) = @_; if (my @l = unsatisfied_requires($urpm, $db, $state, $p, name => $name)) { $urpm->{debug_URPM}("installed " . $p->fullname . " is conflicting because of unsatisfied @l") if $urpm->{debug_URPM}; $do->($p, @l); } }); } #- side-effects: only those done by $do sub with_state_unsatisfied_requires { my ($urpm, $db, $state, $name, $do) = @_; foreach (whatrequires_id($state, $name)) { $state->{selected}{$_} or next; my $p = $urpm->{depslist}[$_]; if (my @l = unsatisfied_requires($urpm, $db, $state, $p, name => $name)) { $urpm->{debug_URPM}("selected " . $p->fullname . " is conflicting because of unsatisfied @l") if $urpm->{debug_URPM}; $do->($p, @l); } } } sub with_any_unsatisfied_requires { my ($urpm, $db, $state, $name, $do) = @_; with_db_unsatisfied_requires($urpm, $db, $state, $name, sub { my ($p, @l) = @_; $do->($p, 0, @l) }); with_state_unsatisfied_requires($urpm, $db, $state, $name, sub { my ($p, @l) = @_; $do->($p, 1, @l) }); } # used when a require is not available # #- side-effects: $state->{backtrack}, $state->{selected} #- + those of disable_selected_and_unrequested_dependencies ($state->{whatrequires}, flag_requested, flag_required) #- + those of _set_rejected_from ($state->{rejected}) #- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) #- + those of _add_rejected_backtrack ($state->{rejected}) sub backtrack_selected { my ($urpm, $db, $state, $dep, $diff_provides, %options) = @_; if (defined $dep->{required}) { #- avoid deadlock here... if (!exists $state->{backtrack}{deadlock}{$dep->{required}}) { $state->{backtrack}{deadlock}{$dep->{required}} = undef; #- search for all possible packages, first is to try the selection, then if it is #- impossible, backtrack the origin. my @packages = find_candidate_packages_($urpm, $dep->{required}); foreach (@packages) { #- avoid dead loop. exists $state->{backtrack}{selected}{$_->id} and next; #- a package if found is problably rejected or there is a problem. if ($state->{rejected}{$_->fullname}) { #- keep in mind a backtrack has happening here... exists $dep->{promote} and _add_rejected_backtrack($state, $_, { promote => [ $dep->{promote} ] }); my $closure = $state->{rejected}{$_->fullname}{closure} || {}; foreach my $p (grep { exists $closure->{$_}{avoid} } keys %$closure) { _add_rejected_backtrack($state, $_, { conflicts => [ $p ] }); } #- backtrack callback should return a strictly positive value if the selection of the new #- package is prefered over the currently selected package. next; } $state->{backtrack}{selected}{$_->id} = undef; #- in such case, we need to drop the problem caused so that rejected condition is removed. #- if this is not possible, the next backtrack on the same package will be refused above. my @l = map { $urpm->search($_, strict_fullname => 1) } keys %{($state->{rejected}{$_->fullname} || {})->{closure}}; disable_selected_and_unrequested_dependencies($urpm, $db, $state, @l); return { required => $_->id, exists $dep->{from} ? (from => $dep->{from}) : @{[]}, exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, }; } } } if (defined $dep->{from}) { if ($options{nodeps}) { #- try to keep unsatisfied dependencies in requested. if ($dep->{required} && exists $state->{selected}{$dep->{from}->id}) { push @{$state->{selected}{$dep->{from}->id}{unsatisfied}}, $dep->{required}; } } else { #- at this point, dep cannot be resolved, this means we need to disable #- all selection tree, re-enabling removed and obsoleted packages as well. unless (exists $state->{rejected}{$dep->{from}->fullname}) { #- package is not currently rejected, compute the closure now. my @l = disable_selected_and_unrequested_dependencies($urpm, $db, $state, $dep->{from}); foreach (@l) { #- disable all these packages in order to avoid selecting them again. _set_rejected_from($state, $_, $dep->{from}); } } #- the package is already rejected, we assume we can add another reason here! $urpm->{debug_URPM}("adding a reason to already rejected package " . $dep->{from}->fullname . ": unsatisfied " . $dep->{required}) if $urpm->{debug_URPM}; _add_rejected_backtrack($state, $dep->{from}, { unsatisfied => [ $dep->{required} ] }); } } my @properties; if (defined $dep->{psel}) { if ($options{keep}) { backtrack_selected_psel_keep($urpm, $db, $state, $dep->{psel}, $dep->{keep}); #- the package is already rejected, we assume we can add another reason here! defined $dep->{promote} and _add_rejected_backtrack($state, $dep->{psel}, { promote => [ $dep->{promote} ] }); } else { #- the backtrack need to examine diff_provides promotion on $n. with_db_unsatisfied_requires($urpm, $db, $state, $dep->{promote}, sub { my ($p, @unsatisfied) = @_; my %diff_provides_h; set_rejected_and_compute_diff_provides($urpm, $state, \%diff_provides_h, { rejected_pkg => $p, removed => 1, from => $dep->{psel}, why => { unsatisfied => \@unsatisfied } }); push @$diff_provides, map { +{ name => $_, pkg => $dep->{psel} } } keys %diff_provides_h; }); with_state_unsatisfied_requires($urpm, $db, $state, $dep->{promote}, sub { my ($p) = @_; _set_rejected_from($state, $p, $dep->{psel}); disable_selected_and_unrequested_dependencies($urpm, $db, $state, $p); }); } } #- some packages may have been removed because of selection of this one. #- the rejected flags should have been cleaned by disable_selected above. @properties; } #- side-effects: #- + those of _set_rejected_from ($state->{rejected}) #- + those of _add_rejected_backtrack ($state->{rejected}) #- + those of disable_selected_and_unrequested_dependencies ($state->{selected}, $state->{whatrequires}, flag_requested, flag_required) sub backtrack_selected_psel_keep { my ($urpm, $db, $state, $psel, $keep) = @_; #- we shouldn't try to remove packages, so psel which leads to this need to be unselected. unless (exists $state->{rejected}{$psel->fullname}) { #- package is not currently rejected, compute the closure now. my @l = disable_selected_and_unrequested_dependencies($urpm, $db, $state, $psel); foreach (@l) { #- disable all these packages in order to avoid selecting them again. _set_rejected_from($state, $_, $psel); } } #- to simplify, a reference to list or standalone elements may be set in keep. $keep and _add_rejected_backtrack($state, $psel, { keep => $keep }); } #- side-effects: $state->{rejected} sub _remove_all_rejected_from { my ($state, $from_fullname) = @_; grep { _remove_rejected_from($state, $_, $from_fullname); } keys %{$state->{rejected}}; } #- side-effects: $state->{rejected} sub _remove_rejected_from { my ($state, $fullname, $from_fullname) = @_; my $rv = $state->{rejected}{$fullname} or return; foreach (qw(removed obsoleted)) { if (exists $rv->{$_} && exists $rv->{$_}{$from_fullname}) { delete $rv->{$_}{$from_fullname}; delete $rv->{$_} if !%{$rv->{$_}}; } } exists $rv->{closure}{$from_fullname} or return; delete $rv->{closure}{$from_fullname}; if (%{$rv->{closure}}) { 0; } else { delete $state->{rejected}{$fullname}; 1; } } #- side-effects: $state->{rejected} sub _add_rejected_backtrack { my ($state, $pkg, $backtrack) = @_; my $bt = $state->{rejected}{$pkg->fullname}{backtrack} ||= {}; foreach (keys %$backtrack) { push @{$bt->{$_}}, @{$backtrack->{$_}}; } } #- useful to reject packages in advance #- eg when selecting "a" which conflict with "b", ensure we won't select "b" #- but it's somewhat dangerous because it's sometimes called on installed packages, #- and in that case, a real resolve_rejected_ must be done #- (that's why set_rejected ignores the effect of _set_rejected_from) #- #- side-effects: $state->{rejected} sub _set_rejected_from { my ($state, $pkg, $from_pkg) = @_; $pkg->fullname ne $from_pkg->fullname or return; $state->{rejected}{$pkg->fullname}{closure}{$from_pkg->fullname}{avoid} ||= undef; } #- side-effects: $state->{rejected} sub _set_rejected_old_package { my ($state, $pkg, $new_pkg) = @_; if ($pkg->fullname eq $new_pkg->fullname) { $state->{rejected_already_installed}{$pkg->id} = $pkg; } else { push @{$state->{rejected}{$pkg->fullname}{backtrack}{keep}}, scalar $new_pkg->fullname; } } #- side-effects: $state->{rejected} sub set_rejected { my ($urpm, $state, $rdep) = @_; my $fullname = $rdep->{rejected_pkg}->fullname; my $rv = $state->{rejected}{$fullname} ||= {}; my $newly_rejected = !exists $rv->{size}; if ($newly_rejected) { $urpm->{debug_URPM}("set_rejected: $fullname") if $urpm->{debug_URPM}; #- keep track of size of package which are finally removed. $rv->{size} = $rdep->{rejected_pkg}->size; } #- keep track of what causes closure. if ($rdep->{from}) { my $closure = $rv->{closure}{scalar $rdep->{from}->fullname} ||= {}; if (my $l = delete $rdep->{why}{unsatisfied}) { my $unsatisfied = $closure->{unsatisfied} ||= []; @$unsatisfied = uniq(@$unsatisfied, @$l); } $closure->{$_} = $rdep->{why}{$_} foreach keys %{$rdep->{why}}; } #- set removed and obsoleted level. foreach (qw(removed obsoleted)) { if ($rdep->{$_}) { if ($rdep->{from}) { $rv->{$_}{scalar $rdep->{from}->fullname} = undef; } else { $rv->{$_}{asked} = undef; } } } $newly_rejected; } #- side-effects: #- + those of set_rejected ($state->{rejected}) #- + those of _compute_diff_provides_of_removed_pkg ($diff_provides_h) sub set_rejected_and_compute_diff_provides { my ($urpm, $state, $diff_provides_h, $rdep) = @_; my $newly_rejected = set_rejected($urpm, $state, $rdep); #- no need to compute diff_provides if package was already rejected $newly_rejected or return; _compute_diff_provides_of_removed_pkg($urpm, $state, $diff_provides_h, $rdep->{rejected_pkg}); } #- see resolve_rejected_ below sub resolve_rejected { my ($urpm, $db, $state, $pkg, %rdep) = @_; $rdep{rejected_pkg} = $pkg; resolve_rejected_($urpm, $db, $state, $rdep{unsatisfied}, \%rdep); } #- close rejected (as urpme previously) for package to be removable without error. #- #- side-effects: $properties #- + those of set_rejected ($state->{rejected}) sub resolve_rejected_ { my ($urpm, $db, $state, $properties, $rdep) = @_; $urpm->{debug_URPM}("resolve_rejected: " . $rdep->{rejected_pkg}->fullname) if $urpm->{debug_URPM}; #- check if the package has already been asked to be rejected (removed or obsoleted). #- this means only add the new reason and return. my $newly_rejected = set_rejected($urpm, $state, $rdep); $newly_rejected or return; my @pkgs_todo = $rdep->{rejected_pkg}; while (my $cp = shift @pkgs_todo) { #- close what requires this property, but check with selected package requiring old properties. foreach my $n ($cp->provides_nosense) { foreach my $pkg (whatrequires($urpm, $state, $n)) { if (my @l = unsatisfied_requires($urpm, $db, $state, $pkg, name => $n)) { #- a selected package requires something that is no more available #- and should be tried to be re-selected if possible. if ($properties) { push @$properties, map { { required => $_, rejected => scalar $pkg->fullname }; # rejected is only there for debugging purpose (??) } @l; } } } with_db_unsatisfied_requires($urpm, $db, $state, $n, sub { my ($p, @unsatisfied) = @_; my $newly_rejected = set_rejected($urpm, $state, { rejected_pkg => $p, from => $rdep->{rejected_pkg}, why => { unsatisfied => \@unsatisfied }, obsoleted => $rdep->{obsoleted}, removed => $rdep->{removed}, }); #- continue the closure unless already examined. $newly_rejected or return; $p->pack_header; #- need to pack else package is no longer visible... push @pkgs_todo, $p; }); } } } # see resolve_requested__no_suggests below for information about usage sub resolve_requested { my ($urpm, $db, $state, $requested, %options) = @_; my @selected = resolve_requested__no_suggests($urpm, $db, $state, $requested, %options); if (!$options{no_suggests}) { my @todo = @selected; while (@todo) { my $pkg = shift @todo; my %suggests = map { $_ => 1 } $pkg->suggests or next; #- do not install a package that has already been suggested $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; delete $suggests{$_} foreach $p->suggests; }); # workaround: if you do "urpmi virtual_pkg" and one virtual_pkg is already installed, # it will ask anyway for the other choices foreach my $suggest (keys %suggests) { $db->traverse_tag('whatprovides', [ $suggest ], sub { delete $suggests{$suggest}; }); } %suggests or next; $urpm->{debug_URPM}("requested " . join(', ', keys %suggests) . " suggested by " . $pkg->fullname) if $urpm->{debug_URPM}; my %new_requested = map { $_ => undef } keys %suggests; my @new_selected = resolve_requested__no_suggests_($urpm, $db, $state, \%new_requested, %options); $state->{selected}{$_->id}{suggested} = 1 foreach @new_selected; push @selected, @new_selected; push @todo, @new_selected; } } @selected; } #- Resolve dependencies of requested packages; keep resolution state to #- speed up process. #- A requested package is marked to be installed; once done, an upgrade flag or #- an installed flag is set according to the needs of the installation of this #- package. #- Other required packages will have a required flag set along with an upgrade #- flag or an installed flag. #- Base flag should always be "installed" or "upgraded". #- The following options are recognized : #- callback_choices : subroutine to be called to ask the user to choose #- between several possible packages. Returns an array of URPM::Package #- objects, or an empty list eventually. #- keep : #- nodeps : #- #- side-effects: flag_requested #- + those of resolve_requested__no_suggests_ sub resolve_requested__no_suggests { my ($urpm, $db, $state, $requested, %options) = @_; foreach (keys %$requested) { #- keep track of requested packages by propating the flag. foreach (find_candidate_packages_($urpm, $_)) { $_->set_flag_requested; } } resolve_requested__no_suggests_($urpm, $db, $state, $requested, %options); } # same as resolve_requested__no_suggests, but do not modify requested_flag #- #- side-effects: $state->{selected}, flag_required, flag_installed, flag_upgrade #- + those of backtrack_selected (flag_requested, $state->{rejected}, $state->{whatrequires}, $state->{backtrack}) #- + those of _unselect_package_deprecated_by (flag_requested, $state->{rejected}, $state->{whatrequires}, $state->{oldpackage}, $state->{unselected_uninstalled}) #- + those of _handle_conflicts ($state->{rejected}) #- + those of _handle_conflict ($state->{rejected}) #- + those of backtrack_selected_psel_keep (flag_requested, $state->{whatrequires}) #- + those of _handle_diff_provides (flag_requested, $state->{rejected}, $state->{whatrequires}) #- + those of _no_more_recent_installed_and_providing ($state->{rejected}) sub resolve_requested__no_suggests_ { my ($urpm, $db, $state, $requested, %options) = @_; my @properties = map { { required => $_, requested => $requested->{$_} }; } keys %$requested; my (@diff_provides, @selected, @choices); #- for each dep property evaluated, examine which package will be obsoleted on $db, #- then examine provides that will be removed (which need to be satisfied by another #- package present or by a new package to upgrade), then requires not satisfied and #- finally conflicts that will force a new upgrade or a remove. do { while (my $dep = shift @properties) { #- we need to avoid selecting packages if the source has been disabled. if (exists $dep->{from} && !$urpm->{keep_unrequested_dependencies}) { exists $state->{selected}{$dep->{from}->id} or next; } my $pkg = _choose_required($urpm, $db, $state, $dep, \@properties, \@choices, \@diff_provides, %options) or next; !$pkg || exists $state->{selected}{$pkg->id} and next; if ($pkg->arch eq 'src') { $pkg->set_flag_upgrade; } else { _set_flag_installed_and_upgrade_if_no_newer($db, $pkg); if ($pkg->flag_installed && !$pkg->flag_upgrade) { _no_more_recent_installed_and_providing($urpm, $db, $state, $pkg, $dep->{required}) or next; } } _handle_conflicts_with_selected($urpm, $db, $state, $pkg, $dep, \@properties, \@diff_provides, %options) or next; $urpm->{debug_URPM}("selecting " . $pkg->fullname) if $urpm->{debug_URPM}; #- keep in mind the package has be selected, remove the entry in requested input hash, #- this means required dependencies have undef value in selected hash. #- requested flag is set only for requested package where value is not false. push @selected, $pkg; $state->{selected}{$pkg->id} = { exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, exists $dep->{from} ? (from => $dep->{from}) : @{[]}, exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, $pkg->flag_disable_obsolete ? (install => 1) : @{[]}, }; $pkg->set_flag_required; #- check if the package is not already installed before trying to use it, compute #- obsoleted packages too. This is valable only for non source packages. my %diff_provides_h; if ($pkg->arch ne 'src' && !$pkg->flag_disable_obsolete) { _unselect_package_deprecated_by($urpm, $db, $state, \%diff_provides_h, $pkg); } #- all requires should be satisfied according to selected package, or installed packages. if (my @l = unsatisfied_requires($urpm, $db, $state, $pkg)) { $urpm->{debug_URPM}("requiring " . join(',', sort @l) . " for " . $pkg->fullname) if $urpm->{debug_URPM}; unshift @properties, map { +{ required => $_, from => $pkg, exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, } } @l; } #- keep in mind what is requiring each item (for unselect to work). foreach ($pkg->requires_nosense) { $state->{whatrequires}{$_}{$pkg->id} = undef; } #- cancel flag if this package should be cancelled but too late (typically keep options). my @keep; _handle_conflicts($urpm, $db, $state, $pkg, \@properties, \%diff_provides_h, $options{keep} && \@keep); #- examine if an existing package does not conflict with this one. $db->traverse_tag('whatconflicts', [ $pkg->provides_nosense ], sub { @keep and return; my ($p) = @_; foreach my $property ($p->conflicts) { if ($pkg->provides_overlap($property)) { _handle_conflict($urpm, $state, $pkg, $p, $property, $property, \@properties, \%diff_provides_h, $options{keep} && \@keep); } } }); #- keep existing package and therefore cancel current one. if (@keep) { backtrack_selected_psel_keep($urpm, $db, $state, $pkg, \@keep); } push @diff_provides, map { +{ name => $_, pkg => $pkg } } keys %diff_provides_h; } if (my $diff = shift @diff_provides) { _handle_diff_provides($urpm, $db, $state, \@properties, \@diff_provides, $diff->{name}, $diff->{pkg}, %options); } elsif (my $dep = shift @choices) { push @properties, $dep; } } while @diff_provides || @properties || @choices; #- return what has been selected by this call (not all selected hash which may be not empty #- previously. avoid returning rejected packages which weren't selectable. grep { exists $state->{selected}{$_->id} } @selected; } #- pre-disables packages that $pkg has conflict entries for, and #- unselects $pkg if such a package is already selected #- side-effects: #- + those of _set_rejected_from ($state->{rejected}) #- + those of _remove_all_rejected_from ($state->{rejected}) #- + those of backtrack_selected ($state->{backtrack}, $state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) sub _handle_conflicts_with_selected { my ($urpm, $db, $state, $pkg, $dep, $properties, $diff_provides, %options) = @_; foreach ($pkg->conflicts) { if (my ($n, $_o, $_v) = property2name_op_version($_)) { foreach my $p ($urpm->packages_providing($n)) { $pkg == $p and next; $p->provides_overlap($_) or next; if (exists $state->{selected}{$p->id}) { $urpm->{debug_URPM}($pkg->fullname . " conflicts with already selected package " . $p->fullname) if $urpm->{debug_URPM}; _remove_all_rejected_from($state, $pkg); _set_rejected_from($state, $pkg, $p); unshift @$properties, backtrack_selected($urpm, $db, $state, $dep, $diff_provides, %options); return; } _set_rejected_from($state, $p, $pkg); } } } 1; } #- side-effects: #- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) #- + those of _handle_conflict ($properties, $keep, $diff_provides_h) sub _handle_conflicts { my ($urpm, $db, $state, $pkg, $properties, $diff_provides_h, $keep) = @_; #- examine conflicts, an existing package conflicting with this selection should #- be upgraded to a new version which will be safe, else it should be removed. foreach ($pkg->conflicts) { $keep && @$keep and last; if (my ($file) = m!^(/[^\s\[]*)!) { $db->traverse_tag('path', [ $file ], sub { $keep && @$keep and return; my ($p) = @_; if ($keep) { push @$keep, scalar $p->fullname; } else { #- all these package should be removed. set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { rejected_pkg => $p, removed => 1, from => $pkg, why => { conflicts => $file }, }); } }); } elsif (my $name = property2name($_)) { my $property = $_; $db->traverse_tag('whatprovides', [ $name ], sub { $keep && @$keep and return; my ($p) = @_; if ($p->provides_overlap($property)) { _handle_conflict($urpm, $state, $pkg, $p, $property, scalar($pkg->fullname), $properties, $diff_provides_h, $keep); } }); } } } #- side-effects: #- + those of _unselect_package_deprecated_by_property (flag_requested, flag_required, $state->{selected}, $state->{rejected}, $state->{whatrequires}, $state->{oldpackage}, $state->{unselected_uninstalled}) sub _unselect_package_deprecated_by { my ($urpm, $db, $state, $diff_provides_h, $pkg) = @_; _unselect_package_deprecated_by_property($urpm, $db, $state, $pkg, $diff_provides_h, $pkg->name, '<', $pkg->epoch . ":" . $pkg->version . "-" . $pkg->release); foreach ($pkg->obsoletes) { my ($n, $o, $v) = property2name_op_version($_) or next; #- ignore if this package obsoletes itself #- otherwise this can cause havoc if: to_install=v3, installed=v2, v3 obsoletes < v2 if ($n ne $pkg->name) { _unselect_package_deprecated_by_property($urpm, $db, $state, $pkg, $diff_provides_h, $n, $o, $v); } } } #- side-effects: $state->{oldpackage}, $state->{unselected_uninstalled} #- + those of set_rejected ($state->{rejected}) #- + those of _set_rejected_from ($state->{rejected}) #- + those of disable_selected (flag_requested, flag_required, $state->{selected}, $state->{rejected}, $state->{whatrequires}) sub _unselect_package_deprecated_by_property { my ($urpm, $db, $state, $pkg, $diff_provides_h, $n, $o, $v) = @_; #- populate avoided entries according to what is selected. foreach my $p ($urpm->packages_providing($n)) { if ($p->name eq $pkg->name) { #- all packages with the same name should now be avoided except when chosen. } else { #- in case of obsoletes, keep track of what should be avoided #- but only if package name equals the obsolete name. $p->name eq $n && (!$o || eval($p->compare($v) . $o . 0)) or next; } #- these packages are not yet selected, if they happen to be selected, #- they must first be unselected. _set_rejected_from($state, $p, $pkg); } #- examine rpm db too (but only according to package names as a fix in rpm itself) $db->traverse_tag('name', [ $n ], sub { my ($p) = @_; #- without an operator, anything (with the same name) is matched. #- with an operator, check package EVR with the obsoletes EVR. #- $satisfied is true if installed package has version newer or equal. my $comparison = $p->compare($v); my $satisfied = !$o || eval($comparison . $o . 0); my $obsoleted; if ($p->name eq $pkg->name) { #- all packages older than the current one are obsoleted, #- the others are simply removed (the result is the same). if ($o && $comparison > 0) { #- installed package is newer #- remove this package from the list of packages to install, #- unless urpmi was invoked with --allow-force (in which #- case rpm could be invoked with --oldpackage) if (!$urpm->{options}{'allow-force'}) { #- since the originally requested packages (or other #- non-installed ones) could be unselected by the following #- operation, remember them, to warn the user $state->{unselected_uninstalled} = [ grep { !$_->flag_installed; } disable_selected($urpm, $db, $state, $pkg) ]; return; } } elsif ($satisfied) { $obsoleted = 1; } } elsif ($satisfied) { $obsoleted = 1; } else { return; } set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { rejected_pkg => $p, obsoleted => $obsoleted, removed => !$obsoleted, from => $pkg, why => $obsoleted ? undef : { old_requested => 1 }, }); $obsoleted or ++$state->{oldpackage}; }); } #- side-effects: $diff_provides sub _compute_diff_provides_of_removed_pkg { my ($urpm, $state, $diff_provides_h, $p) = @_; foreach ($p->provides) { #- check differential provides between obsoleted package and newer one. my ($pn, $ps) = property2name_range($_) or next; my $not_provided = 1; foreach (grep { exists $state->{selected}{$_} } keys %{$urpm->{provides}{$pn} || {}}) { my $pp = $urpm->{depslist}[$_]; foreach ($pp->provides) { my ($ppn, $pps) = property2name_range($_) or next; $ppn eq $pn && $pps eq $ps and $not_provided = 0; } } $not_provided and $diff_provides_h->{$pn} = undef; } } #- side-effects: none sub _find_packages_obsoleting { my ($urpm, $state, $p) = @_; grep { $_ && !$_->flag_skip && $_->is_arch_compat && !exists $state->{rejected}{$_->fullname} && $_->obsoletes_overlap($p->name . " == " . $p->epoch . ":" . $p->version . "-" . $p->release) && $_->fullname ne $p->fullname && (!strict_arch($urpm) || strict_arch_check($p, $_)); } $urpm->packages_obsoleting($p->name); } #- side-effects: $properties #- + those of backtrack_selected_psel_keep ($state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) #- + those of resolve_rejected_ ($state->{rejected}, $properties) #- + those of disable_selected_and_unrequested_dependencies (flag_requested, flag_required, $state->{selected}, $state->{whatrequires}, $state->{rejected}) #- + those of _set_rejected_from ($state->{rejected}) sub _handle_diff_provides { my ($urpm, $db, $state, $properties, $diff_provides, $n, $pkg, %options) = @_; with_any_unsatisfied_requires($urpm, $db, $state, $n, sub { my ($p, $from_state, @unsatisfied) = @_; #- try if upgrading the package will be satisfying all the requires... #- there is no need to avoid promoting epoch as the package examined is not #- already installed. my @packages = find_candidate_packages_($urpm, $p->name, $state->{rejected}); @packages = grep { ($_->name eq $p->name ? $p->compare_pkg($_) < 0 : $_->obsoletes_overlap($p->name . " == " . $p->epoch . ":" . $p->version . "-" . $p->release)) && (!strict_arch($urpm) || strict_arch_check($p, $_)); } @packages; if (!@packages) { @packages = _find_packages_obsoleting($urpm, $state, $p); } if (@packages) { my $best = join('|', map { $_->id } @packages); $urpm->{debug_URPM}("promoting " . $urpm->{depslist}[$best]->fullname . " because of conflict above") if $urpm->{debug_URPM}; push @$properties, { required => $best, promote => $n, psel => $pkg }; } else { #- no package have been found, we may need to remove the package examined unless #- there exists enough packages that provided the unsatisfied requires. my @best; foreach (@unsatisfied) { my @packages = find_candidate_packages_($urpm, $_, $state->{rejected}); if (@packages = grep { $_->fullname ne $p->fullname } @packages) { push @best, join('|', map { $_->id } @packages); } } if (@best == @unsatisfied) { $urpm->{debug_URPM}("promoting " . join(' ', _ids_to_fullnames($urpm, @best)) . " because of conflict above") if $urpm->{debug_URPM}; push @$properties, map { +{ required => $_, promote => $n, psel => $pkg } } @best; } else { if ($from_state) { disable_selected_and_unrequested_dependencies($urpm, $db, $state, $p); _set_rejected_from($state, $p, $pkg); } elsif ($options{keep}) { backtrack_selected_psel_keep($urpm, $db, $state, $pkg, [ scalar $p->fullname ]); } else { my %diff_provides_h; set_rejected_and_compute_diff_provides($urpm, $state, \%diff_provides_h, { rejected_pkg => $p, removed => 1, from => $pkg, why => { unsatisfied => \@unsatisfied }, }); push @$diff_provides, map { +{ name => $_, pkg => $pkg } } keys %diff_provides_h; } } } }); } #- side-effects: $properties, $keep #- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) sub _handle_conflict { my ($urpm, $state, $pkg, $p, $property, $reason, $properties, $diff_provides_h, $keep) = @_; $urpm->{debug_URPM}("installed package " . $p->fullname . " is conflicting with " . $pkg->fullname . " (Conflicts: $property)") if $urpm->{debug_URPM}; #- the existing package will conflict with the selection; check #- whether a newer version will be ok, else ask to remove the old. my $need_deps = $p->name . " > " . ($p->epoch ? $p->epoch . ":" : "") . $p->version . "-" . $p->release; my @packages = grep { $_->name eq $p->name } find_candidate_packages_($urpm, $need_deps, $state->{rejected}); @packages = grep { ! $_->provides_overlap($property) } @packages; if (!@packages) { @packages = _find_packages_obsoleting($urpm, $state, $p); @packages = grep { ! $_->provides_overlap($property) } @packages; } if (@packages) { my $best = join('|', map { $_->id } @packages); $urpm->{debug_URPM}("promoting " . join('|', map { scalar $_->fullname } @packages) . " because of conflict above") if $urpm->{debug_URPM}; unshift @$properties, { required => $best, promote_conflicts => $reason }; } else { if ($keep) { push @$keep, scalar $p->fullname; } else { #- no package has been found, we need to remove the package examined. set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { rejected_pkg => $p, removed => 1, from => $pkg, why => { conflicts => $reason }, }); } } } #- side-effects: none sub _dep_to_name { my ($urpm, $dep) = @_; join('|', map { _id_to_name($urpm, $_) } split('\|', $dep->{required})); } #- side-effects: none sub _id_to_name { my ($urpm, $id_prop) = @_; if ($id_prop =~ /^\d+/) { my $pkg = $urpm->{depslist}[$id_prop]; $pkg && $pkg->name; } else { $id_prop; } } #- side-effects: none sub _ids_to_names { my $urpm = shift; map { $urpm->{depslist}[$_]->name } @_; } #- side-effects: none sub _ids_to_fullnames { my $urpm = shift; map { scalar $urpm->{depslist}[$_]->fullname } @_; } #- side-effects: flag_installed, flag_upgrade sub _set_flag_installed_and_upgrade_if_no_newer { my ($db, $pkg) = @_; !$pkg->flag_upgrade && !$pkg->flag_installed or return; my $upgrade = 1; $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; $pkg->set_flag_installed; $upgrade &&= $pkg->compare_pkg($p) > 0; }); $pkg->set_flag_upgrade($upgrade); } #- side-effects: #- + those of _set_rejected_old_package ($state->{rejected}) sub _no_more_recent_installed_and_providing { my ($urpm, $db, $state, $pkg, $required) = @_; my $allow = 1; $db->traverse_tag('name', [ $pkg->name ], sub { my ($p) = @_; #- allow if a less recent package is installed, if ($allow && $pkg->compare_pkg($p) <= 0) { if ($required =~ /^\d+/ || $p->provides_overlap($required)) { $urpm->{debug_URPM}("not selecting " . $pkg->fullname . " since the more recent " . $p->fullname . " is installed") if $urpm->{debug_URPM}; _set_rejected_old_package($state, $pkg, $p); $allow = 0; } else { $urpm->{debug_URPM}("the more recent " . $p->fullname . " is installed, but does not provide $required whereas " . $pkg->fullname . " does") if $urpm->{debug_URPM}; } } }); $allow; } #- do the opposite of the resolve_requested: #- unselect a package and extend to any package not requested that is no #- longer needed by any other package. #- return the packages that have been deselected. #- #- side-effects: flag_requested, flag_required, $state->{selected}, $state->{whatrequires} #- + those of _remove_all_rejected_from ($state->{rejected}) sub disable_selected { my ($urpm, $db, $state, @pkgs_todo) = @_; my @unselected; #- iterate over package needing unrequested one. while (my $pkg = shift @pkgs_todo) { exists $state->{selected}{$pkg->id} or next; #- keep a trace of what is deselected. push @unselected, $pkg; #- perform a closure on rejected packages (removed, obsoleted or avoided). my @rejected_todo = scalar $pkg->fullname; while (my $fullname = shift @rejected_todo) { push @rejected_todo, _remove_all_rejected_from($state, $fullname); } #- the package being examined has to be unselected. $urpm->{debug_URPM}("unselecting " . $pkg->fullname) if $urpm->{debug_URPM}; $pkg->set_flag_requested(0); $pkg->set_flag_required(0); delete $state->{selected}{$pkg->id}; #- determine package that requires properties no longer available, so that they need to be #- unselected too. foreach my $n ($pkg->provides_nosense) { foreach my $p (whatrequires($urpm, $state, $n)) { exists $state->{selected}{$p->id} or next; if (unsatisfied_requires($urpm, $db, $state, $p, name => $n)) { #- this package has broken dependencies and is selected. push @pkgs_todo, $p; } } } #- clean whatrequires hash. foreach ($pkg->requires_nosense) { delete $state->{whatrequires}{$_}{$pkg->id}; %{$state->{whatrequires}{$_}} or delete $state->{whatrequires}{$_}; } } #- return all unselected packages. @unselected; } #- determine dependencies that can safely been removed and are not requested #- return the packages that have been deselected. #- #- side-effects: #- + those of disable_selected (flag_requested, flag_required, $state->{selected}, $state->{whatrequires}, $state->{rejected}) sub disable_selected_and_unrequested_dependencies { my ($urpm, $db, $state, @pkgs_todo) = @_; my @all_unselected; #- disable selected packages, then extend unselection to all required packages #- no longer needed and not requested. while (my @unselected = disable_selected($urpm, $db, $state, @pkgs_todo)) { my %required; #- keep in the packages that had to be unselected. @all_unselected or push @all_unselected, @unselected; if ($urpm->{keep_unrequested_dependencies}) { last; } #- search for unrequested required packages. foreach (@unselected) { foreach ($_->requires_nosense) { foreach my $pkg (grep { $_ } $urpm->packages_providing($_)) { $state->{selected}{$pkg->id} or next; $state->{selected}{$pkg->id}{psel} && $state->{selected}{$state->{selected}{$pkg->id}{psel}->id} and next; $pkg->flag_requested and next; $required{$pkg->id} = undef; } } } #- check required packages are not needed by another selected package. foreach (keys %required) { my $pkg = $urpm->{depslist}[$_] or next; foreach ($pkg->provides_nosense) { foreach my $p_id (whatrequires_id($state, $_)) { exists $required{$p_id} and next; $state->{selected}{$p_id} and $required{$pkg->id} = 1; } } } #- now required values still undefined indicates packages than can be removed. @pkgs_todo = map { $urpm->{depslist}[$_] } grep { !$required{$_} } keys %required; } @all_unselected; } #- compute selected size by removing any removed or obsoleted package. #- #- side-effects: none sub selected_size { my ($urpm, $state) = @_; my ($size) = _selected_size_filesize($urpm, $state, 0); $size; } #- side-effects: none sub selected_size_filesize { my ($urpm, $state) = @_; _selected_size_filesize($urpm, $state, 1); } #- side-effects: none sub _selected_size_filesize { my ($urpm, $state, $compute_filesize) = @_; my ($size, $filesize, $bad_filesize); foreach (keys %{$state->{selected} || {}}) { my $pkg = $urpm->{depslist}[$_]; $size += $pkg->size; $compute_filesize or next; if (my $n = $pkg->filesize) { $filesize += $n; } elsif (!$bad_filesize) { $urpm->{debug} and $urpm->{debug}("no filesize for package " . $pkg->fullname); $bad_filesize = 1; } } foreach (values %{$state->{rejected} || {}}) { $_->{removed} || $_->{obsoleted} or next; if ($_->{size} < 0) { $size += $_->{size}; } else { $size -= $_->{size}; } } foreach (@{$state->{orphans_to_remove} || []}) { $size -= $_->size; } $size, $bad_filesize ? 0 : $filesize; } #- compute installed flags for all packages in depslist. #- #- side-effects: flag_upgrade, flag_installed sub compute_installed_flags { my ($urpm, $db) = @_; #- first pass to initialize flags installed and upgrade for all packages. foreach (@{$urpm->{depslist}}) { $_->is_arch_compat or next; $_->flag_upgrade || $_->flag_installed or $_->set_flag_upgrade; } #- second pass to set installed flag and clean upgrade flag according to installed packages. $db->traverse(sub { my ($p) = @_; #- compute flags. foreach my $pkg ($urpm->packages_providing($p->name)) { next if !defined $pkg; $pkg->is_arch_compat && $pkg->name eq $p->name or next; #- compute only installed and upgrade flags. $pkg->set_flag_installed; #- there is at least one package installed (whatever its version). $pkg->flag_upgrade and $pkg->set_flag_upgrade($pkg->compare_pkg($p) > 0); } }); } #- side-effects: flag_skip, flag_disable_obsolete sub compute_flag { my ($urpm, $pkg, %options) = @_; foreach (qw(skip disable_obsolete)) { if ($options{$_} && !$pkg->flag($_)) { $pkg->set_flag($_, 1); $options{callback} and $options{callback}->($urpm, $pkg, %options); } } } #- Adds packages flags according to an array containing packages names. #- $val is an array reference (as returned by get_packages_list) containing #- package names, or a regular expression matching against the fullname, if #- enclosed in slashes. #- %options : #- callback : sub to be called for each package where the flag is set #- skip : if true, set the 'skip' flag #- disable_obsolete : if true, set the 'disable_obsolete' flag #- #- side-effects: #- + those of compute_flag (flag_skip, flag_disable_obsolete) sub compute_flags { my ($urpm, $val, %options) = @_; if (ref $val eq 'HASH') { $val = [ keys %$val ] } #- compatibility with urpmi <= 4.5-13mdk my @regex; #- unless a regular expression is given, search in provides foreach my $name (@$val) { if ($name =~ m,^/(.*)/$,) { push @regex, $1; } else { foreach my $pkg ($urpm->packages_providing($name)) { compute_flag($urpm, $pkg, %options); } } } #- now search packages which fullname match given regexps if (@regex) { my $large_re_s = join("|", map { "(?:$_)" } @regex); my $re = qr/$large_re_s/; foreach my $pkg (@{$urpm->{depslist}}) { if ($pkg->fullname =~ $re) { compute_flag($urpm, $pkg, %options); } } } } #- side-effects: none sub _choose_best_pkg { my ($urpm, $pkg_installed, @pkgs) = @_; _choose_best_pkg_($urpm, $pkg_installed, grep { $_->compare_pkg($pkg_installed) > 0; } @pkgs); } #- side-effects: none sub _choose_best_pkg_ { my ($urpm, $pkg_installed, @pkgs) = @_; my $best; foreach my $pkg (grep { !strict_arch($urpm) || strict_arch_check($pkg_installed, $_); } @pkgs) { if (!$best || ($pkg->compare_pkg($best) || $pkg->id < $best->id) > 0) { $best = $pkg; } } $best; } #- side-effects: none sub _choose_bests_obsolete { my ($urpm, $db, $pkg_installed, @pkgs) = @_; _set_flag_installed_and_upgrade_if_no_newer($db, $_) foreach @pkgs; my %by_name; push @{$by_name{$_->name}}, $_ foreach grep { $_->flag_upgrade } @pkgs; map { _choose_best_pkg_($urpm, $pkg_installed, @$_) } values %by_name; } #- select packages to upgrade, according to package already registered. #- by default, only takes best package and its obsoleted and compute #- all installed or upgrade flag. #- (used for --auto-select) #- #- side-effects: $requisted, flag_installed, flag_upgrade sub request_packages_to_upgrade { my ($urpm, $db, $state, $requested, %options) = @_; my %by_name; #- now we can examine all existing packages to find packages to upgrade. $db->traverse(sub { my ($pkg_installed) = @_; my $name = $pkg_installed->name; my $pkg; if (exists $by_name{$name}) { if (my $p = $by_name{$name}) { #- here a pkg with the same name is installed twice if ($p->compare_pkg($pkg_installed) > 0) { #- we selected $p, and it is still a valid choice $pkg = $p; } else { #- $p is no good since $pkg_installed is higher version, } } } elsif ($pkg = _choose_best_pkg($urpm, $pkg_installed, $urpm->packages_by_name($name))) { #- first try with package using the same name. $pkg->set_flag_installed; $pkg->set_flag_upgrade; } if (my @pkgs = _choose_bests_obsolete($urpm, $db, $pkg_installed, _find_packages_obsoleting($urpm, $state, $pkg_installed))) { if (@pkgs == 1) { $pkg and $urpm->{debug_URPM}("auto-select: prefering " . $pkgs[0]->fullname . " obsoleting " . $pkg_installed->fullname . " over " . $pkg->fullname) if $urpm->{debug_URPM}; $pkg = $pkgs[0]; } elsif (@pkgs > 1) { $urpm->{debug_URPM}("auto-select: multiple packages (" . join(' ', map { scalar $_->fullname } @pkgs) . ") obsoleting " . $pkg_installed->fullname) if $urpm->{debug_URPM}; $pkg = undef; } } if ($pkg && $options{idlist} && !grep { $pkg->id == $_ } @{$options{idlist}}) { $urpm->{debug_URPM}("not auto-selecting " . $pkg->fullname . "because it's not in search medias") if $urpm->{debug_URPM}; $pkg = undef; } $pkg and $urpm->{debug_URPM}("auto-select: adding " . $pkg->fullname . " replacing " . $pkg_installed->fullname) if $urpm->{debug_URPM}; $by_name{$name} = $pkg; }); foreach my $pkg (values %by_name) { $pkg or next; $pkg->set_flag_upgrade; $requested->{$pkg->id} = $options{requested}; } $requested; } #- side-effects: none sub _sort_by_dependencies_get_graph { my ($urpm, $state, $l) = @_; my %edges; foreach my $id (@$l) { my $pkg = $urpm->{depslist}[$id]; my @provides = map { whatrequires_id($state, $_) } $pkg->provides_nosense; if (my $from = $state->{selected}{$id}{from}) { unshift @provides, $from->id; } $edges{$id} = [ uniq(@provides) ]; } \%edges; } #- side-effects: none sub reverse_multi_hash { my ($h) = @_; my %r; my ($k, $v); while (($k, $v) = each %$h) { push @{$r{$_}}, $k foreach @$v; } \%r; } sub _merge_2_groups { my ($groups, $l1, $l2) = @_; my $l = [ @$l1, @$l2 ]; $groups->{$_} = $l foreach @$l; $l; } sub _add_group { my ($groups, $group) = @_; my ($main, @other) = uniq(grep { $_ } map { $groups->{$_} } @$group); $main ||= []; if (@other) { $main = _merge_2_groups($groups, $main, $_) foreach @other; } foreach (grep { !$groups->{$_} } @$group) { $groups->{$_} ||= $main; push @$main, $_; my @l_ = uniq(@$main); @l_ == @$main or die ''; } # warn "# groups: ", join(' ', map { join('+', @$_) } uniq(values %$groups)), "\n"; } #- nb: this handles $nodes list not containing all $nodes that can be seen in $edges #- #- side-effects: none sub sort_graph { my ($nodes, $edges) = @_; #require Data::Dumper; #warn Data::Dumper::Dumper($nodes, $edges); my %nodes_h = map { $_ => 1 } @$nodes; my (%loops, %added, @sorted); my $recurse; $recurse = sub { my ($id, @ids) = @_; # warn "# recurse $id @ids\n"; my $loop_ahead; foreach my $p_id (@{$edges->{$id}}) { if ($p_id == $id) { # don't care } elsif (exists $added{$p_id}) { # already done } elsif (grep { $_ == $p_id } @ids) { my $begin = 1; my @l = grep { $begin &&= $_ != $p_id } @ids; $loop_ahead = 1; _add_group(\%loops, [ $p_id, $id, @l ]); } elsif ($loops{$p_id}) { my $take; if (my @l = grep { $take ||= $loops{$_} && $loops{$_} == $loops{$p_id} } reverse @ids) { $loop_ahead = 1; # warn "# loop to existing one $p_id, $id, @l\n"; _add_group(\%loops, [ $p_id, $id, @l ]); } } else { $recurse->($p_id, $id, @ids); #- we would need to compute loop_ahead. we will do it below only once, and if not already set } } if (!$loop_ahead && $loops{$id} && grep { exists $loops{$_} && $loops{$_} == $loops{$id} } @ids) { $loop_ahead = 1; } if (!$loop_ahead) { #- it's now a leaf or a loop we're done with my @toadd = $loops{$id} ? @{$loops{$id}} : $id; $added{$_} = undef foreach @toadd; # warn "# adding ", join('+', @toadd), " for $id\n"; push @sorted, [ uniq(grep { $nodes_h{$_} } @toadd) ]; } }; !exists $added{$_} and $recurse->($_) foreach @$nodes; # warn "# result: ", join(' ', map { join('+', @$_) } @sorted), "\n"; check_graph_is_sorted(\@sorted, $nodes, $edges) or die "sort_graph failed"; @sorted; } #- side-effects: none sub check_graph_is_sorted { my ($sorted, $nodes, $edges) = @_; my $i = 1; my %nb; foreach (@$sorted) { $nb{$_} = $i foreach @$_; $i++; } my $nb_errors = 0; my $error = sub { $nb_errors++; warn "error: $_[0]\n" }; foreach my $id (@$nodes) { $nb{$id} or $error->("missing $id in sort_graph list"); } foreach my $id (keys %$edges) { my $id_i = $nb{$id} or next; foreach my $req (@{$edges->{$id}}) { my $req_i = $nb{$req} or next; $req_i <= $id_i or $error->("$req should be before $id ($req_i $id_i)"); } } $nb_errors == 0; } #- side-effects: none sub _sort_by_dependencies__add_obsolete_edges { my ($urpm, $state, $l, $requires) = @_; my @obsoletes = grep { $_->{obsoleted} } values %{$state->{rejected}} or return; my @groups = grep { @$_ > 1 } map { [ keys %{$_->{closure}} ] } @obsoletes; my %groups; foreach my $group (@groups) { _add_group(\%groups, $group); foreach (@$group) { my $rej = $state->{rejected}{$_} or next; _add_group(\%groups, [ $_, keys %{$rej->{closure}} ]); } } my %fullnames = map { scalar($urpm->{depslist}[$_]->fullname) => $_ } @$l; foreach my $group (uniq(values %groups)) { my @group = grep { defined $_ } map { $fullnames{$_} } @$group; foreach (@group) { @{$requires->{$_}} = uniq(@{$requires->{$_}}, @group); } } } #- side-effects: none sub sort_by_dependencies { my ($urpm, $state, @list_unsorted) = @_; @list_unsorted = sort { $a <=> $b } @list_unsorted; # sort by ids to be more reproductable $urpm->{debug_URPM}("getting graph of dependencies for sorting") if $urpm->{debug_URPM}; my $edges = _sort_by_dependencies_get_graph($urpm, $state, \@list_unsorted); my $requires = reverse_multi_hash($edges); _sort_by_dependencies__add_obsolete_edges($urpm, $state, \@list_unsorted, $requires); $urpm->{debug_URPM}("sorting graph of dependencies") if $urpm->{debug_URPM}; sort_graph(\@list_unsorted, $requires); } sub sorted_rpms_to_string { my ($urpm, @sorted) = @_; "rpms sorted by dependencies:\n" . join("\n", map { join('+', _ids_to_names($urpm, @$_)); } @sorted); } #- build transaction set for given selection #- options: start, end, idlist, split_length, keep #- #- side-effects: $state->{transaction}, $state->{transaction_state} sub build_transaction_set { my ($urpm, $db, $state, %options) = @_; #- clean transaction set. $state->{transaction} = []; my %selected_id; @selected_id{$urpm->build_listid($options{start}, $options{end}, $options{idlist})} = (); if ($options{split_length}) { #- first step consists of sorting packages according to dependencies. my @sorted = sort_by_dependencies($urpm, $state, keys(%selected_id) > 0 ? (grep { exists($selected_id{$_}) } keys %{$state->{selected}}) : keys %{$state->{selected}}); $urpm->{debug_URPM}(sorted_rpms_to_string($urpm, @sorted)) if $urpm->{debug_URPM}; #- second step consists of re-applying resolve_requested in the same #- order computed in first step and to update a list of packages to #- install, to upgrade and to remove. my %examined; my @todo = @sorted; while (@todo) { my @ids; while (@todo && @ids < $options{split_length}) { my $l = shift @todo; push @ids, @$l; } my %requested = map { $_ => undef } @ids; resolve_requested__no_suggests_($urpm, $db, $state->{transaction_state} ||= {}, \%requested, defined $options{start} ? (start => $options{start}) : @{[]}, defined $options{end} ? (end => $options{end}) : @{[]}, keep => $options{keep}, ); my @upgrade = grep { ! exists $examined{$_} } keys %{$state->{transaction_state}{selected}}; my @remove = grep { ! exists $examined{$_} } packages_to_remove($state->{transaction_state}); @upgrade || @remove or next; if (my @bad_remove = grep { !$state->{rejected}{$_}{removed} || $state->{rejected}{$_}{obsoleted} } @remove) { $urpm->{error}(sorted_rpms_to_string($urpm, @sorted)) if $urpm->{error}; $urpm->{error}('transaction is too small: ' . join(' ', @bad_remove) . ' is rejected but it should not (current transaction: ' . join(' ', _ids_to_fullnames($urpm, @upgrade)) . ', requested: ' . join('+', _ids_to_fullnames($urpm, @ids)) . ')') if $urpm->{error}; $state->{transaction} = []; last; } $urpm->{debug_URPM}(sprintf('transaction valid: remove=%s update=%s', join(',', @remove), join(',', _ids_to_names($urpm, @upgrade)))) if $urpm->{debug_URPM}; $examined{$_} = undef foreach @upgrade, @remove; push @{$state->{transaction}}, { upgrade => \@upgrade, remove => \@remove }; } #- check that the transaction set has been correctly created. #- (ie that no other package was removed) if (keys(%{$state->{selected}}) == keys(%{$state->{transaction_state}{selected}}) && listlength(packages_to_remove($state)) == listlength(packages_to_remove($state->{transaction_state})) ) { foreach (keys(%{$state->{selected}})) { exists $state->{transaction_state}{selected}{$_} and next; $urpm->{error}('using one big transaction') if $urpm->{error}; $state->{transaction} = []; last; } foreach (packages_to_remove($state)) { $state->{transaction_state}{rejected}{$_}{removed} && !$state->{transaction_state}{rejected}{$_}{obsoleted} and next; $urpm->{error}('using one big transaction') if $urpm->{error}; $state->{transaction} = []; last; } } } #- fallback if something can be selected but nothing has been allowed in transaction list. if (%{$state->{selected} || {}} && !@{$state->{transaction}}) { $urpm->{debug_URPM}('using one big transaction') if $urpm->{debug_URPM}; push @{$state->{transaction}}, { upgrade => [ keys %{$state->{selected}} ], remove => [ packages_to_remove($state) ], }; } if ($state->{orphans_to_remove}) { my @l = map { scalar $_->fullname } @{$state->{orphans_to_remove}}; push @{$state->{transaction}}, { remove => \@l }; } $state->{transaction}; } 1;