| 1 |
package URPM; |
| 2 |
#package URPM::Resolve; |
| 3 |
#use URPM; |
| 4 |
|
| 5 |
# $Id: Resolve.pm 270395 2010-07-30 00:55:59Z nanardon $ |
| 6 |
|
| 7 |
use strict; |
| 8 |
use warnings; |
| 9 |
use Config; |
| 10 |
|
| 11 |
# perl_checker: require URPM |
| 12 |
|
| 13 |
#- a few functions from MDK::Common copied here: |
| 14 |
sub any(&@) { |
| 15 |
my $f = shift; |
| 16 |
$f->($_) and return 1 foreach @_; |
| 17 |
0; |
| 18 |
} |
| 19 |
sub listlength { |
| 20 |
my (@l) = @_; |
| 21 |
scalar @l; |
| 22 |
} |
| 23 |
sub uniq { |
| 24 |
my (@l) = @_; |
| 25 |
my %l; |
| 26 |
$l{$_} = 1 foreach @l; |
| 27 |
grep { delete $l{$_} } @l; |
| 28 |
} |
| 29 |
sub find(&@) { |
| 30 |
my $f = shift; |
| 31 |
$f->($_) and return $_ foreach @_; |
| 32 |
undef; |
| 33 |
} |
| 34 |
|
| 35 |
#- property2name* functions below parse things like "mageia-release[>= 1]" |
| 36 |
#- which is the format returned by URPM.xs for ->requires, ->provides, ->conflicts... |
| 37 |
sub property2name { |
| 38 |
my ($property) = @_; |
| 39 |
$property =~ /^([^\s\[]*)/ && $1; |
| 40 |
} |
| 41 |
|
| 42 |
sub property2name_range { |
| 43 |
my ($property) = @_; |
| 44 |
$property =~ /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/; |
| 45 |
} |
| 46 |
|
| 47 |
sub property2name_op_version { |
| 48 |
my ($property) = @_; |
| 49 |
$property =~ /^([^\s\[]*)(?:\[\*\])?\s*\[?([^\s\]]*)\s*([^\s\]]*)/; |
| 50 |
} |
| 51 |
|
| 52 |
#- wrappers around $state (cf "The $state object" in "perldoc URPM") |
| 53 |
sub packages_to_remove { |
| 54 |
my ($state) = @_; |
| 55 |
grep { |
| 56 |
$state->{rejected}{$_}{removed} && !$state->{rejected}{$_}{obsoleted}; |
| 57 |
} keys %{$state->{rejected} || {}}; |
| 58 |
} |
| 59 |
sub removed_or_obsoleted_packages { |
| 60 |
my ($state) = @_; |
| 61 |
grep { |
| 62 |
$state->{rejected}{$_}{removed} || $state->{rejected}{$_}{obsoleted}; |
| 63 |
} keys %{$state->{rejected} || {}}; |
| 64 |
} |
| 65 |
|
| 66 |
#- Find candidates packages from a require string (or id). |
| 67 |
#- Takes care of choices using the '|' separator. |
| 68 |
#- (nb: see also find_required_package()) |
| 69 |
#- |
| 70 |
#- side-effects: none |
| 71 |
sub find_candidate_packages { |
| 72 |
my ($urpm, $id_prop, $o_rejected) = @_; |
| 73 |
my @packages; |
| 74 |
|
| 75 |
foreach (split /\|/, $id_prop) { |
| 76 |
if (/^\d+$/) { |
| 77 |
my $pkg = $urpm->{depslist}[$_]; |
| 78 |
$pkg->flag_skip and next; |
| 79 |
$pkg->arch eq 'src' || $pkg->is_arch_compat or next; |
| 80 |
$o_rejected && exists $o_rejected->{$pkg->fullname} and next; |
| 81 |
push @packages, $pkg; |
| 82 |
} elsif (my $name = property2name($_)) { |
| 83 |
my $property = $_; |
| 84 |
foreach (keys %{$urpm->{provides}{$name} || {}}) { |
| 85 |
my $pkg = $urpm->{depslist}[$_]; |
| 86 |
$pkg->flag_skip and next; |
| 87 |
$pkg->is_arch_compat or next; |
| 88 |
$o_rejected && exists $o_rejected->{$pkg->fullname} and next; |
| 89 |
#- check if at least one provide of the package overlap the property. |
| 90 |
!$urpm->{provides}{$name}{$_} || $pkg->provides_overlap($property) |
| 91 |
and push @packages, $pkg; |
| 92 |
} |
| 93 |
} |
| 94 |
} |
| 95 |
@packages; |
| 96 |
} |
| 97 |
|
| 98 |
#- returns the "arch" of package $n in rpm db |
| 99 |
sub get_installed_arch { |
| 100 |
my ($db, $n) = @_; |
| 101 |
my $arch; |
| 102 |
$db->traverse_tag_find('name', $n, sub { $arch = $_[0]->arch; 1 }); |
| 103 |
$arch; |
| 104 |
} |
| 105 |
|
| 106 |
#- is "strict-arch" wanted? (cf "man urpmi") |
| 107 |
#- since it's slower we only force it on bi-arch |
| 108 |
sub strict_arch { |
| 109 |
my ($urpm) = @_; |
| 110 |
defined $urpm->{options}{'strict-arch'} ? $urpm->{options}{'strict-arch'} : $Config{archname} =~ /x86_64|sparc64|ppc64/; |
| 111 |
} |
| 112 |
my %installed_arch; |
| 113 |
|
| 114 |
#- checks wether $pkg could be installed under strict-arch policy |
| 115 |
#- (ie check wether $pkg->name with different arch is not installed) |
| 116 |
#- |
| 117 |
#- side-effects: none (but uses a cache) |
| 118 |
sub strict_arch_check_installed { |
| 119 |
my ($db, $pkg) = @_; |
| 120 |
my $arch = $pkg->arch; |
| 121 |
if ($arch ne 'src' && $arch ne 'noarch') { |
| 122 |
my $n = $pkg->name; |
| 123 |
defined $installed_arch{$n} or $installed_arch{$n} = get_installed_arch($db, $n); |
| 124 |
if ($installed_arch{$n} && $installed_arch{$n} ne 'noarch') { |
| 125 |
$arch eq $installed_arch{$n} or return; |
| 126 |
} |
| 127 |
} |
| 128 |
1; |
| 129 |
} |
| 130 |
|
| 131 |
#- check wether $installed_pkg and $pkg have same arch |
| 132 |
#- (except for src/noarch of course) |
| 133 |
#- |
| 134 |
#- side-effects: none |
| 135 |
sub strict_arch_check { |
| 136 |
my ($installed_pkg, $pkg) = @_; |
| 137 |
my $arch = $pkg->arch; |
| 138 |
if ($arch ne 'src' && $arch ne 'noarch') { |
| 139 |
my $inst_arch = $installed_pkg->arch; |
| 140 |
if ($inst_arch ne 'noarch') { |
| 141 |
$arch eq $inst_arch or return; |
| 142 |
} |
| 143 |
} |
| 144 |
1; |
| 145 |
} |
| 146 |
|
| 147 |
#- is $pkg->name installed? |
| 148 |
#- |
| 149 |
#- side-effects: none |
| 150 |
sub is_package_installed { |
| 151 |
my ($db, $pkg) = @_; |
| 152 |
|
| 153 |
my $found; |
| 154 |
$db->traverse_tag_find('name', $pkg->name, sub { |
| 155 |
my ($p) = @_; |
| 156 |
$found ||= $p->fullname eq $pkg->fullname; |
| 157 |
}); |
| 158 |
$found; |
| 159 |
} |
| 160 |
|
| 161 |
sub _is_selected_or_installed { |
| 162 |
my ($urpm, $db, $name) = @_; |
| 163 |
|
| 164 |
(grep { $_->flag_available } $urpm->packages_providing($name)) > 0 || |
| 165 |
$db->traverse_tag('name', [ $name ], undef) > 0; |
| 166 |
} |
| 167 |
|
| 168 |
#- finds $pkg "provides" that matches $provide_name, and returns the version provided |
| 169 |
#- eg: $pkg provides "a = 3", $provide_name is "a > 1", returns "3" |
| 170 |
sub provided_version_that_overlaps { |
| 171 |
my ($pkg, $provide_name) = @_; |
| 172 |
|
| 173 |
my $version; |
| 174 |
foreach my $property ($pkg->provides) { |
| 175 |
my ($n, undef, $v) = property2name_op_version($property) or next; |
| 176 |
$n eq $provide_name or next; |
| 177 |
|
| 178 |
if ($version) { |
| 179 |
$version = $v if URPM::rpmvercmp($v, $version) > 0; |
| 180 |
} else { |
| 181 |
$version = $v; |
| 182 |
} |
| 183 |
} |
| 184 |
$version; |
| 185 |
} |
| 186 |
|
| 187 |
#- find the package (or packages) to install matching $id_prop |
| 188 |
#- returns (list ref of matches, list ref of preferred matches) |
| 189 |
#- (see also find_candidate_packages()) |
| 190 |
#- |
| 191 |
#- side-effects: flag_install, flag_upgrade (and strict_arch_check_installed cache) |
| 192 |
sub find_required_package { |
| 193 |
my ($urpm, $db, $state, $id_prop) = @_; |
| 194 |
my (%packages, %provided_version); |
| 195 |
my $strict_arch = strict_arch($urpm); |
| 196 |
|
| 197 |
my $may_add_to_packages = sub { |
| 198 |
my ($pkg) = @_; |
| 199 |
|
| 200 |
if (my $p = $packages{$pkg->name}) { |
| 201 |
$pkg->flag_requested > $p->flag_requested || |
| 202 |
$pkg->flag_requested == $p->flag_requested && $pkg->compare_pkg($p) > 0 and $packages{$pkg->name} = $pkg; |
| 203 |
} else { |
| 204 |
$packages{$pkg->name} = $pkg; |
| 205 |
} |
| 206 |
}; |
| 207 |
|
| 208 |
#- search for possible packages, try to be as fast as possible, backtrack can be longer. |
| 209 |
foreach (split /\|/, $id_prop) { |
| 210 |
if (/^\d+$/) { |
| 211 |
my $pkg = $urpm->{depslist}[$_]; |
| 212 |
$pkg->arch eq 'src' || $pkg->is_arch_compat or next; |
| 213 |
$pkg->flag_skip || $state->{rejected}{$pkg->fullname} and next; |
| 214 |
#- determine if this package is better than a possibly previously chosen package. |
| 215 |
$pkg->flag_selected || exists $state->{selected}{$pkg->id} and return [$pkg]; |
| 216 |
!$strict_arch || strict_arch_check_installed($db, $pkg) or next; |
| 217 |
$may_add_to_packages->($pkg); |
| 218 |
} elsif (my $name = property2name($_)) { |
| 219 |
my $property = $_; |
| 220 |
foreach my $pkg (packages_providing($urpm, $name)) { |
| 221 |
$pkg->is_arch_compat or next; |
| 222 |
$pkg->flag_skip || $state->{rejected}{$pkg->fullname} and next; |
| 223 |
#- check if at least one provide of the package overlaps the property |
| 224 |
if (!$urpm->{provides}{$name}{$pkg->id} || $pkg->provides_overlap($property)) { |
| 225 |
#- determine if this package is better than a possibly previously chosen package. |
| 226 |
$pkg->flag_selected || exists $state->{selected}{$pkg->id} and return [$pkg]; |
| 227 |
!$strict_arch || strict_arch_check_installed($db, $pkg) or next; |
| 228 |
$provided_version{$pkg} = provided_version_that_overlaps($pkg, $name); |
| 229 |
$may_add_to_packages->($pkg); |
| 230 |
} |
| 231 |
} |
| 232 |
} |
| 233 |
} |
| 234 |
my @packages = values %packages; |
| 235 |
|
| 236 |
if (@packages > 1) { |
| 237 |
#- packages should be preferred if one of their provides is referenced |
| 238 |
#- in the "requested" hash, or if the package itself is requested (or |
| 239 |
#- required). |
| 240 |
#- If there is no preference, choose the first one by default (higher |
| 241 |
#- probability of being chosen) and ask the user. |
| 242 |
#- Packages with more compatibles architectures are always preferred. |
| 243 |
#- Puts the results in @chosen. Other are left unordered. |
| 244 |
foreach my $pkg (@packages) { |
| 245 |
_set_flag_installed_and_upgrade_if_no_newer($db, $pkg); |
| 246 |
} |
| 247 |
|
| 248 |
if (my @kernel_source = _find_required_package__kernel_source($urpm, $db, \@packages)) { |
| 249 |
$urpm->{debug_URPM}("packageCallbackChoices: kernel source chosen " . join(",", map { $_->name } @kernel_source) . " in " . join(",", map { $_->name } @packages)) if $urpm->{debug_URPM}; |
| 250 |
return \@kernel_source, \@kernel_source; |
| 251 |
} |
| 252 |
if (my @kmod = _find_required_package__kmod($urpm, $db, \@packages)) { |
| 253 |
$urpm->{debug_URPM}("packageCallbackChoices: kmod packages " . join(",", map { $_->name } @kmod) . " in " . join(",", map { $_->name } @packages)) if $urpm->{debug_URPM}; |
| 254 |
return \@kmod, \@kmod; |
| 255 |
} |
| 256 |
|
| 257 |
_find_required_package__sort($urpm, $db, \@packages, \%provided_version); |
| 258 |
} else { |
| 259 |
\@packages; |
| 260 |
} |
| 261 |
} |
| 262 |
|
| 263 |
# nb: _set_flag_installed_and_upgrade_if_no_newer must be done on $packages |
| 264 |
sub _find_required_package__sort { |
| 265 |
my ($urpm, $db, $packages, $provided_version) = @_; |
| 266 |
|
| 267 |
my ($best, @other) = sort { |
| 268 |
$a->[1] <=> $b->[1] #- we want the lowest (ie preferred arch) |
| 269 |
|| $b->[2] <=> $a->[2]; #- and the higher score |
| 270 |
} map { |
| 271 |
my $score = 0; |
| 272 |
$score += 2 if $_->flag_requested; |
| 273 |
$score += $_->flag_upgrade ? 1 : -1 if $_->flag_installed; |
| 274 |
[ $_, $_->is_arch_compat, $score ]; |
| 275 |
} @$packages; |
| 276 |
|
| 277 |
my @chosen_with_score = ($best, grep { $_->[1] == $best->[1] && $_->[2] == $best->[2] } @other); |
| 278 |
my @chosen = map { $_->[0] } @chosen_with_score; |
| 279 |
|
| 280 |
#- return immediately if there is only one chosen package |
| 281 |
return \@chosen if @chosen == 1; |
| 282 |
|
| 283 |
#- if several packages were selected to match a requested installation, |
| 284 |
#- and if --more-choices wasn't given, trim the choices to the first one. |
| 285 |
if (!$urpm->{options}{morechoices} && $chosen_with_score[0][2] == 3) { |
| 286 |
return [ $chosen[0] ]; |
| 287 |
} |
| 288 |
|
| 289 |
if ($urpm->{media}) { |
| 290 |
@chosen_with_score = sort { |
| 291 |
$a->[2] != $b->[2] ? |
| 292 |
$a->[0]->id <=> $b->[0]->id : |
| 293 |
$b->[1] <=> $a->[1] || $b->[0]->compare_pkg($a->[0]); |
| 294 |
} map { [ $_, _score_for_locales($urpm, $db, $_), pkg2media($urpm->{media}, $_) ] } @chosen; |
| 295 |
} else { |
| 296 |
# obsolete code which should not happen, kept just in case |
| 297 |
$urpm->{debug_URPM}("can't sort choices by media") if $urpm->{debug_URPM}; |
| 298 |
@chosen_with_score = sort { |
| 299 |
$b->[1] <=> $a->[1] || |
| 300 |
$b->[0]->compare_pkg($a->[0]) || $a->[0]->id <=> $b->[0]->id; |
| 301 |
} map { [ $_, _score_for_locales($urpm, $db, $_) ] } @chosen; |
| 302 |
} |
| 303 |
if (!$urpm->{options}{morechoices}) { |
| 304 |
if (my @valid_locales = grep { $_->[1] } @chosen_with_score) { |
| 305 |
#- get rid of invalid locales |
| 306 |
@chosen_with_score = @valid_locales; |
| 307 |
} |
| 308 |
} |
| 309 |
# propose to select all packages for installed locales |
| 310 |
my @prefered = grep { $_->[1] == 3 } @chosen_with_score; |
| 311 |
|
| 312 |
@chosen = map { $_->[0] } @chosen_with_score; |
| 313 |
if (%$provided_version) { |
| 314 |
# highest provided version first |
| 315 |
# (nb: this sort overrules the sort on media (cf ->id above)) |
| 316 |
@chosen = sort { URPM::rpmvercmp($provided_version->{$b} || 0, $provided_version->{$a} || 0) } @chosen; |
| 317 |
} |
| 318 |
\@chosen, [ map { $_->[0] } @prefered ]; |
| 319 |
} |
| 320 |
|
| 321 |
#- prefer the pkgs corresponding to installed/selected kernels |
| 322 |
sub _find_required_package__kernel_source { |
| 323 |
my ($urpm, $db, $choices) = @_; |
| 324 |
|
| 325 |
$choices->[0]->name =~ /^kernel-(.*source-|.*-devel-)/ or return; |
| 326 |
|
| 327 |
grep { |
| 328 |
if ($_->name =~ /^kernel-.*source-stripped-(.*)/) { |
| 329 |
my $version = quotemeta($1); |
| 330 |
find { |
| 331 |
$_->name =~ /-$version$/ && ($_->flag_installed || $_->flag_selected); |
| 332 |
} $urpm->packages_providing('kernel'); |
| 333 |
} elsif ($_->name =~ /(kernel-.*)-devel-(.*)/) { |
| 334 |
my $kernel = "$1-$2"; |
| 335 |
_is_selected_or_installed($urpm, $db, $kernel); |
| 336 |
} elsif ($_->name =~ /^kernel-.*source-/) { |
| 337 |
#- hopefully we don't have a media with kernel-source but not kernel-source-stripped nor kernel-.*-devel |
| 338 |
0; |
| 339 |
} else { |
| 340 |
$urpm->{debug_URPM}("unknown kernel-source package " . $_->fullname) if $urpm->{debug_URPM}; |
| 341 |
0; |
| 342 |
} |
| 343 |
} @$choices; |
| 344 |
} |
| 345 |
|
| 346 |
#- prefer the pkgs corresponding to installed/selected kernels |
| 347 |
sub _find_required_package__kmod { |
| 348 |
my ($urpm, $db, $choices) = @_; |
| 349 |
|
| 350 |
$choices->[0]->name =~ /^dkms-|-kernel-\d\./ or return; |
| 351 |
|
| 352 |
grep { |
| 353 |
if (my ($version, $flavor, $release) = $_->name =~ /(?:.*)-kernel-(\d\..*)-(.*)-(.*)/) { |
| 354 |
my $kernel = "kernel-$flavor-$version-$release"; |
| 355 |
_is_selected_or_installed($urpm, $db, $kernel); |
| 356 |
} elsif ($_->name =~ /^dkms-/) { |
| 357 |
0; # we prefer precompiled dkms |
| 358 |
} else { |
| 359 |
$urpm->{debug_URPM}("unknown kmod package " . $_->fullname) if $urpm->{debug_URPM}; |
| 360 |
0; |
| 361 |
} |
| 362 |
} @$choices; |
| 363 |
} |
| 364 |
|
| 365 |
#- Packages that require locales-xxx when the corresponding locales are |
| 366 |
#- already installed should be preferred over packages that require locales |
| 367 |
#- which are not installed. |
| 368 |
#- |
| 369 |
#- eg: locales-fr & locales-de are installed, |
| 370 |
#- prefer firefox-fr & firefox-de which respectively require locales-fr & locales-de |
| 371 |
sub _score_for_locales { |
| 372 |
my ($urpm, $db, $pkg) = @_; |
| 373 |
|
| 374 |
my @r = $pkg->requires_nosense; |
| 375 |
|
| 376 |
if (my ($specific_locales) = grep { /locales-(?!en)/ } @r) { |
| 377 |
if (_is_selected_or_installed($urpm, $db, $specific_locales)) { |
| 378 |
3; # good locale |
| 379 |
} else { |
| 380 |
0; # bad locale |
| 381 |
} |
| 382 |
} elsif (any { /locales-en/ } @r) { |
| 383 |
2; # |
| 384 |
} else { |
| 385 |
1; |
| 386 |
} |
| 387 |
} |
| 388 |
|
| 389 |
#- side-effects: $properties, $choices |
| 390 |
#- + those of backtrack_selected ($state->{backtrack}, $state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) |
| 391 |
sub _choose_required { |
| 392 |
my ($urpm, $db, $state, $dep, $properties, $choices, $diff_provides, %options) = @_; |
| 393 |
|
| 394 |
#- take the best choice possible. |
| 395 |
my ($chosen, $prefered) = find_required_package($urpm, $db, $state, $dep->{required}); |
| 396 |
|
| 397 |
#- If no choice is found, this means that nothing can be possibly selected |
| 398 |
#- according to $dep, so we need to retry the selection, allowing all |
| 399 |
#- packages that conflict or anything similar to see which strategy can be |
| 400 |
#- tried. Backtracking is used to avoid trying multiple times the same |
| 401 |
#- packages. If multiple packages are possible and properties is not |
| 402 |
#- empty, postpone the choice for a later time as one of the packages |
| 403 |
#- may be selected for another reason. Otherwise simply ask the user which |
| 404 |
#- one to choose; else take the first one available. |
| 405 |
if (!@$chosen) { |
| 406 |
$urpm->{debug_URPM}("no packages match " . _dep_to_name($urpm, $dep) . " (it is either in skip.list or already rejected)") if $urpm->{debug_URPM}; |
| 407 |
unshift @$properties, backtrack_selected($urpm, $db, $state, $dep, $diff_provides, %options); |
| 408 |
return; #- backtrack code choose to continue with same package or completely new strategy. |
| 409 |
} elsif (@$chosen > 1) { |
| 410 |
if (@$properties) { |
| 411 |
unshift @$choices, $dep; |
| 412 |
return; |
| 413 |
} elsif ($options{callback_choices}) { |
| 414 |
my @l = grep { ref $_ } $options{callback_choices}->($urpm, $db, $state, $chosen, _dep_to_name($urpm, $dep), $prefered); |
| 415 |
$urpm->{debug_URPM}("replacing " . _dep_to_name($urpm, $dep) . " with " . |
| 416 |
join(' ', map { $_->name } @l)) if $urpm->{debug_URPM}; |
| 417 |
unshift @$properties, map { |
| 418 |
+{ |
| 419 |
required => $_->id, |
| 420 |
_choices => $dep->{required}, |
| 421 |
exists $dep->{from} ? (from => $dep->{from}) : @{[]}, |
| 422 |
exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, |
| 423 |
}; |
| 424 |
} @l; |
| 425 |
return; #- always redo according to choices. |
| 426 |
} |
| 427 |
} |
| 428 |
|
| 429 |
|
| 430 |
#- now do the real work, select the package. |
| 431 |
my $pkg = shift @$chosen; |
| 432 |
if ($urpm->{debug_URPM} && $pkg->name ne _dep_to_name($urpm, $dep)) { |
| 433 |
$urpm->{debug_URPM}("chosen " . $pkg->fullname . " for " . _dep_to_name($urpm, $dep)); |
| 434 |
@$chosen and $urpm->{debug_URPM}(" (it could also have chosen " . join(' ', map { scalar $_->fullname } @$chosen)); |
| 435 |
} |
| 436 |
|
| 437 |
$pkg; |
| 438 |
} |
| 439 |
|
| 440 |
sub pkg2media { |
| 441 |
my ($mediums, $p) = @_; |
| 442 |
my $id = $p->id; |
| 443 |
#- || 0 to avoid undef, but is it normal to have undef ? |
| 444 |
find { $id >= ($_->{start} || 0) && $id <= ($_->{end} || 0) } @$mediums; |
| 445 |
} |
| 446 |
|
| 447 |
sub whatrequires { |
| 448 |
my ($urpm, $state, $property_name) = @_; |
| 449 |
|
| 450 |
map { $urpm->{depslist}[$_] } whatrequires_id($state, $property_name); |
| 451 |
} |
| 452 |
sub whatrequires_id { |
| 453 |
my ($state, $property_name) = @_; |
| 454 |
|
| 455 |
keys %{$state->{whatrequires}{$property_name} || {}}; |
| 456 |
} |
| 457 |
|
| 458 |
#- return unresolved requires of a package (a new one or an existing one). |
| 459 |
#- |
| 460 |
#- side-effects: none (but uses a $state->{cached_installed}) |
| 461 |
sub unsatisfied_requires { |
| 462 |
my ($urpm, $db, $state, $pkg, %options) = @_; |
| 463 |
my %unsatisfied; |
| 464 |
|
| 465 |
#- all requires should be satisfied according to selected packages or installed packages, |
| 466 |
#- or the package itself. |
| 467 |
REQUIRES: foreach my $prop ($pkg->requires) { |
| 468 |
my ($n, $s) = property2name_range($prop) or next; |
| 469 |
|
| 470 |
if (defined $options{name} && $n ne $options{name}) { |
| 471 |
#- allow filtering on a given name (to speed up some search). |
| 472 |
} elsif (exists $unsatisfied{$prop}) { |
| 473 |
#- avoid recomputing the same all the time. |
| 474 |
} else { |
| 475 |
#- check for installed packages in the installed cache. |
| 476 |
foreach (keys %{$state->{cached_installed}{$n} || {}}) { |
| 477 |
exists $state->{rejected}{$_} and next; |
| 478 |
next REQUIRES; |
| 479 |
} |
| 480 |
|
| 481 |
#- check on the selected package if a provide is satisfying the resolution (need to do the ops). |
| 482 |
foreach (grep { exists $state->{selected}{$_} } keys %{$urpm->{provides}{$n} || {}}) { |
| 483 |
my $p = $urpm->{depslist}[$_]; |
| 484 |
!$urpm->{provides}{$n}{$_} || $p->provides_overlap($prop) and next REQUIRES; |
| 485 |
} |
| 486 |
|
| 487 |
#- check if the package itself provides what is necessary. |
| 488 |
$pkg->provides_overlap($prop) and next REQUIRES; |
| 489 |
|
| 490 |
#- check on installed system if a package which is not obsoleted is satisfying the require. |
| 491 |
my $satisfied = 0; |
| 492 |
if ($n =~ m!^/!) { |
| 493 |
$db->traverse_tag('path', [ $n ], sub { |
| 494 |
my ($p) = @_; |
| 495 |
exists $state->{rejected}{$p->fullname} and return; |
| 496 |
$state->{cached_installed}{$n}{$p->fullname} = undef; |
| 497 |
++$satisfied; |
| 498 |
}); |
| 499 |
} else { |
| 500 |
$db->traverse_tag('whatprovides', [ $n ], sub { |
| 501 |
my ($p) = @_; |
| 502 |
exists $state->{rejected}{$p->fullname} and return; |
| 503 |
foreach ($p->provides) { |
| 504 |
if (my ($pn, $ps) = property2name_range($_)) { |
| 505 |
$ps or $state->{cached_installed}{$pn}{$p->fullname} = undef; |
| 506 |
$pn eq $n or next; |
| 507 |
URPM::ranges_overlap($ps, $s) and ++$satisfied; |
| 508 |
} |
| 509 |
} |
| 510 |
}); |
| 511 |
} |
| 512 |
#- if nothing can be done, the require should be resolved. |
| 513 |
$satisfied or $unsatisfied{$prop} = undef; |
| 514 |
} |
| 515 |
} |
| 516 |
|
| 517 |
keys %unsatisfied; |
| 518 |
} |
| 519 |
|
| 520 |
#- this function is "suggests vs requires" safe: |
| 521 |
#- 'whatrequires' will give both requires & suggests, but unsatisfied_requires |
| 522 |
#- will check $p->requires and so filter out suggests |
| 523 |
|
| 524 |
#- side-effects: only those done by $do |
| 525 |
sub with_db_unsatisfied_requires { |
| 526 |
my ($urpm, $db, $state, $name, $do) = @_; |
| 527 |
|
| 528 |
$db->traverse_tag('whatrequires', [ $name ], sub { |
| 529 |
my ($p) = @_; |
| 530 |
if (my @l = unsatisfied_requires($urpm, $db, $state, $p, name => $name)) { |
| 531 |
$urpm->{debug_URPM}("installed " . $p->fullname . " is conflicting because of unsatisfied @l") if $urpm->{debug_URPM}; |
| 532 |
$do->($p, @l); |
| 533 |
} |
| 534 |
}); |
| 535 |
} |
| 536 |
|
| 537 |
#- side-effects: only those done by $do |
| 538 |
sub with_state_unsatisfied_requires { |
| 539 |
my ($urpm, $db, $state, $name, $do) = @_; |
| 540 |
|
| 541 |
foreach (whatrequires_id($state, $name)) { |
| 542 |
$state->{selected}{$_} or next; |
| 543 |
my $p = $urpm->{depslist}[$_]; |
| 544 |
if (my @l = unsatisfied_requires($urpm, $db, $state, $p, name => $name)) { |
| 545 |
$urpm->{debug_URPM}("selected " . $p->fullname . " is conflicting because of unsatisfied @l") if $urpm->{debug_URPM}; |
| 546 |
$do->($p, @l); |
| 547 |
} |
| 548 |
} |
| 549 |
} |
| 550 |
|
| 551 |
sub with_any_unsatisfied_requires { |
| 552 |
my ($urpm, $db, $state, $name, $do) = @_; |
| 553 |
with_db_unsatisfied_requires($urpm, $db, $state, $name, sub { my ($p, @l) = @_; $do->($p, 0, @l) }); |
| 554 |
with_state_unsatisfied_requires($urpm, $db, $state, $name, sub { my ($p, @l) = @_; $do->($p, 1, @l) }); |
| 555 |
} |
| 556 |
|
| 557 |
|
| 558 |
# used when a require is not available |
| 559 |
# |
| 560 |
#- side-effects: $state->{backtrack}, $state->{selected} |
| 561 |
#- + those of disable_selected_and_unrequested_dependencies ($state->{whatrequires}, flag_requested, flag_required) |
| 562 |
#- + those of _set_rejected_from ($state->{rejected}) |
| 563 |
#- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) |
| 564 |
#- + those of _add_rejected_backtrack ($state->{rejected}) |
| 565 |
sub backtrack_selected { |
| 566 |
my ($urpm, $db, $state, $dep, $diff_provides, %options) = @_; |
| 567 |
|
| 568 |
if (defined $dep->{required}) { |
| 569 |
#- avoid deadlock here... |
| 570 |
if (!exists $state->{backtrack}{deadlock}{$dep->{required}}) { |
| 571 |
$state->{backtrack}{deadlock}{$dep->{required}} = undef; |
| 572 |
|
| 573 |
#- search for all possible packages, first is to try the selection, then if it is |
| 574 |
#- impossible, backtrack the origin. |
| 575 |
my @packages = find_candidate_packages($urpm, $dep->{required}); |
| 576 |
|
| 577 |
foreach (@packages) { |
| 578 |
#- avoid dead loop. |
| 579 |
exists $state->{backtrack}{selected}{$_->id} and next; |
| 580 |
#- a package if found is problably rejected or there is a problem. |
| 581 |
if ($state->{rejected}{$_->fullname}) { |
| 582 |
#- keep in mind a backtrack has happening here... |
| 583 |
exists $dep->{promote} and _add_rejected_backtrack($state, $_, { promote => [ $dep->{promote} ] }); |
| 584 |
|
| 585 |
my $closure = $state->{rejected}{$_->fullname}{closure} || {}; |
| 586 |
foreach my $p (grep { exists $closure->{$_}{avoid} } keys %$closure) { |
| 587 |
_add_rejected_backtrack($state, $_, { conflicts => [ $p ] }); |
| 588 |
} |
| 589 |
#- backtrack callback should return a strictly positive value if the selection of the new |
| 590 |
#- package is prefered over the currently selected package. |
| 591 |
next; |
| 592 |
} |
| 593 |
$state->{backtrack}{selected}{$_->id} = undef; |
| 594 |
|
| 595 |
#- in such case, we need to drop the problem caused so that rejected condition is removed. |
| 596 |
#- if this is not possible, the next backtrack on the same package will be refused above. |
| 597 |
my @l = map { $urpm->search($_, strict_fullname => 1) } |
| 598 |
keys %{($state->{rejected}{$_->fullname} || {})->{closure}}; |
| 599 |
|
| 600 |
disable_selected_and_unrequested_dependencies($urpm, $db, $state, @l); |
| 601 |
|
| 602 |
return { required => $_->id, |
| 603 |
exists $dep->{from} ? (from => $dep->{from}) : @{[]}, |
| 604 |
exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, |
| 605 |
exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, |
| 606 |
exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, |
| 607 |
}; |
| 608 |
} |
| 609 |
} |
| 610 |
} |
| 611 |
|
| 612 |
if (defined $dep->{from}) { |
| 613 |
if ($options{nodeps}) { |
| 614 |
#- try to keep unsatisfied dependencies in requested. |
| 615 |
if ($dep->{required} && exists $state->{selected}{$dep->{from}->id}) { |
| 616 |
push @{$state->{selected}{$dep->{from}->id}{unsatisfied}}, $dep->{required}; |
| 617 |
} |
| 618 |
} else { |
| 619 |
#- at this point, dep cannot be resolved, this means we need to disable |
| 620 |
#- all selection tree, re-enabling removed and obsoleted packages as well. |
| 621 |
unless (exists $state->{rejected}{$dep->{from}->fullname}) { |
| 622 |
#- package is not currently rejected, compute the closure now. |
| 623 |
my @l = disable_selected_and_unrequested_dependencies($urpm, $db, $state, $dep->{from}); |
| 624 |
foreach (@l) { |
| 625 |
#- disable all these packages in order to avoid selecting them again. |
| 626 |
_set_rejected_from($state, $_, $dep->{from}); |
| 627 |
} |
| 628 |
} |
| 629 |
#- the package is already rejected, we assume we can add another reason here! |
| 630 |
$urpm->{debug_URPM}("adding a reason to already rejected package " . $dep->{from}->fullname . ": unsatisfied " . $dep->{required}) if $urpm->{debug_URPM}; |
| 631 |
|
| 632 |
_add_rejected_backtrack($state, $dep->{from}, { unsatisfied => [ $dep->{required} ] }); |
| 633 |
} |
| 634 |
} |
| 635 |
|
| 636 |
my @properties; |
| 637 |
if (defined $dep->{psel}) { |
| 638 |
if ($options{keep}) { |
| 639 |
backtrack_selected_psel_keep($urpm, $db, $state, $dep->{psel}, $dep->{keep}); |
| 640 |
|
| 641 |
#- the package is already rejected, we assume we can add another reason here! |
| 642 |
defined $dep->{promote} and _add_rejected_backtrack($state, $dep->{psel}, { promote => [ $dep->{promote} ] }); |
| 643 |
} else { |
| 644 |
#- the backtrack need to examine diff_provides promotion on $n. |
| 645 |
with_db_unsatisfied_requires($urpm, $db, $state, $dep->{promote}, sub { |
| 646 |
my ($p, @unsatisfied) = @_; |
| 647 |
my %diff_provides_h; |
| 648 |
set_rejected_and_compute_diff_provides($urpm, $state, \%diff_provides_h, { |
| 649 |
rejected_pkg => $p, removed => 1, |
| 650 |
from => $dep->{psel}, |
| 651 |
why => { unsatisfied => \@unsatisfied } |
| 652 |
}); |
| 653 |
push @$diff_provides, map { +{ name => $_, pkg => $dep->{psel} } } keys %diff_provides_h; |
| 654 |
}); |
| 655 |
with_state_unsatisfied_requires($urpm, $db, $state, $dep->{promote}, sub { |
| 656 |
my ($p) = @_; |
| 657 |
_set_rejected_from($state, $p, $dep->{psel}); |
| 658 |
disable_selected_and_unrequested_dependencies($urpm, $db, $state, $p); |
| 659 |
}); |
| 660 |
} |
| 661 |
} |
| 662 |
|
| 663 |
#- some packages may have been removed because of selection of this one. |
| 664 |
#- the rejected flags should have been cleaned by disable_selected above. |
| 665 |
@properties; |
| 666 |
} |
| 667 |
|
| 668 |
#- side-effects: |
| 669 |
#- + those of _set_rejected_from ($state->{rejected}) |
| 670 |
#- + those of _add_rejected_backtrack ($state->{rejected}) |
| 671 |
#- + those of disable_selected_and_unrequested_dependencies ($state->{selected}, $state->{whatrequires}, flag_requested, flag_required) |
| 672 |
sub backtrack_selected_psel_keep { |
| 673 |
my ($urpm, $db, $state, $psel, $keep) = @_; |
| 674 |
|
| 675 |
#- we shouldn't try to remove packages, so psel which leads to this need to be unselected. |
| 676 |
unless (exists $state->{rejected}{$psel->fullname}) { |
| 677 |
#- package is not currently rejected, compute the closure now. |
| 678 |
my @l = disable_selected_and_unrequested_dependencies($urpm, $db, $state, $psel); |
| 679 |
foreach (@l) { |
| 680 |
#- disable all these packages in order to avoid selecting them again. |
| 681 |
_set_rejected_from($state, $_, $psel); |
| 682 |
} |
| 683 |
} |
| 684 |
#- to simplify, a reference to list or standalone elements may be set in keep. |
| 685 |
$keep and _add_rejected_backtrack($state, $psel, { keep => $keep }); |
| 686 |
} |
| 687 |
|
| 688 |
#- side-effects: $state->{rejected} |
| 689 |
sub _remove_all_rejected_from { |
| 690 |
my ($state, $from_fullname) = @_; |
| 691 |
|
| 692 |
grep { |
| 693 |
_remove_rejected_from($state, $_, $from_fullname); |
| 694 |
} keys %{$state->{rejected}}; |
| 695 |
} |
| 696 |
|
| 697 |
#- side-effects: $state->{rejected} |
| 698 |
sub _remove_rejected_from { |
| 699 |
my ($state, $fullname, $from_fullname) = @_; |
| 700 |
|
| 701 |
my $rv = $state->{rejected}{$fullname} or return; |
| 702 |
|
| 703 |
foreach (qw(removed obsoleted)) { |
| 704 |
if (exists $rv->{$_} && exists $rv->{$_}{$from_fullname}) { |
| 705 |
delete $rv->{$_}{$from_fullname}; |
| 706 |
delete $rv->{$_} if !%{$rv->{$_}}; |
| 707 |
} |
| 708 |
} |
| 709 |
|
| 710 |
exists $rv->{closure}{$from_fullname} or return; |
| 711 |
delete $rv->{closure}{$from_fullname}; |
| 712 |
if (%{$rv->{closure}}) { |
| 713 |
0; |
| 714 |
} else { |
| 715 |
delete $state->{rejected}{$fullname}; |
| 716 |
1; |
| 717 |
} |
| 718 |
} |
| 719 |
|
| 720 |
#- side-effects: $state->{rejected} |
| 721 |
sub _add_rejected_backtrack { |
| 722 |
my ($state, $pkg, $backtrack) = @_; |
| 723 |
|
| 724 |
my $bt = $state->{rejected}{$pkg->fullname}{backtrack} ||= {}; |
| 725 |
|
| 726 |
foreach (keys %$backtrack) { |
| 727 |
push @{$bt->{$_}}, @{$backtrack->{$_}}; |
| 728 |
} |
| 729 |
} |
| 730 |
|
| 731 |
#- useful to reject packages in advance |
| 732 |
#- eg when selecting "a" which conflict with "b", ensure we won't select "b" |
| 733 |
#- but it's somewhat dangerous because it's sometimes called on installed packages, |
| 734 |
#- and in that case, a real resolve_rejected_ must be done |
| 735 |
#- (that's why set_rejected ignores the effect of _set_rejected_from) |
| 736 |
#- |
| 737 |
#- side-effects: $state->{rejected} |
| 738 |
sub _set_rejected_from { |
| 739 |
my ($state, $pkg, $from_pkg) = @_; |
| 740 |
|
| 741 |
$pkg->fullname ne $from_pkg->fullname or return; |
| 742 |
|
| 743 |
$state->{rejected}{$pkg->fullname}{closure}{$from_pkg->fullname}{avoid} ||= undef; |
| 744 |
} |
| 745 |
|
| 746 |
#- side-effects: $state->{rejected} |
| 747 |
sub _set_rejected_old_package { |
| 748 |
my ($state, $pkg, $new_pkg) = @_; |
| 749 |
|
| 750 |
if ($pkg->fullname eq $new_pkg->fullname) { |
| 751 |
$state->{rejected_already_installed}{$pkg->id} = $pkg; |
| 752 |
} else { |
| 753 |
push @{$state->{rejected}{$pkg->fullname}{backtrack}{keep}}, scalar $new_pkg->fullname; |
| 754 |
} |
| 755 |
} |
| 756 |
|
| 757 |
#- side-effects: $state->{rejected} |
| 758 |
sub set_rejected { |
| 759 |
my ($urpm, $state, $rdep) = @_; |
| 760 |
|
| 761 |
my $fullname = $rdep->{rejected_pkg}->fullname; |
| 762 |
my $rv = $state->{rejected}{$fullname} ||= {}; |
| 763 |
|
| 764 |
my $newly_rejected = !exists $rv->{size}; |
| 765 |
|
| 766 |
if ($newly_rejected) { |
| 767 |
$urpm->{debug_URPM}("set_rejected: $fullname") if $urpm->{debug_URPM}; |
| 768 |
#- keep track of size of package which are finally removed. |
| 769 |
$rv->{size} = $rdep->{rejected_pkg}->size; |
| 770 |
} |
| 771 |
|
| 772 |
#- keep track of what causes closure. |
| 773 |
if ($rdep->{from}) { |
| 774 |
my $closure = $rv->{closure}{scalar $rdep->{from}->fullname} ||= {}; |
| 775 |
if (my $l = delete $rdep->{why}{unsatisfied}) { |
| 776 |
my $unsatisfied = $closure->{unsatisfied} ||= []; |
| 777 |
@$unsatisfied = uniq(@$unsatisfied, @$l); |
| 778 |
} |
| 779 |
$closure->{$_} = $rdep->{why}{$_} foreach keys %{$rdep->{why}}; |
| 780 |
} |
| 781 |
|
| 782 |
#- set removed and obsoleted level. |
| 783 |
foreach (qw(removed obsoleted)) { |
| 784 |
if ($rdep->{$_}) { |
| 785 |
if ($rdep->{from}) { |
| 786 |
$rv->{$_}{scalar $rdep->{from}->fullname} = undef; |
| 787 |
} else { |
| 788 |
$rv->{$_}{asked} = undef; |
| 789 |
} |
| 790 |
} |
| 791 |
} |
| 792 |
|
| 793 |
$newly_rejected; |
| 794 |
} |
| 795 |
|
| 796 |
#- side-effects: |
| 797 |
#- + those of set_rejected ($state->{rejected}) |
| 798 |
#- + those of _compute_diff_provides_of_removed_pkg ($diff_provides_h) |
| 799 |
sub set_rejected_and_compute_diff_provides { |
| 800 |
my ($urpm, $state, $diff_provides_h, $rdep) = @_; |
| 801 |
|
| 802 |
my $newly_rejected = set_rejected($urpm, $state, $rdep); |
| 803 |
|
| 804 |
#- no need to compute diff_provides if package was already rejected |
| 805 |
$newly_rejected or return; |
| 806 |
|
| 807 |
_compute_diff_provides_of_removed_pkg($urpm, $state, $diff_provides_h, $rdep->{rejected_pkg}); |
| 808 |
} |
| 809 |
|
| 810 |
#- see resolve_rejected_ below |
| 811 |
sub resolve_rejected { |
| 812 |
my ($urpm, $db, $state, $pkg, %rdep) = @_; |
| 813 |
$rdep{rejected_pkg} = $pkg; |
| 814 |
resolve_rejected_($urpm, $db, $state, $rdep{unsatisfied}, \%rdep); |
| 815 |
} |
| 816 |
|
| 817 |
#- close rejected (as urpme previously) for package to be removable without error. |
| 818 |
#- |
| 819 |
#- side-effects: $properties |
| 820 |
#- + those of set_rejected ($state->{rejected}) |
| 821 |
sub resolve_rejected_ { |
| 822 |
my ($urpm, $db, $state, $properties, $rdep) = @_; |
| 823 |
|
| 824 |
$urpm->{debug_URPM}("resolve_rejected: " . $rdep->{rejected_pkg}->fullname) if $urpm->{debug_URPM}; |
| 825 |
|
| 826 |
#- check if the package has already been asked to be rejected (removed or obsoleted). |
| 827 |
#- this means only add the new reason and return. |
| 828 |
my $newly_rejected = set_rejected($urpm, $state, $rdep); |
| 829 |
|
| 830 |
$newly_rejected or return; |
| 831 |
|
| 832 |
my @pkgs_todo = $rdep->{rejected_pkg}; |
| 833 |
|
| 834 |
while (my $cp = shift @pkgs_todo) { |
| 835 |
#- close what requires this property, but check with selected package requiring old properties. |
| 836 |
foreach my $n ($cp->provides_nosense) { |
| 837 |
foreach my $pkg (whatrequires($urpm, $state, $n)) { |
| 838 |
if (my @l = unsatisfied_requires($urpm, $db, $state, $pkg, name => $n)) { |
| 839 |
#- a selected package requires something that is no more available |
| 840 |
#- and should be tried to be re-selected if possible. |
| 841 |
if ($properties) { |
| 842 |
push @$properties, map { |
| 843 |
{ required => $_, rejected => scalar $pkg->fullname }; # rejected is only there for debugging purpose (??) |
| 844 |
} @l; |
| 845 |
} |
| 846 |
} |
| 847 |
} |
| 848 |
with_db_unsatisfied_requires($urpm, $db, $state, $n, sub { |
| 849 |
my ($p, @unsatisfied) = @_; |
| 850 |
|
| 851 |
my $newly_rejected = set_rejected($urpm, $state, { |
| 852 |
rejected_pkg => $p, |
| 853 |
from => $rdep->{rejected_pkg}, |
| 854 |
why => { unsatisfied => \@unsatisfied }, |
| 855 |
obsoleted => $rdep->{obsoleted}, |
| 856 |
removed => $rdep->{removed}, |
| 857 |
}); |
| 858 |
|
| 859 |
#- continue the closure unless already examined. |
| 860 |
$newly_rejected or return; |
| 861 |
|
| 862 |
$p->pack_header; #- need to pack else package is no longer visible... |
| 863 |
push @pkgs_todo, $p; |
| 864 |
}); |
| 865 |
} |
| 866 |
} |
| 867 |
} |
| 868 |
|
| 869 |
# see resolve_requested__no_suggests below for information about usage |
| 870 |
sub resolve_requested { |
| 871 |
my ($urpm, $db, $state, $requested, %options) = @_; |
| 872 |
|
| 873 |
my @selected = resolve_requested__no_suggests($urpm, $db, $state, $requested, %options); |
| 874 |
|
| 875 |
if (!$options{no_suggests}) { |
| 876 |
@selected = resolve_requested_suggests($urpm, $db, $state, \@selected, %options); |
| 877 |
} |
| 878 |
@selected; |
| 879 |
} |
| 880 |
|
| 881 |
sub resolve_requested_suggests { |
| 882 |
my ($urpm, $db, $state, $selected, %options) = @_; |
| 883 |
my @todo = @$selected; |
| 884 |
while (@todo) { |
| 885 |
my $pkg = shift @todo; |
| 886 |
my %suggests = map { $_ => 1 } $pkg->suggests or next; |
| 887 |
|
| 888 |
#- do not install a package that has already been suggested |
| 889 |
$db->traverse_tag_find('name', $pkg->name, sub { |
| 890 |
my ($p) = @_; |
| 891 |
delete $suggests{$_} foreach $p->suggests; |
| 892 |
}); |
| 893 |
|
| 894 |
# workaround: if you do "urpmi virtual_pkg" and one virtual_pkg is already installed, |
| 895 |
# it will ask anyway for the other choices |
| 896 |
foreach my $suggest (keys %suggests) { |
| 897 |
$db->traverse_tag('whatprovides', [ $suggest ], sub { |
| 898 |
delete $suggests{$suggest}; |
| 899 |
}); |
| 900 |
} |
| 901 |
|
| 902 |
%suggests or next; |
| 903 |
|
| 904 |
$urpm->{debug_URPM}("requested " . join(', ', keys %suggests) . " suggested by " . $pkg->fullname) if $urpm->{debug_URPM}; |
| 905 |
|
| 906 |
my %new_requested = map { $_ => undef } keys %suggests; |
| 907 |
my @new_selected = resolve_requested__no_suggests_($urpm, $db, $state, \%new_requested, %options); |
| 908 |
$state->{selected}{$_->id}{suggested} = 1 foreach @new_selected; |
| 909 |
push @$selected, @new_selected; |
| 910 |
push @todo, @new_selected; |
| 911 |
} |
| 912 |
|
| 913 |
@$selected; |
| 914 |
} |
| 915 |
|
| 916 |
#- Resolve dependencies of requested packages; keep resolution state to |
| 917 |
#- speed up process. |
| 918 |
#- A requested package is marked to be installed; once done, an upgrade flag or |
| 919 |
#- an installed flag is set according to the needs of the installation of this |
| 920 |
#- package. |
| 921 |
#- Other required packages will have a required flag set along with an upgrade |
| 922 |
#- flag or an installed flag. |
| 923 |
#- Base flag should always be "installed" or "upgraded". |
| 924 |
#- The following options are recognized : |
| 925 |
#- callback_choices : subroutine to be called to ask the user to choose |
| 926 |
#- between several possible packages. Returns an array of URPM::Package |
| 927 |
#- objects, or an empty list eventually. |
| 928 |
#- keep : |
| 929 |
#- nodeps : |
| 930 |
#- |
| 931 |
#- side-effects: flag_requested |
| 932 |
#- + those of resolve_requested__no_suggests_ |
| 933 |
sub resolve_requested__no_suggests { |
| 934 |
my ($urpm, $db, $state, $requested, %options) = @_; |
| 935 |
|
| 936 |
foreach (keys %$requested) { |
| 937 |
#- keep track of requested packages by propating the flag. |
| 938 |
foreach (find_candidate_packages($urpm, $_)) { |
| 939 |
$_->set_flag_requested; |
| 940 |
} |
| 941 |
} |
| 942 |
|
| 943 |
resolve_requested__no_suggests_($urpm, $db, $state, $requested, %options); |
| 944 |
} |
| 945 |
|
| 946 |
# same as resolve_requested__no_suggests, but do not modify requested_flag |
| 947 |
#- |
| 948 |
#- side-effects: $state->{selected}, flag_required, flag_installed, flag_upgrade |
| 949 |
#- + those of backtrack_selected (flag_requested, $state->{rejected}, $state->{whatrequires}, $state->{backtrack}) |
| 950 |
#- + those of _unselect_package_deprecated_by (flag_requested, $state->{rejected}, $state->{whatrequires}, $state->{oldpackage}, $state->{unselected_uninstalled}) |
| 951 |
#- + those of _handle_conflicts ($state->{rejected}) |
| 952 |
#- + those of _handle_conflict ($state->{rejected}) |
| 953 |
#- + those of backtrack_selected_psel_keep (flag_requested, $state->{whatrequires}) |
| 954 |
#- + those of _handle_diff_provides (flag_requested, $state->{rejected}, $state->{whatrequires}) |
| 955 |
#- + those of _no_more_recent_installed_and_providing ($state->{rejected}) |
| 956 |
sub resolve_requested__no_suggests_ { |
| 957 |
my ($urpm, $db, $state, $requested, %options) = @_; |
| 958 |
|
| 959 |
my @properties = map { |
| 960 |
{ required => $_, requested => $requested->{$_} }; |
| 961 |
} keys %$requested; |
| 962 |
|
| 963 |
my (@diff_provides, @selected, @choices); |
| 964 |
|
| 965 |
#- for each dep property evaluated, examine which package will be obsoleted on $db, |
| 966 |
#- then examine provides that will be removed (which need to be satisfied by another |
| 967 |
#- package present or by a new package to upgrade), then requires not satisfied and |
| 968 |
#- finally conflicts that will force a new upgrade or a remove. |
| 969 |
my $count = 1; |
| 970 |
do { |
| 971 |
while (my $dep = shift @properties) { |
| 972 |
#- we need to avoid selecting packages if the source has been disabled. |
| 973 |
if (exists $dep->{from} && !$urpm->{keep_unrequested_dependencies}) { |
| 974 |
exists $state->{selected}{$dep->{from}->id} or next; |
| 975 |
} |
| 976 |
|
| 977 |
my $pkg = _choose_required($urpm, $db, $state, $dep, \@properties, \@choices, \@diff_provides, %options) or next; |
| 978 |
|
| 979 |
!$pkg || exists $state->{selected}{$pkg->id} and next; |
| 980 |
|
| 981 |
if ($pkg->arch eq 'src') { |
| 982 |
$pkg->set_flag_upgrade; |
| 983 |
} else { |
| 984 |
_set_flag_installed_and_upgrade_if_no_newer($db, $pkg); |
| 985 |
|
| 986 |
if ($pkg->flag_installed && !$pkg->flag_upgrade && !$urpm->{options}{downgrade}) { |
| 987 |
_no_more_recent_installed_and_providing($urpm, $db, $state, $pkg, $dep->{required}) or next; |
| 988 |
} |
| 989 |
} |
| 990 |
|
| 991 |
_handle_conflicts_with_selected($urpm, $db, $state, $pkg, $dep, \@properties, \@diff_provides, %options) or next; |
| 992 |
|
| 993 |
$urpm->{debug_URPM}("selecting " . $pkg->fullname) if $urpm->{debug_URPM}; |
| 994 |
|
| 995 |
#- keep in mind the package has be selected, remove the entry in requested input hash, |
| 996 |
#- this means required dependencies have undef value in selected hash. |
| 997 |
#- requested flag is set only for requested package where value is not false. |
| 998 |
push @selected, $pkg; |
| 999 |
$state->{selected}{$pkg->id} = { exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, |
| 1000 |
exists $dep->{from} ? (from => $dep->{from}) : @{[]}, |
| 1001 |
exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, |
| 1002 |
exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, |
| 1003 |
$pkg->flag_disable_obsolete ? (install => 1) : @{[]}, |
| 1004 |
}; |
| 1005 |
|
| 1006 |
$pkg->set_flag_required; |
| 1007 |
|
| 1008 |
#- check if the package is not already installed before trying to use it, compute |
| 1009 |
#- obsoleted packages too. This is valable only for non source packages. |
| 1010 |
my %diff_provides_h; |
| 1011 |
if ($pkg->arch ne 'src' && !$pkg->flag_disable_obsolete) { |
| 1012 |
_unselect_package_deprecated_by($urpm, $db, $state, \%diff_provides_h, $pkg); |
| 1013 |
} |
| 1014 |
|
| 1015 |
#- all requires should be satisfied according to selected package, or installed packages. |
| 1016 |
if (my @l = unsatisfied_requires($urpm, $db, $state, $pkg)) { |
| 1017 |
$urpm->{debug_URPM}("requiring " . join(',', sort @l) . " for " . $pkg->fullname) if $urpm->{debug_URPM}; |
| 1018 |
unshift @properties, map { +{ required => $_, from => $pkg, |
| 1019 |
exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, |
| 1020 |
exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, |
| 1021 |
} } @l; |
| 1022 |
} |
| 1023 |
|
| 1024 |
#- keep in mind what is requiring each item (for unselect to work). |
| 1025 |
foreach ($pkg->requires_nosense) { |
| 1026 |
$state->{whatrequires}{$_}{$pkg->id} = undef; |
| 1027 |
} |
| 1028 |
|
| 1029 |
#- cancel flag if this package should be cancelled but too late (typically keep options). |
| 1030 |
my @keep; |
| 1031 |
|
| 1032 |
_handle_conflicts($urpm, $db, $state, $pkg, \@properties, \%diff_provides_h, $options{keep} && \@keep); |
| 1033 |
|
| 1034 |
#- examine if an existing package does not conflict with this one. |
| 1035 |
$db->traverse_tag('whatconflicts', [ $pkg->provides_nosense ], sub { |
| 1036 |
@keep and return; |
| 1037 |
my ($p) = @_; |
| 1038 |
foreach my $property ($p->conflicts) { |
| 1039 |
if ($pkg->provides_overlap($property)) { |
| 1040 |
_handle_conflict($urpm, $state, $pkg, $p, $property, $property, \@properties, \%diff_provides_h, $options{keep} && \@keep); |
| 1041 |
} |
| 1042 |
} |
| 1043 |
}); |
| 1044 |
|
| 1045 |
#- keep existing package and therefore cancel current one. |
| 1046 |
if (@keep) { |
| 1047 |
backtrack_selected_psel_keep($urpm, $db, $state, $pkg, \@keep); |
| 1048 |
} |
| 1049 |
|
| 1050 |
push @diff_provides, map { +{ name => $_, pkg => $pkg } } keys %diff_provides_h; |
| 1051 |
} |
| 1052 |
if (my $diff = shift @diff_provides) { |
| 1053 |
_handle_diff_provides($urpm, $db, $state, \@properties, \@diff_provides, $diff->{name}, $diff->{pkg}, %options); |
| 1054 |
} elsif (my $dep = shift @choices) { |
| 1055 |
push @properties, $dep; |
| 1056 |
} |
| 1057 |
|
| 1058 |
# safety: |
| 1059 |
if ($count++ > 50000) { |
| 1060 |
die("detecting looping forever while trying to resolve dependancies.\n" |
| 1061 |
. "Aborting... Try again with '-vv --debug' options"); |
| 1062 |
} |
| 1063 |
} while (@diff_provides || @properties || @choices); |
| 1064 |
|
| 1065 |
#- return what has been selected by this call (not all selected hash which may be not empty |
| 1066 |
#- previously. avoid returning rejected packages which weren't selectable. |
| 1067 |
grep { exists $state->{selected}{$_->id} } @selected; |
| 1068 |
} |
| 1069 |
|
| 1070 |
#- pre-disables packages that $pkg has conflict entries for, and |
| 1071 |
#- unselects $pkg if such a package is already selected |
| 1072 |
#- side-effects: |
| 1073 |
#- + those of _set_rejected_from ($state->{rejected}) |
| 1074 |
#- + those of _remove_all_rejected_from ($state->{rejected}) |
| 1075 |
#- + those of backtrack_selected ($state->{backtrack}, $state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) |
| 1076 |
sub _handle_conflicts_with_selected { |
| 1077 |
my ($urpm, $db, $state, $pkg, $dep, $properties, $diff_provides, %options) = @_; |
| 1078 |
foreach ($pkg->conflicts) { |
| 1079 |
if (my $n = property2name($_)) { |
| 1080 |
foreach my $p ($urpm->packages_providing($n)) { |
| 1081 |
$pkg == $p and next; |
| 1082 |
$p->provides_overlap($_) or next; |
| 1083 |
if (exists $state->{selected}{$p->id}) { |
| 1084 |
$urpm->{debug_URPM}($pkg->fullname . " conflicts with already selected package " . $p->fullname) if $urpm->{debug_URPM}; |
| 1085 |
_remove_all_rejected_from($state, $pkg); |
| 1086 |
_set_rejected_from($state, $pkg, $p); |
| 1087 |
unshift @$properties, backtrack_selected($urpm, $db, $state, $dep, $diff_provides, %options); |
| 1088 |
return; |
| 1089 |
} |
| 1090 |
_set_rejected_from($state, $p, $pkg); |
| 1091 |
} |
| 1092 |
} |
| 1093 |
} |
| 1094 |
1; |
| 1095 |
} |
| 1096 |
|
| 1097 |
#- side-effects: |
| 1098 |
#- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) |
| 1099 |
#- + those of _handle_conflict ($properties, $keep, $diff_provides_h) |
| 1100 |
sub _handle_conflicts { |
| 1101 |
my ($urpm, $db, $state, $pkg, $properties, $diff_provides_h, $keep) = @_; |
| 1102 |
|
| 1103 |
#- examine conflicts, an existing package conflicting with this selection should |
| 1104 |
#- be upgraded to a new version which will be safe, else it should be removed. |
| 1105 |
foreach ($pkg->conflicts) { |
| 1106 |
$keep && @$keep and last; |
| 1107 |
if (my ($file) = m!^(/[^\s\[]*)!) { |
| 1108 |
$db->traverse_tag('path', [ $file ], sub { |
| 1109 |
$keep && @$keep and return; |
| 1110 |
my ($p) = @_; |
| 1111 |
if ($keep) { |
| 1112 |
push @$keep, scalar $p->fullname; |
| 1113 |
} else { |
| 1114 |
#- all these package should be removed. |
| 1115 |
set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { |
| 1116 |
rejected_pkg => $p, removed => 1, |
| 1117 |
from => $pkg, |
| 1118 |
why => { conflicts => $file }, |
| 1119 |
}); |
| 1120 |
} |
| 1121 |
}); |
| 1122 |
} elsif (my $name = property2name($_)) { |
| 1123 |
my $property = $_; |
| 1124 |
$db->traverse_tag('whatprovides', [ $name ], sub { |
| 1125 |
$keep && @$keep and return; |
| 1126 |
my ($p) = @_; |
| 1127 |
if ($p->provides_overlap($property)) { |
| 1128 |
_handle_conflict($urpm, $state, $pkg, $p, $property, scalar($pkg->fullname), $properties, $diff_provides_h, $keep); |
| 1129 |
} |
| 1130 |
}); |
| 1131 |
} |
| 1132 |
} |
| 1133 |
} |
| 1134 |
|
| 1135 |
#- side-effects: |
| 1136 |
#- + those of _unselect_package_deprecated_by_property (flag_requested, flag_required, $state->{selected}, $state->{rejected}, $state->{whatrequires}, $state->{oldpackage}, $state->{unselected_uninstalled}) |
| 1137 |
sub _unselect_package_deprecated_by { |
| 1138 |
my ($urpm, $db, $state, $diff_provides_h, $pkg) = @_; |
| 1139 |
|
| 1140 |
_unselect_package_deprecated_by_property($urpm, $db, $state, $pkg, $diff_provides_h, $pkg->name, '<', $pkg->epoch . ":" . $pkg->version . "-" . $pkg->release); |
| 1141 |
|
| 1142 |
foreach ($pkg->obsoletes) { |
| 1143 |
my ($n, $o, $v) = property2name_op_version($_) or next; |
| 1144 |
|
| 1145 |
#- ignore if this package obsoletes itself |
| 1146 |
#- otherwise this can cause havoc if: to_install=v3, installed=v2, v3 obsoletes < v2 |
| 1147 |
if ($n ne $pkg->name) { |
| 1148 |
_unselect_package_deprecated_by_property($urpm, $db, $state, $pkg, $diff_provides_h, $n, $o, $v); |
| 1149 |
} |
| 1150 |
} |
| 1151 |
} |
| 1152 |
|
| 1153 |
#- side-effects: $state->{oldpackage}, $state->{unselected_uninstalled} |
| 1154 |
#- + those of set_rejected ($state->{rejected}) |
| 1155 |
#- + those of _set_rejected_from ($state->{rejected}) |
| 1156 |
#- + those of disable_selected (flag_requested, flag_required, $state->{selected}, $state->{rejected}, $state->{whatrequires}) |
| 1157 |
sub _unselect_package_deprecated_by_property { |
| 1158 |
my ($urpm, $db, $state, $pkg, $diff_provides_h, $n, $o, $v) = @_; |
| 1159 |
|
| 1160 |
#- populate avoided entries according to what is selected. |
| 1161 |
foreach my $p ($urpm->packages_providing($n)) { |
| 1162 |
if ($p->name eq $pkg->name) { |
| 1163 |
#- all packages with the same name should now be avoided except when chosen. |
| 1164 |
} else { |
| 1165 |
#- in case of obsoletes, keep track of what should be avoided |
| 1166 |
#- but only if package name equals the obsolete name. |
| 1167 |
$p->name eq $n && (!$o || eval($p->compare($v) . $o . 0)) or next; |
| 1168 |
} |
| 1169 |
#- these packages are not yet selected, if they happen to be selected, |
| 1170 |
#- they must first be unselected. |
| 1171 |
_set_rejected_from($state, $p, $pkg); |
| 1172 |
} |
| 1173 |
|
| 1174 |
#- examine rpm db too (but only according to package names as a fix in rpm itself) |
| 1175 |
$db->traverse_tag('name', [ $n ], sub { |
| 1176 |
my ($p) = @_; |
| 1177 |
|
| 1178 |
#- without an operator, anything (with the same name) is matched. |
| 1179 |
#- with an operator, check package EVR with the obsoletes EVR. |
| 1180 |
#- $satisfied is true if installed package has version newer or equal. |
| 1181 |
my $comparison = $p->compare($v); |
| 1182 |
my $satisfied = !$o || eval($comparison . $o . 0); |
| 1183 |
|
| 1184 |
my $obsoleted; |
| 1185 |
if ($p->name eq $pkg->name) { |
| 1186 |
#- all packages older than the current one are obsoleted, |
| 1187 |
#- the others are simply removed (the result is the same). |
| 1188 |
if ($o && $comparison > 0) { |
| 1189 |
#- installed package is newer |
| 1190 |
#- remove this package from the list of packages to install, |
| 1191 |
#- unless urpmi was invoked with --allow-force |
| 1192 |
#- (in which case rpm could be invoked with --oldpackage) |
| 1193 |
if (!$urpm->{options}{'allow-force'} && !$urpm->{options}{downgrade}) { |
| 1194 |
#- since the originally requested packages (or other |
| 1195 |
#- non-installed ones) could be unselected by the following |
| 1196 |
#- operation, remember them, to warn the user |
| 1197 |
$state->{unselected_uninstalled} = [ grep { |
| 1198 |
!$_->flag_installed; |
| 1199 |
} disable_selected($urpm, $db, $state, $pkg) ]; |
| 1200 |
|
| 1201 |
return; |
| 1202 |
} |
| 1203 |
} elsif ($satisfied) { |
| 1204 |
$obsoleted = 1; |
| 1205 |
} |
| 1206 |
} elsif ($satisfied) { |
| 1207 |
$obsoleted = 1; |
| 1208 |
} else { |
| 1209 |
return; |
| 1210 |
} |
| 1211 |
|
| 1212 |
set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { |
| 1213 |
rejected_pkg => $p, |
| 1214 |
obsoleted => $obsoleted, removed => !$obsoleted, |
| 1215 |
from => $pkg, why => $obsoleted ? undef : { old_requested => 1 }, |
| 1216 |
}); |
| 1217 |
$obsoleted or ++$state->{oldpackage}; |
| 1218 |
}); |
| 1219 |
} |
| 1220 |
|
| 1221 |
#- side-effects: $diff_provides |
| 1222 |
sub _compute_diff_provides_of_removed_pkg { |
| 1223 |
my ($urpm, $state, $diff_provides_h, $p) = @_; |
| 1224 |
|
| 1225 |
foreach ($p->provides) { |
| 1226 |
#- check differential provides between obsoleted package and newer one. |
| 1227 |
my ($pn, $ps) = property2name_range($_) or next; |
| 1228 |
|
| 1229 |
my $not_provided = 1; |
| 1230 |
foreach (grep { exists $state->{selected}{$_} } |
| 1231 |
keys %{$urpm->{provides}{$pn} || {}}) { |
| 1232 |
my $pp = $urpm->{depslist}[$_]; |
| 1233 |
foreach ($pp->provides) { |
| 1234 |
my ($ppn, $pps) = property2name_range($_) or next; |
| 1235 |
$ppn eq $pn && $pps eq $ps |
| 1236 |
and $not_provided = 0; |
| 1237 |
} |
| 1238 |
} |
| 1239 |
$not_provided and $diff_provides_h->{$pn} = undef; |
| 1240 |
} |
| 1241 |
} |
| 1242 |
|
| 1243 |
#- side-effects: none |
| 1244 |
sub _find_packages_obsoleting { |
| 1245 |
my ($urpm, $state, $p) = @_; |
| 1246 |
|
| 1247 |
grep { |
| 1248 |
$_ && |
| 1249 |
!$_->flag_skip |
| 1250 |
&& $_->is_arch_compat |
| 1251 |
&& !exists $state->{rejected}{$_->fullname} |
| 1252 |
&& $_->obsoletes_overlap($p->name . " == " . $p->epoch . ":" . $p->version . "-" . $p->release) |
| 1253 |
&& $_->fullname ne $p->fullname |
| 1254 |
&& (!strict_arch($urpm) || strict_arch_check($p, $_)); |
| 1255 |
} $urpm->packages_obsoleting($p->name); |
| 1256 |
} |
| 1257 |
|
| 1258 |
#- side-effects: $properties |
| 1259 |
#- + those of backtrack_selected_psel_keep ($state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) |
| 1260 |
#- + those of resolve_rejected_ ($state->{rejected}, $properties) |
| 1261 |
#- + those of disable_selected_and_unrequested_dependencies (flag_requested, flag_required, $state->{selected}, $state->{whatrequires}, $state->{rejected}) |
| 1262 |
#- + those of _set_rejected_from ($state->{rejected}) |
| 1263 |
sub _handle_diff_provides { |
| 1264 |
my ($urpm, $db, $state, $properties, $diff_provides, $n, $pkg, %options) = @_; |
| 1265 |
|
| 1266 |
with_any_unsatisfied_requires($urpm, $db, $state, $n, sub { |
| 1267 |
my ($p, $from_state, @unsatisfied) = @_; |
| 1268 |
|
| 1269 |
#- try if upgrading the package will be satisfying all the requires... |
| 1270 |
#- there is no need to avoid promoting epoch as the package examined is not |
| 1271 |
#- already installed. |
| 1272 |
my @packages = find_candidate_packages($urpm, $p->name, $state->{rejected}); |
| 1273 |
@packages = |
| 1274 |
grep { ($_->name eq $p->name ? $p->compare_pkg($_) < 0 : |
| 1275 |
$_->obsoletes_overlap($p->name . " == " . $p->epoch . ":" . $p->version . "-" . $p->release)) |
| 1276 |
&& (!strict_arch($urpm) || strict_arch_check($p, $_)); |
| 1277 |
} @packages; |
| 1278 |
|
| 1279 |
if (!@packages) { |
| 1280 |
@packages = _find_packages_obsoleting($urpm, $state, $p); |
| 1281 |
} |
| 1282 |
|
| 1283 |
if (@packages) { |
| 1284 |
my $best = join('|', map { $_->id } @packages); |
| 1285 |
$urpm->{debug_URPM}("promoting " . $urpm->{depslist}[$best]->fullname . " because of conflict above") if $urpm->{debug_URPM}; |
| 1286 |
push @$properties, { required => $best, promote => $n, psel => $pkg }; |
| 1287 |
} else { |
| 1288 |
#- no package have been found, we may need to remove the package examined unless |
| 1289 |
#- there exists enough packages that provided the unsatisfied requires. |
| 1290 |
my @best; |
| 1291 |
foreach (@unsatisfied) { |
| 1292 |
my @packages = find_candidate_packages($urpm, $_, $state->{rejected}); |
| 1293 |
if (@packages = grep { $_->fullname ne $p->fullname } @packages) { |
| 1294 |
push @best, join('|', map { $_->id } @packages); |
| 1295 |
} |
| 1296 |
} |
| 1297 |
|
| 1298 |
if (@best == @unsatisfied) { |
| 1299 |
$urpm->{debug_URPM}("promoting " . join(' ', _ids_to_fullnames($urpm, map { split('\|', $_) } @best)) . " because of conflict above") if $urpm->{debug_URPM}; |
| 1300 |
push @$properties, map { +{ required => $_, promote => $n, psel => $pkg } } @best; |
| 1301 |
} else { |
| 1302 |
if ($from_state) { |
| 1303 |
disable_selected_and_unrequested_dependencies($urpm, $db, $state, $p); |
| 1304 |
_set_rejected_from($state, $p, $pkg); |
| 1305 |
} elsif ($options{keep}) { |
| 1306 |
backtrack_selected_psel_keep($urpm, $db, $state, $pkg, [ scalar $p->fullname ]); |
| 1307 |
} else { |
| 1308 |
my %diff_provides_h; |
| 1309 |
set_rejected_and_compute_diff_provides($urpm, $state, \%diff_provides_h, { |
| 1310 |
rejected_pkg => $p, removed => 1, |
| 1311 |
from => $pkg, |
| 1312 |
why => { unsatisfied => \@unsatisfied }, |
| 1313 |
}); |
| 1314 |
push @$diff_provides, map { +{ name => $_, pkg => $pkg } } keys %diff_provides_h; |
| 1315 |
} |
| 1316 |
} |
| 1317 |
} |
| 1318 |
}); |
| 1319 |
} |
| 1320 |
|
| 1321 |
#- side-effects: $properties, $keep |
| 1322 |
#- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) |
| 1323 |
sub _handle_conflict { |
| 1324 |
my ($urpm, $state, $pkg, $p, $property, $reason, $properties, $diff_provides_h, $keep) = @_; |
| 1325 |
|
| 1326 |
$urpm->{debug_URPM}("installed package " . $p->fullname . " is conflicting with " . $pkg->fullname . " (Conflicts: $property)") if $urpm->{debug_URPM}; |
| 1327 |
|
| 1328 |
#- the existing package will conflict with the selection; check |
| 1329 |
#- whether a newer version will be ok, else ask to remove the old. |
| 1330 |
my $need_deps = $p->name . " > " . ($p->epoch ? $p->epoch . ":" : "") . |
| 1331 |
$p->version . "-" . $p->release; |
| 1332 |
my @packages = grep { $_->name eq $p->name } find_candidate_packages($urpm, $need_deps, $state->{rejected}); |
| 1333 |
@packages = grep { ! $_->provides_overlap($property) } @packages; |
| 1334 |
|
| 1335 |
if (!@packages) { |
| 1336 |
@packages = _find_packages_obsoleting($urpm, $state, $p); |
| 1337 |
@packages = grep { ! $_->provides_overlap($property) } @packages; |
| 1338 |
} |
| 1339 |
|
| 1340 |
if (@packages) { |
| 1341 |
my $best = join('|', map { $_->id } @packages); |
| 1342 |
$urpm->{debug_URPM}("promoting " . join('|', map { scalar $_->fullname } @packages) . " because of conflict above") if $urpm->{debug_URPM}; |
| 1343 |
unshift @$properties, { required => $best, promote_conflicts => $reason }; |
| 1344 |
} else { |
| 1345 |
if ($keep) { |
| 1346 |
push @$keep, scalar $p->fullname; |
| 1347 |
} else { |
| 1348 |
#- no package has been found, we need to remove the package examined. |
| 1349 |
set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { |
| 1350 |
rejected_pkg => $p, removed => 1, |
| 1351 |
from => $pkg, |
| 1352 |
why => { conflicts => $reason }, |
| 1353 |
}); |
| 1354 |
} |
| 1355 |
} |
| 1356 |
} |
| 1357 |
|
| 1358 |
#- side-effects: none |
| 1359 |
sub _dep_to_name { |
| 1360 |
my ($urpm, $dep) = @_; |
| 1361 |
join('|', map { _id_to_name($urpm, $_) } split('\|', $dep->{required})); |
| 1362 |
} |
| 1363 |
#- side-effects: none |
| 1364 |
sub _id_to_name { |
| 1365 |
my ($urpm, $id_prop) = @_; |
| 1366 |
if ($id_prop =~ /^\d+/) { |
| 1367 |
my $pkg = $urpm->{depslist}[$id_prop]; |
| 1368 |
$pkg && $pkg->name; |
| 1369 |
} else { |
| 1370 |
$id_prop; |
| 1371 |
} |
| 1372 |
} |
| 1373 |
#- side-effects: none |
| 1374 |
sub _ids_to_names { |
| 1375 |
my $urpm = shift; |
| 1376 |
|
| 1377 |
map { $urpm->{depslist}[$_]->name } @_; |
| 1378 |
} |
| 1379 |
#- side-effects: none |
| 1380 |
sub _ids_to_fullnames { |
| 1381 |
my $urpm = shift; |
| 1382 |
|
| 1383 |
map { scalar $urpm->{depslist}[$_]->fullname } @_; |
| 1384 |
} |
| 1385 |
|
| 1386 |
#- side-effects: flag_installed, flag_upgrade |
| 1387 |
sub _set_flag_installed_and_upgrade_if_no_newer { |
| 1388 |
my ($db, $pkg) = @_; |
| 1389 |
|
| 1390 |
!$pkg->flag_upgrade && !$pkg->flag_installed or return; |
| 1391 |
|
| 1392 |
my $upgrade = 1; |
| 1393 |
$db->traverse_tag('name', [ $pkg->name ], sub { |
| 1394 |
my ($p) = @_; |
| 1395 |
$pkg->set_flag_installed; |
| 1396 |
$upgrade &&= $pkg->compare_pkg($p) > 0; |
| 1397 |
}); |
| 1398 |
$pkg->set_flag_upgrade($upgrade); |
| 1399 |
} |
| 1400 |
|
| 1401 |
#- side-effects: |
| 1402 |
#- + those of _set_rejected_old_package ($state->{rejected}) |
| 1403 |
sub _no_more_recent_installed_and_providing { |
| 1404 |
my ($urpm, $db, $state, $pkg, $required) = @_; |
| 1405 |
|
| 1406 |
my $allow = 1; |
| 1407 |
$db->traverse_tag('name', [ $pkg->name ], sub { |
| 1408 |
my ($p) = @_; |
| 1409 |
#- allow if a less recent package is installed, |
| 1410 |
if ($allow && $pkg->compare_pkg($p) <= 0) { |
| 1411 |
if ($required =~ /^\d+/ || $p->provides_overlap($required)) { |
| 1412 |
$urpm->{debug_URPM}("not selecting " . $pkg->fullname . " since the more recent " . $p->fullname . " is installed") if $urpm->{debug_URPM}; |
| 1413 |
_set_rejected_old_package($state, $pkg, $p); |
| 1414 |
$allow = 0; |
| 1415 |
} else { |
| 1416 |
$urpm->{debug_URPM}("the more recent " . $p->fullname . |
| 1417 |
" is installed, but does not provide $required whereas " . |
| 1418 |
$pkg->fullname . " does") if $urpm->{debug_URPM}; |
| 1419 |
} |
| 1420 |
} |
| 1421 |
}); |
| 1422 |
$allow; |
| 1423 |
} |
| 1424 |
|
| 1425 |
#- do the opposite of the resolve_requested: |
| 1426 |
#- unselect a package and extend to any package not requested that is no |
| 1427 |
#- longer needed by any other package. |
| 1428 |
#- return the packages that have been deselected. |
| 1429 |
#- |
| 1430 |
#- side-effects: flag_requested, flag_required, $state->{selected}, $state->{whatrequires} |
| 1431 |
#- + those of _remove_all_rejected_from ($state->{rejected}) |
| 1432 |
sub disable_selected { |
| 1433 |
my ($urpm, $db, $state, @pkgs_todo) = @_; |
| 1434 |
my @unselected; |
| 1435 |
|
| 1436 |
#- iterate over package needing unrequested one. |
| 1437 |
while (my $pkg = shift @pkgs_todo) { |
| 1438 |
exists $state->{selected}{$pkg->id} or next; |
| 1439 |
|
| 1440 |
#- keep a trace of what is deselected. |
| 1441 |
push @unselected, $pkg; |
| 1442 |
|
| 1443 |
#- perform a closure on rejected packages (removed, obsoleted or avoided). |
| 1444 |
my @rejected_todo = scalar $pkg->fullname; |
| 1445 |
while (my $fullname = shift @rejected_todo) { |
| 1446 |
push @rejected_todo, _remove_all_rejected_from($state, $fullname); |
| 1447 |
} |
| 1448 |
|
| 1449 |
#- the package being examined has to be unselected. |
| 1450 |
$urpm->{debug_URPM}("unselecting " . $pkg->fullname) if $urpm->{debug_URPM}; |
| 1451 |
$pkg->set_flag_requested(0); |
| 1452 |
$pkg->set_flag_required(0); |
| 1453 |
delete $state->{selected}{$pkg->id}; |
| 1454 |
|
| 1455 |
#- determine package that requires properties no longer available, so that they need to be |
| 1456 |
#- unselected too. |
| 1457 |
foreach my $n ($pkg->provides_nosense) { |
| 1458 |
foreach my $p (whatrequires($urpm, $state, $n)) { |
| 1459 |
exists $state->{selected}{$p->id} or next; |
| 1460 |
if (unsatisfied_requires($urpm, $db, $state, $p, name => $n)) { |
| 1461 |
#- this package has broken dependencies and is selected. |
| 1462 |
push @pkgs_todo, $p; |
| 1463 |
} |
| 1464 |
} |
| 1465 |
} |
| 1466 |
|
| 1467 |
#- clean whatrequires hash. |
| 1468 |
foreach ($pkg->requires_nosense) { |
| 1469 |
delete $state->{whatrequires}{$_}{$pkg->id}; |
| 1470 |
%{$state->{whatrequires}{$_}} or delete $state->{whatrequires}{$_}; |
| 1471 |
} |
| 1472 |
} |
| 1473 |
|
| 1474 |
#- return all unselected packages. |
| 1475 |
@unselected; |
| 1476 |
} |
| 1477 |
|
| 1478 |
#- determine dependencies that can safely been removed and are not requested |
| 1479 |
#- return the packages that have been deselected. |
| 1480 |
#- |
| 1481 |
#- side-effects: |
| 1482 |
#- + those of disable_selected (flag_requested, flag_required, $state->{selected}, $state->{whatrequires}, $state->{rejected}) |
| 1483 |
sub disable_selected_and_unrequested_dependencies { |
| 1484 |
my ($urpm, $db, $state, @pkgs_todo) = @_; |
| 1485 |
my @all_unselected; |
| 1486 |
|
| 1487 |
#- disable selected packages, then extend unselection to all required packages |
| 1488 |
#- no longer needed and not requested. |
| 1489 |
while (my @unselected = disable_selected($urpm, $db, $state, @pkgs_todo)) { |
| 1490 |
my %required; |
| 1491 |
|
| 1492 |
#- keep in the packages that had to be unselected. |
| 1493 |
@all_unselected or push @all_unselected, @unselected; |
| 1494 |
|
| 1495 |
last if $urpm->{keep_unrequested_dependencies}; |
| 1496 |
|
| 1497 |
#- search for unrequested required packages. |
| 1498 |
foreach (@unselected) { |
| 1499 |
foreach ($_->requires_nosense) { |
| 1500 |
foreach my $pkg (grep { $_ } $urpm->packages_providing($_)) { |
| 1501 |
$state->{selected}{$pkg->id} or next; |
| 1502 |
$state->{selected}{$pkg->id}{psel} && $state->{selected}{$state->{selected}{$pkg->id}{psel}->id} and next; |
| 1503 |
$pkg->flag_requested and next; |
| 1504 |
$required{$pkg->id} = undef; |
| 1505 |
} |
| 1506 |
} |
| 1507 |
} |
| 1508 |
|
| 1509 |
#- check required packages are not needed by another selected package. |
| 1510 |
foreach (keys %required) { |
| 1511 |
my $pkg = $urpm->{depslist}[$_] or next; |
| 1512 |
foreach ($pkg->provides_nosense) { |
| 1513 |
foreach my $p_id (whatrequires_id($state, $_)) { |
| 1514 |
exists $required{$p_id} and next; |
| 1515 |
$state->{selected}{$p_id} and $required{$pkg->id} = 1; |
| 1516 |
} |
| 1517 |
} |
| 1518 |
} |
| 1519 |
|
| 1520 |
#- now required values still undefined indicates packages than can be removed. |
| 1521 |
@pkgs_todo = map { $urpm->{depslist}[$_] } grep { !$required{$_} } keys %required; |
| 1522 |
} |
| 1523 |
|
| 1524 |
@all_unselected; |
| 1525 |
} |
| 1526 |
|
| 1527 |
#- compute selected size by removing any removed or obsoleted package. |
| 1528 |
#- |
| 1529 |
#- side-effects: none |
| 1530 |
sub selected_size { |
| 1531 |
my ($urpm, $state) = @_; |
| 1532 |
my ($size) = _selected_size_filesize($urpm, $state, 0); |
| 1533 |
$size; |
| 1534 |
} |
| 1535 |
#- side-effects: none |
| 1536 |
sub selected_size_filesize { |
| 1537 |
my ($urpm, $state) = @_; |
| 1538 |
_selected_size_filesize($urpm, $state, 1); |
| 1539 |
} |
| 1540 |
#- side-effects: none |
| 1541 |
sub _selected_size_filesize { |
| 1542 |
my ($urpm, $state, $compute_filesize) = @_; |
| 1543 |
my ($size, $filesize, $bad_filesize); |
| 1544 |
|
| 1545 |
foreach (keys %{$state->{selected} || {}}) { |
| 1546 |
my $pkg = $urpm->{depslist}[$_]; |
| 1547 |
$size += $pkg->size; |
| 1548 |
$compute_filesize or next; |
| 1549 |
|
| 1550 |
if (my $n = $pkg->filesize) { |
| 1551 |
$filesize += $n; |
| 1552 |
} elsif (!$bad_filesize) { |
| 1553 |
$urpm->{debug} and $urpm->{debug}("no filesize for package " . $pkg->fullname); |
| 1554 |
$bad_filesize = 1; |
| 1555 |
} |
| 1556 |
} |
| 1557 |
|
| 1558 |
foreach (values %{$state->{rejected} || {}}) { |
| 1559 |
$_->{removed} || $_->{obsoleted} or next; |
| 1560 |
$size -= abs($_->{size}); |
| 1561 |
} |
| 1562 |
|
| 1563 |
foreach (@{$state->{orphans_to_remove} || []}) { |
| 1564 |
$size -= $_->size; |
| 1565 |
} |
| 1566 |
|
| 1567 |
$size, $bad_filesize ? 0 : $filesize; |
| 1568 |
} |
| 1569 |
|
| 1570 |
#- compute installed flags for all packages in depslist. |
| 1571 |
#- |
| 1572 |
#- side-effects: flag_upgrade, flag_installed |
| 1573 |
sub compute_installed_flags { |
| 1574 |
my ($urpm, $db) = @_; |
| 1575 |
|
| 1576 |
#- first pass to initialize flags installed and upgrade for all packages. |
| 1577 |
foreach (@{$urpm->{depslist}}) { |
| 1578 |
$_->is_arch_compat or next; |
| 1579 |
$_->flag_upgrade || $_->flag_installed or $_->set_flag_upgrade; |
| 1580 |
} |
| 1581 |
|
| 1582 |
#- second pass to set installed flag and clean upgrade flag according to installed packages. |
| 1583 |
$db->traverse(sub { |
| 1584 |
my ($p) = @_; |
| 1585 |
#- compute flags. |
| 1586 |
foreach my $pkg ($urpm->packages_providing($p->name)) { |
| 1587 |
next if !defined $pkg; |
| 1588 |
$pkg->is_arch_compat && $pkg->name eq $p->name or next; |
| 1589 |
#- compute only installed and upgrade flags. |
| 1590 |
$pkg->set_flag_installed; #- there is at least one package installed (whatever its version). |
| 1591 |
$pkg->flag_upgrade and $pkg->set_flag_upgrade($pkg->compare_pkg($p) > 0); |
| 1592 |
} |
| 1593 |
}); |
| 1594 |
} |
| 1595 |
|
| 1596 |
#- side-effects: flag_skip, flag_disable_obsolete |
| 1597 |
sub compute_flag { |
| 1598 |
my ($urpm, $pkg, %options) = @_; |
| 1599 |
foreach (qw(skip disable_obsolete)) { |
| 1600 |
if ($options{$_} && !$pkg->flag($_)) { |
| 1601 |
$pkg->set_flag($_, 1); |
| 1602 |
$options{callback} and $options{callback}->($urpm, $pkg, %options); |
| 1603 |
} |
| 1604 |
} |
| 1605 |
} |
| 1606 |
|
| 1607 |
#- Adds packages flags according to an array containing packages names. |
| 1608 |
#- $val is an array reference (as returned by get_packages_list) containing |
| 1609 |
#- package names, or a regular expression matching against the fullname, if |
| 1610 |
#- enclosed in slashes. |
| 1611 |
#- %options : |
| 1612 |
#- callback : sub to be called for each package where the flag is set |
| 1613 |
#- skip : if true, set the 'skip' flag |
| 1614 |
#- disable_obsolete : if true, set the 'disable_obsolete' flag |
| 1615 |
#- |
| 1616 |
#- side-effects: |
| 1617 |
#- + those of compute_flag (flag_skip, flag_disable_obsolete) |
| 1618 |
sub compute_flags { |
| 1619 |
my ($urpm, $val, %options) = @_; |
| 1620 |
my @regex; |
| 1621 |
|
| 1622 |
#- unless a regular expression is given, search in provides |
| 1623 |
foreach my $name (@$val) { |
| 1624 |
if ($name =~ m,^/(.*)/$,) { |
| 1625 |
push @regex, $1; |
| 1626 |
} else { |
| 1627 |
foreach my $pkg ($urpm->packages_providing($name)) { |
| 1628 |
compute_flag($urpm, $pkg, %options); |
| 1629 |
} |
| 1630 |
} |
| 1631 |
} |
| 1632 |
|
| 1633 |
#- now search packages which fullname match given regexps |
| 1634 |
if (@regex) { |
| 1635 |
my $large_re_s = join("|", map { "(?:$_)" } @regex); |
| 1636 |
my $re = qr/$large_re_s/; |
| 1637 |
|
| 1638 |
foreach my $pkg (@{$urpm->{depslist}}) { |
| 1639 |
if ($pkg->fullname =~ $re) { |
| 1640 |
compute_flag($urpm, $pkg, %options); |
| 1641 |
} |
| 1642 |
} |
| 1643 |
} |
| 1644 |
} |
| 1645 |
|
| 1646 |
#- side-effects: none |
| 1647 |
sub _choose_best_pkg { |
| 1648 |
my ($urpm, $pkg_installed, @pkgs) = @_; |
| 1649 |
|
| 1650 |
_choose_best_pkg_($urpm, $pkg_installed, grep { $_->compare_pkg($pkg_installed) > 0 } @pkgs); |
| 1651 |
} |
| 1652 |
|
| 1653 |
#- side-effects: none |
| 1654 |
sub _choose_best_pkg_ { |
| 1655 |
my ($urpm, $pkg_installed, @pkgs) = @_; |
| 1656 |
|
| 1657 |
my $best; |
| 1658 |
foreach my $pkg (grep { |
| 1659 |
!strict_arch($urpm) || strict_arch_check($pkg_installed, $_); |
| 1660 |
} @pkgs) { |
| 1661 |
if (!$best || ($pkg->compare_pkg($best) || $pkg->id < $best->id) > 0) { |
| 1662 |
$best = $pkg; |
| 1663 |
} |
| 1664 |
} |
| 1665 |
$best; |
| 1666 |
} |
| 1667 |
|
| 1668 |
#- side-effects: none |
| 1669 |
sub _choose_bests_obsolete { |
| 1670 |
my ($urpm, $db, $pkg_installed, @pkgs) = @_; |
| 1671 |
|
| 1672 |
_set_flag_installed_and_upgrade_if_no_newer($db, $_) foreach @pkgs; |
| 1673 |
|
| 1674 |
my %by_name; |
| 1675 |
push @{$by_name{$_->name}}, $_ foreach grep { $_->flag_upgrade } @pkgs; |
| 1676 |
|
| 1677 |
map { _choose_best_pkg_($urpm, $pkg_installed, @$_) } values %by_name; |
| 1678 |
} |
| 1679 |
|
| 1680 |
#- select packages to upgrade, according to package already registered. |
| 1681 |
#- by default, only takes best package and its obsoleted and compute |
| 1682 |
#- all installed or upgrade flag. |
| 1683 |
#- (used for --auto-select) |
| 1684 |
#- |
| 1685 |
#- side-effects: $requisted, flag_installed, flag_upgrade |
| 1686 |
sub request_packages_to_upgrade { |
| 1687 |
my ($urpm, $db, $state, $requested, %options) = @_; |
| 1688 |
|
| 1689 |
my %by_name; |
| 1690 |
|
| 1691 |
#- now we can examine all existing packages to find packages to upgrade. |
| 1692 |
$db->traverse(sub { |
| 1693 |
my ($pkg_installed) = @_; |
| 1694 |
my $name = $pkg_installed->name; |
| 1695 |
my $pkg; |
| 1696 |
if (exists $by_name{$name}) { |
| 1697 |
if (my $p = $by_name{$name}) { |
| 1698 |
#- here a pkg with the same name is installed twice |
| 1699 |
if ($p->compare_pkg($pkg_installed) > 0) { |
| 1700 |
#- we selected $p, and it is still a valid choice |
| 1701 |
$pkg = $p; |
| 1702 |
} else { |
| 1703 |
#- $p is no good since $pkg_installed is higher version, |
| 1704 |
} |
| 1705 |
} |
| 1706 |
} elsif ($pkg = _choose_best_pkg($urpm, $pkg_installed, $urpm->packages_by_name($name))) { |
| 1707 |
#- first try with package using the same name. |
| 1708 |
$pkg->set_flag_installed; |
| 1709 |
$pkg->set_flag_upgrade; |
| 1710 |
} |
| 1711 |
if (my @pkgs = _choose_bests_obsolete($urpm, $db, $pkg_installed, _find_packages_obsoleting($urpm, $state, $pkg_installed))) { |
| 1712 |
if (@pkgs == 1) { |
| 1713 |
$pkg and $urpm->{debug_URPM}("auto-select: prefering " . $pkgs[0]->fullname . " obsoleting " . $pkg_installed->fullname . " over " . $pkg->fullname) if $urpm->{debug_URPM}; |
| 1714 |
$pkg = $pkgs[0]; |
| 1715 |
} elsif (@pkgs > 1) { |
| 1716 |
$urpm->{debug_URPM}("auto-select: multiple packages (" . join(' ', map { scalar $_->fullname } @pkgs) . ") obsoleting " . $pkg_installed->fullname) if $urpm->{debug_URPM}; |
| 1717 |
$pkg = undef; |
| 1718 |
} |
| 1719 |
} |
| 1720 |
if ($pkg && $options{idlist} && !any { $pkg->id == $_ } @{$options{idlist}}) { |
| 1721 |
$urpm->{debug_URPM}("not auto-selecting " . $pkg->fullname . "because it's not in search medias") if $urpm->{debug_URPM}; |
| 1722 |
$pkg = undef; |
| 1723 |
} |
| 1724 |
|
| 1725 |
$pkg and $urpm->{debug_URPM}("auto-select: adding " . $pkg->fullname . " replacing " . $pkg_installed->fullname) if $urpm->{debug_URPM}; |
| 1726 |
|
| 1727 |
$by_name{$name} = $pkg; |
| 1728 |
}); |
| 1729 |
|
| 1730 |
foreach my $pkg (values %by_name) { |
| 1731 |
$pkg or next; |
| 1732 |
$pkg->set_flag_upgrade; |
| 1733 |
$requested->{$pkg->id} = $options{requested}; |
| 1734 |
} |
| 1735 |
|
| 1736 |
$requested; |
| 1737 |
} |
| 1738 |
|
| 1739 |
#- side-effects: none |
| 1740 |
sub _sort_by_dependencies_get_graph { |
| 1741 |
my ($urpm, $state, $l) = @_; |
| 1742 |
my %edges; |
| 1743 |
foreach my $id (@$l) { |
| 1744 |
my $pkg = $urpm->{depslist}[$id]; |
| 1745 |
my @provides = map { whatrequires_id($state, $_) } $pkg->provides_nosense; |
| 1746 |
if (my $from = $state->{selected}{$id}{from}) { |
| 1747 |
unshift @provides, $from->id; |
| 1748 |
} |
| 1749 |
$edges{$id} = [ uniq(@provides) ]; |
| 1750 |
} |
| 1751 |
\%edges; |
| 1752 |
} |
| 1753 |
|
| 1754 |
#- side-effects: none |
| 1755 |
sub reverse_multi_hash { |
| 1756 |
my ($h) = @_; |
| 1757 |
my %r; |
| 1758 |
my ($k, $v); |
| 1759 |
while (($k, $v) = each %$h) { |
| 1760 |
push @{$r{$_}}, $k foreach @$v; |
| 1761 |
} |
| 1762 |
\%r; |
| 1763 |
} |
| 1764 |
|
| 1765 |
sub _merge_2_groups { |
| 1766 |
my ($groups, $l1, $l2) = @_; |
| 1767 |
my $l = [ @$l1, @$l2 ]; |
| 1768 |
$groups->{$_} = $l foreach @$l; |
| 1769 |
$l; |
| 1770 |
} |
| 1771 |
sub _add_group { |
| 1772 |
my ($groups, $group) = @_; |
| 1773 |
|
| 1774 |
my ($main, @other) = uniq(grep { $_ } map { $groups->{$_} } @$group); |
| 1775 |
$main ||= []; |
| 1776 |
if (@other) { |
| 1777 |
$main = _merge_2_groups($groups, $main, $_) foreach @other; |
| 1778 |
} |
| 1779 |
foreach (grep { !$groups->{$_} } @$group) { |
| 1780 |
$groups->{$_} ||= $main; |
| 1781 |
push @$main, $_; |
| 1782 |
my @l_ = uniq(@$main); |
| 1783 |
@l_ == @$main or die ''; |
| 1784 |
} |
| 1785 |
# warn "# groups: ", join(' ', map { join('+', @$_) } uniq(values %$groups)), "\n"; |
| 1786 |
} |
| 1787 |
|
| 1788 |
#- nb: this handles $nodes list not containing all $nodes that can be seen in $edges |
| 1789 |
#- |
| 1790 |
#- side-effects: none |
| 1791 |
sub sort_graph { |
| 1792 |
my ($nodes, $edges) = @_; |
| 1793 |
|
| 1794 |
#require Data::Dumper; |
| 1795 |
#warn Data::Dumper::Dumper($nodes, $edges); |
| 1796 |
|
| 1797 |
my %nodes_h = map { $_ => 1 } @$nodes; |
| 1798 |
my (%loops, %added, @sorted); |
| 1799 |
|
| 1800 |
my $recurse; $recurse = sub { |
| 1801 |
my ($id, @ids) = @_; |
| 1802 |
# warn "# recurse $id @ids\n"; |
| 1803 |
|
| 1804 |
my $loop_ahead; |
| 1805 |
foreach my $p_id (@{$edges->{$id}}) { |
| 1806 |
if ($p_id == $id) { |
| 1807 |
# don't care |
| 1808 |
} elsif (exists $added{$p_id}) { |
| 1809 |
# already done |
| 1810 |
} elsif (any { $_ == $p_id } @ids) { |
| 1811 |
my $begin = 1; |
| 1812 |
my @l = grep { $begin &&= $_ != $p_id } @ids; |
| 1813 |
$loop_ahead = 1; |
| 1814 |
_add_group(\%loops, [ $p_id, $id, @l ]); |
| 1815 |
} elsif ($loops{$p_id}) { |
| 1816 |
my $take; |
| 1817 |
if (my @l = grep { $take ||= $loops{$_} && $loops{$_} == $loops{$p_id} } reverse @ids) { |
| 1818 |
$loop_ahead = 1; |
| 1819 |
# warn "# loop to existing one $p_id, $id, @l\n"; |
| 1820 |
_add_group(\%loops, [ $p_id, $id, @l ]); |
| 1821 |
} |
| 1822 |
} else { |
| 1823 |
$recurse->($p_id, $id, @ids); |
| 1824 |
#- we would need to compute loop_ahead. we will do it below only once, and if not already set |
| 1825 |
} |
| 1826 |
} |
| 1827 |
if (!$loop_ahead && $loops{$id} && grep { exists $loops{$_} && $loops{$_} == $loops{$id} } @ids) { |
| 1828 |
$loop_ahead = 1; |
| 1829 |
} |
| 1830 |
|
| 1831 |
if (!$loop_ahead) { |
| 1832 |
#- it's now a leaf or a loop we're done with |
| 1833 |
my @toadd = $loops{$id} ? @{$loops{$id}} : $id; |
| 1834 |
$added{$_} = undef foreach @toadd; |
| 1835 |
# warn "# adding ", join('+', @toadd), " for $id\n"; |
| 1836 |
push @sorted, [ uniq(grep { $nodes_h{$_} } @toadd) ]; |
| 1837 |
} |
| 1838 |
}; |
| 1839 |
!exists $added{$_} and $recurse->($_) foreach @$nodes; |
| 1840 |
|
| 1841 |
# warn "# result: ", join(' ', map { join('+', @$_) } @sorted), "\n"; |
| 1842 |
|
| 1843 |
check_graph_is_sorted(\@sorted, $nodes, $edges) or die "sort_graph failed"; |
| 1844 |
|
| 1845 |
@sorted; |
| 1846 |
} |
| 1847 |
|
| 1848 |
#- side-effects: none |
| 1849 |
sub check_graph_is_sorted { |
| 1850 |
my ($sorted, $nodes, $edges) = @_; |
| 1851 |
|
| 1852 |
my $i = 1; |
| 1853 |
my %nb; |
| 1854 |
foreach (@$sorted) { |
| 1855 |
$nb{$_} = $i foreach @$_; |
| 1856 |
$i++; |
| 1857 |
} |
| 1858 |
my $nb_errors = 0; |
| 1859 |
my $error = sub { $nb_errors++; warn "error: $_[0]\n" }; |
| 1860 |
|
| 1861 |
foreach my $id (@$nodes) { |
| 1862 |
$nb{$id} or $error->("missing $id in sort_graph list"); |
| 1863 |
} |
| 1864 |
foreach my $id (keys %$edges) { |
| 1865 |
my $id_i = $nb{$id} or next; |
| 1866 |
foreach my $req (@{$edges->{$id}}) { |
| 1867 |
my $req_i = $nb{$req} or next; |
| 1868 |
$req_i <= $id_i or $error->("$req should be before $id ($req_i $id_i)"); |
| 1869 |
} |
| 1870 |
} |
| 1871 |
$nb_errors == 0; |
| 1872 |
} |
| 1873 |
|
| 1874 |
|
| 1875 |
#- side-effects: none |
| 1876 |
sub _sort_by_dependencies__add_obsolete_edges { |
| 1877 |
my ($urpm, $state, $l, $requires) = @_; |
| 1878 |
|
| 1879 |
my @obsoletes = grep { $_->{obsoleted} } values %{$state->{rejected}} or return; |
| 1880 |
my @groups = grep { @$_ > 1 } map { [ keys %{$_->{closure}} ] } @obsoletes; |
| 1881 |
my %groups; |
| 1882 |
foreach my $group (@groups) { |
| 1883 |
_add_group(\%groups, $group); |
| 1884 |
foreach (@$group) { |
| 1885 |
my $rej = $state->{rejected}{$_} or next; |
| 1886 |
_add_group(\%groups, [ $_, keys %{$rej->{closure}} ]); |
| 1887 |
} |
| 1888 |
} |
| 1889 |
|
| 1890 |
my %fullnames = map { scalar($urpm->{depslist}[$_]->fullname) => $_ } @$l; |
| 1891 |
foreach my $group (uniq(values %groups)) { |
| 1892 |
my @group = grep { defined $_ } map { $fullnames{$_} } @$group; |
| 1893 |
foreach (@group) { |
| 1894 |
@{$requires->{$_}} = uniq(@{$requires->{$_}}, @group); |
| 1895 |
} |
| 1896 |
} |
| 1897 |
} |
| 1898 |
|
| 1899 |
#- side-effects: none |
| 1900 |
sub sort_by_dependencies { |
| 1901 |
my ($urpm, $state, @list_unsorted) = @_; |
| 1902 |
@list_unsorted = sort { $a <=> $b } @list_unsorted; # sort by ids to be more reproductable |
| 1903 |
$urpm->{debug_URPM}("getting graph of dependencies for sorting") if $urpm->{debug_URPM}; |
| 1904 |
my $edges = _sort_by_dependencies_get_graph($urpm, $state, \@list_unsorted); |
| 1905 |
my $requires = reverse_multi_hash($edges); |
| 1906 |
|
| 1907 |
_sort_by_dependencies__add_obsolete_edges($urpm, $state, \@list_unsorted, $requires); |
| 1908 |
|
| 1909 |
$urpm->{debug_URPM}("sorting graph of dependencies") if $urpm->{debug_URPM}; |
| 1910 |
sort_graph(\@list_unsorted, $requires); |
| 1911 |
} |
| 1912 |
|
| 1913 |
sub sorted_rpms_to_string { |
| 1914 |
my ($urpm, @sorted) = @_; |
| 1915 |
|
| 1916 |
"rpms sorted by dependencies:\n" . join("\n", map { |
| 1917 |
join('+', _ids_to_names($urpm, @$_)); |
| 1918 |
} @sorted); |
| 1919 |
} |
| 1920 |
|
| 1921 |
#- build transaction set for given selection |
| 1922 |
#- options: start, end, idlist, split_length, keep |
| 1923 |
#- |
| 1924 |
#- side-effects: $state->{transaction}, $state->{transaction_state} |
| 1925 |
sub build_transaction_set { |
| 1926 |
my ($urpm, $db, $state, %options) = @_; |
| 1927 |
|
| 1928 |
#- clean transaction set. |
| 1929 |
$state->{transaction} = []; |
| 1930 |
|
| 1931 |
my %selected_id; |
| 1932 |
@selected_id{$urpm->build_listid($options{start}, $options{end}, $options{idlist})} = (); |
| 1933 |
|
| 1934 |
if ($options{split_length}) { |
| 1935 |
#- first step consists of sorting packages according to dependencies. |
| 1936 |
my @sorted = sort_by_dependencies($urpm, $state, |
| 1937 |
keys(%selected_id) > 0 ? |
| 1938 |
(grep { exists($selected_id{$_}) } keys %{$state->{selected}}) : |
| 1939 |
keys %{$state->{selected}}); |
| 1940 |
$urpm->{debug_URPM}(sorted_rpms_to_string($urpm, @sorted)) if $urpm->{debug_URPM}; |
| 1941 |
|
| 1942 |
#- second step consists of re-applying resolve_requested in the same |
| 1943 |
#- order computed in first step and to update a list of packages to |
| 1944 |
#- install, to upgrade and to remove. |
| 1945 |
my %examined; |
| 1946 |
my @todo = @sorted; |
| 1947 |
while (@todo) { |
| 1948 |
my @ids; |
| 1949 |
while (@todo && @ids < $options{split_length}) { |
| 1950 |
my $l = shift @todo; |
| 1951 |
push @ids, @$l; |
| 1952 |
} |
| 1953 |
my %requested = map { $_ => undef } @ids; |
| 1954 |
|
| 1955 |
resolve_requested__no_suggests_($urpm, |
| 1956 |
$db, $state->{transaction_state} ||= {}, |
| 1957 |
\%requested, |
| 1958 |
defined $options{start} ? (start => $options{start}) : @{[]}, |
| 1959 |
defined $options{end} ? (end => $options{end}) : @{[]}, |
| 1960 |
keep => $options{keep}, |
| 1961 |
); |
| 1962 |
|
| 1963 |
my @upgrade = grep { ! exists $examined{$_} } keys %{$state->{transaction_state}{selected}}; |
| 1964 |
my @remove = grep { ! exists $examined{$_} } packages_to_remove($state->{transaction_state}); |
| 1965 |
|
| 1966 |
@upgrade || @remove or next; |
| 1967 |
|
| 1968 |
if (my @bad_remove = grep { !$state->{rejected}{$_}{removed} || $state->{rejected}{$_}{obsoleted} } @remove) { |
| 1969 |
$urpm->{error}(sorted_rpms_to_string($urpm, @sorted)) if $urpm->{error}; |
| 1970 |
$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}; |
| 1971 |
$state->{transaction} = []; |
| 1972 |
last; |
| 1973 |
} |
| 1974 |
|
| 1975 |
$urpm->{debug_URPM}(sprintf('transaction valid: remove=%s update=%s', |
| 1976 |
join(',', @remove), |
| 1977 |
join(',', _ids_to_names($urpm, @upgrade)))) if $urpm->{debug_URPM}; |
| 1978 |
|
| 1979 |
$examined{$_} = undef foreach @upgrade, @remove; |
| 1980 |
push @{$state->{transaction}}, { upgrade => \@upgrade, remove => \@remove }; |
| 1981 |
} |
| 1982 |
|
| 1983 |
#- check that the transaction set has been correctly created. |
| 1984 |
#- (ie that no other package was removed) |
| 1985 |
if (keys(%{$state->{selected}}) == keys(%{$state->{transaction_state}{selected}}) && |
| 1986 |
listlength(packages_to_remove($state)) == listlength(packages_to_remove($state->{transaction_state})) |
| 1987 |
) { |
| 1988 |
foreach (keys(%{$state->{selected}})) { |
| 1989 |
exists $state->{transaction_state}{selected}{$_} and next; |
| 1990 |
$urpm->{error}('using one big transaction') if $urpm->{error}; |
| 1991 |
$state->{transaction} = []; last; |
| 1992 |
} |
| 1993 |
foreach (packages_to_remove($state)) { |
| 1994 |
$state->{transaction_state}{rejected}{$_}{removed} && |
| 1995 |
!$state->{transaction_state}{rejected}{$_}{obsoleted} and next; |
| 1996 |
$urpm->{error}('using one big transaction') if $urpm->{error}; |
| 1997 |
$state->{transaction} = []; last; |
| 1998 |
} |
| 1999 |
} |
| 2000 |
} |
| 2001 |
|
| 2002 |
#- fallback if something can be selected but nothing has been allowed in transaction list. |
| 2003 |
if (%{$state->{selected} || {}} && !@{$state->{transaction}}) { |
| 2004 |
$urpm->{debug_URPM}('using one big transaction') if $urpm->{debug_URPM}; |
| 2005 |
push @{$state->{transaction}}, { |
| 2006 |
upgrade => [ keys %{$state->{selected}} ], |
| 2007 |
remove => [ packages_to_remove($state) ], |
| 2008 |
}; |
| 2009 |
} |
| 2010 |
|
| 2011 |
if ($state->{orphans_to_remove}) { |
| 2012 |
my @l = map { scalar $_->fullname } @{$state->{orphans_to_remove}}; |
| 2013 |
push @{$state->{transaction}}, { remove => \@l } if @l; |
| 2014 |
} |
| 2015 |
|
| 2016 |
$state->{transaction}; |
| 2017 |
} |
| 2018 |
|
| 2019 |
1; |
Parent Directory
| 
Revision Log