summaryrefslogtreecommitdiffstats
path: root/urpm.pm
diff options
context:
space:
mode:
Diffstat (limited to 'urpm.pm')
-rw-r--r--urpm.pm456
1 files changed, 4 insertions, 452 deletions
diff --git a/urpm.pm b/urpm.pm
index d75a2246..64925093 100644
--- a/urpm.pm
+++ b/urpm.pm
@@ -3,7 +3,7 @@ package urpm;
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.5';
+$VERSION = '3.6';
@ISA = qw(URPM);
=head1 NAME
@@ -740,14 +740,15 @@ sub update_media {
$error = 1, $urpm->{error}(_("copy of [%s] failed", "$with_hdlist_dir"));
#- check if the file are equals... and no force copy...
- unless ($error || $options{force}) {
+ unless ($error || $options{force} || ! -e "$urpm->{statedir}/synthesis.$medium->{hdlist}") {
my @sstat = stat "$urpm->{cachedir}/partial/$medium->{hdlist}";
my @lstat = stat "$urpm->{statedir}/$medium->{hdlist}";
if ($sstat[7] == $lstat[7] && $sstat[9] == $lstat[9]) {
#- the two files are considered equal here, the medium is so not modified.
$medium->{modified} = 0;
unlink "$urpm->{cachedir}/partial/$medium->{hdlist}";
- #- as previously done, just read synthesis file here, this is enough.
+ #- as previously done, just read synthesis file here, this is enough, but only
+ #- if synthesis exists, else it need to be recomputed.
$urpm->{log}(_("examining synthesis file [%s]", "$urpm->{statedir}/synthesis.$medium->{hdlist}"));
($medium->{start}, $medium->{end}) = $urpm->parse_synthesis("$urpm->{statedir}/synthesis.$medium->{hdlist}");
unless (defined $medium->{start} && defined $medium->{end}) {
@@ -1404,282 +1405,6 @@ sub search_packages {
$result;
}
-#- filter minimal list, upgrade packages only according to rpm requires
-#- satisfied, remove upgrade for package already installed or with a better
-#- version, try to upgrade to minimize upgrade errors.
-#- all additional package selected have a true value.
-sub filter_packages_to_upgrade {
- my ($urpm, $db, $packages, $select_choices, %options) = @_;
- my ($id, %track, %track_requires, %installed, %selected, %conflicts);
- my @packages = keys %$packages;
-
- #- at this level, compute global closure of what is requested, regardless of
- #- choices for which all package in the choices are taken and their dependencies.
- #- allow iteration over a modifying list.
- while (defined($id = shift @packages)) {
- $id =~ /\|/ and delete $packages->{$id}, $id = [ split '\|', $id ]; #- get back choices...
- if (ref $id) {
- my (@forced_selection, @selection);
-
- #- at this point we have almost only choices to resolves.
- #- but we have to check if one package here is already selected
- #- previously, if this is the case, use it instead.
- #- if a choice is proposed with package already installed (this is the case for
- #- a provide with a lot of choices, we have to filter according to those who
- #- are installed).
- foreach (@$id) {
- my $pkg = $urpm->{depslist}[$_];
- $pkg->arch eq 'src' and return;
- my $count = $options{keep_alldeps} || exists $installed{$pkg->id} ? 0 :
- $db->traverse_tag('name', [ $pkg->name ], sub {
- my ($p) = @_;
- $installed{$pkg->id} ||= $pkg->compare_pkg($p) <= 0;
- });
- if (exists $packages->{$_} || $count > 0) {
- $installed{$pkg->id} or push @forced_selection, $_;
- } else {
- push @selection, $_;
- }
- }
-
- #- propose the choice to the user now, or select the best one (as it is supposed to be).
- @selection = @forced_selection ? @forced_selection :
- $select_choices ? (@selection > 1 ? ($select_choices->($urpm, undef, @selection)) : ($selection[0])) :
- (join '|', @selection);
- foreach (@selection) {
- unless (exists $packages->{$_}) {
- /\|/ or unshift @packages, $_;
- $packages->{$_} = 1;
- }
- }
- next;
- }
- my $pkg = $urpm->{depslist}[$id];
- defined $pkg->id or next; #- id has been removed for package that only exists on some arch.
-
- #- search for package that will be upgraded, and check the difference
- #- of provides to see if something will be altered and need to be upgraded.
- #- this is bogus as it only take care of == operator if any.
- #- defining %provides here could slow the algorithm but it solves multi-pass
- #- where a provides is A and after A == version-release, when A is already
- #- installed.
- my (%diff_provides, %provides);
-
- if ($pkg->arch ne 'src') {
- my @upgraded;
-
- foreach ($pkg->name, $pkg->obsoletes) {
- if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- $db->traverse_tag('name', [ $n ], sub {
- my ($p) = @_;
- eval($p->compare($v) . $o . 0) or return;
- $options{track} and $p->pack_header, push @upgraded, $p;
- foreach ($p->provides) {
- s/\[\*\]//;
- s/\[([^\]]*)\]/ $1/;
- $diff_provides{$_} = $p->fullname;
- }
- });
- }
- }
- $options{track} and $track{$pkg->id}{upgraded} = \@upgraded;
-
- foreach ($pkg->provides) {
- s/\[\*\]//;
- s/\[([^\]]*)\]/ $1/;
- delete $diff_provides{$_};
- }
-
- foreach (keys %diff_provides) {
- #- analyse the difference in provides and select other package.
- if (my ($n, $o, $v) = /^(\S*)\s*(\S*)\s*(\S*)/) {
- my $check = sub {
- my ($p) = @_;
- my ($needed, $satisfied) = (0, 0);
- foreach ($p->requires) {
- if (my ($pn, $po, $pv) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- if ($po || $o) {
- $pn eq $n && $pn eq $pkg->name or next;
- ++$needed;
- eval($pkg->compare($pv) . $po . 0) or next;
- #- an existing provides (propably the one examined) is satisfying the underlying.
- ++$satisfied;
- } else {
- $pn eq $n or next;
- #- a property has been removed since in diff_provides.
- ++$needed;
- }
- }
- }
- #- check if the package need to be updated because it
- #- losts some of its requires regarding the current diff_provides.
- if ($needed > $satisfied) {
- $selected{$p->name} ||= undef;
- if ($options{track}) {
- $p->pack_header;
- push @{$track{$pkg->id}{diff_provides} ||= []}, $p;
- }
- }
- };
- $db->traverse_tag('whatrequires', [ $n ], $check);
- }
- }
-
- $selected{$pkg->name} ||= undef;
- }
-
- #- iterate over requires of the packages, register them.
- foreach ($pkg->requires) {
- if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- exists $provides{$_} and next;
- #- if the provides is not found, it will be resolved at next step, else
- #- it will be resolved by searching the rpm database.
- $provides{$_} ||= undef;
- unless ($options{keep_alldeps}) {
- my $check_pkg = sub {
- my ($p) = @_;
- exists $selected{$p->name} and return;
- $o and $n eq $p->name || return;
- eval($p->compare($v) . $o . 0) or return;
- $provides{$_} = $p->fullname;
- };
- $db->traverse_tag($n =~ m|^/| ? 'path' : 'whatprovides', [ $n ], $check_pkg);
- }
- $options{track} and $track_requires{$_}{$pkg->id} = $_;
- }
- }
-
- #- examine conflicts and try to resolve them.
- #- if there is a conflicts with a too old version, it need to be upgraded.
- #- if there is a provides (by using a obsoletes on it too), examine obsolete (provides) too.
- foreach ($pkg->conflicts) {
- if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- my $check_pkg = sub {
- my ($p) = @_;
- $o and $n eq $p->name || return;
- eval($p->compare($v) . $o . 0) or return;
- $conflicts{$p->fullname} = 1;
- $selected{$p->name} ||= undef;
- if ($options{track}) {
- $p->pack_header;
- push @{$track{$pkg->id}{conflicts} ||= []}, $p;
- }
- };
- $db->traverse_tag($n =~ m|^/| ? 'path' : 'whatprovides', [ $n ], $check_pkg);
- foreach my $id (keys %{$urpm->{provides}{$n} || {}}) {
- my $p = $urpm->{depslist}[$id];
- $p->arch eq 'src' and next;
- $o and $n eq $p->name || next;
- eval($p->compare($v) . $o . 0) or next;
- $conflicts{$p->fullname} ||= 0;
- }
- }
- }
-
- #- at this point, all unresolved provides (requires) should be fixed by
- #- provides files, try to minimize choice at this level.
- foreach (keys %provides, grep { !$selected{$_} } keys %selected) {
- my (%pre_choices, @pre_choices, @choices, @upgradable_choices, %choices_id);
- if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- $provides{$_} and next;
-
- foreach my $id (keys %{$urpm->{provides}{$n} || {}}) {
- my $pkg = $urpm->{depslist}[$id];
- exists $conflicts{$pkg->fullname} and next;
- $pkg->arch eq 'src' and next;
- $selected{$n} || $selected{$pkg->name} and %pre_choices=(), last;
- #- check if a unsatisfied selection on a package is needed,
- #- which need a obsolete on a package with different name or
- #- a package with the given name.
- #- if an obsolete is given, it will be satisfied elsewhere. CHECK TODO
- if ($n ne $pkg->name) {
- unless (exists $selected{$n}) {
- #- a virtual provides exists with a specific version and maybe release.
- #- try to resolve.
- foreach ($pkg->provides) {
- if (my ($pn, $po, $pv) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- $pn eq $n or next;
- my $no = $po eq '==' ? $o : $po; #- CHECK TODO ?
-#TODO (!$pv || !$v || eval(rpmtools::version_compare($pv, $v) . $no . 0)) &&
-#TODO (!$pr || !$r || rpmtools::version_compare($pv, $v) != 0 ||
-#TODO eval(rpmtools::version_compare($pr, $r) . $no . 0)) or next;
- push @{$pre_choices{$pkg->name}}, $pkg;
- }
- }
- }
- } else {
- eval($pkg->compare($v) . $o . 0) or next;
- push @{$pre_choices{$pkg->name}}, $pkg;
- }
- }
- }
- foreach (values %pre_choices) {
- #- there is at least one element in each list of values.
- if (@$_ == 1) {
- push @pre_choices, $_->[0];
- } else {
- #- take the best one, according to id used.
- my $chosen_pkg;
- foreach my $id (%$packages) {
- my $candidate_pkg = $urpm->{depslist}[$id];
- $candidate_pkg->name eq $pkg->name or next;
- foreach my $pkg (@$_) {
- $pkg == $candidate_pkg and $chosen_pkg = $pkg, last;
- }
- }
- $chosen_pkg ||= $urpm->{names}{$_->[0]->name}; #- at least take the best normally used.
- push @pre_choices, $chosen_pkg;
- }
- }
- foreach my $pkg (@pre_choices) {
- push @choices, $pkg;
-
- $pkg->arch eq 'src' and return;
- unless ($options{keep_alldeps} || exists $installed{$pkg->id}) {
- $db->traverse_tag('name', [ $pkg->name ], sub {
- my ($p) = @_;
- $installed{$pkg->id} ||= $pkg->compare_pkg($p) <= 0;
- });
- }
- $installed{$pkg->id} and delete $packages->{$pkg->id};
- exists $installed{$pkg->id} and push @upgradable_choices, $pkg;
- }
- foreach my $pkg (@pre_choices) {
- if (exists $packages->{$pkg->id} || $installed{$pkg->id}) {
- #- the package is already selected, or installed with a better version and release.
- @choices = @upgradable_choices = ();
- last;
- }
- }
- @upgradable_choices > 0 and @choices = @upgradable_choices;
- $choices_id{$_->id} = $_ foreach @choices;
- if (keys(%choices_id) == 1) {
- my ($id) = keys(%choices_id);
- $selected{$choices_id{$id}->name} = 1;
- unless ($packages->{$id}) {
- $packages->{$id} = 1;
- if ($options{track} && $track_requires{$_}) {
- foreach my $deps (keys %{$track_requires{$_}}) {
- $track{$deps}{requires}{$id} = $_;
- }
- }
- }
- unshift @packages, $id;
- } elsif (keys(%choices_id) > 1) {
- push @packages, [ sort { $a <=> $b } keys %choices_id ];
- if ($options{track} && $track_requires{$_}) {
- foreach my $deps (keys %{$track_requires{$_}}) {
- $track{$deps}{requires}{join '|', sort { $a <=> $b } keys %choices_id} = $_;
- }
- }
- }
- }
- }
-
- #- rpm db will be closed automatically on destruction of $db.
- \%track;
-}
-
#- get out of package that should not be upgraded.
sub deselect_unwanted_packages {
my ($urpm, $packages, %options) = @_;
@@ -1952,177 +1677,4 @@ sub extract_packages_to_install {
\%inst;
}
-sub select_packages_to_upgrade {
- my ($urpm, $db, $packages, $remove_packages, $keep_files, %options) = @_;
-
- #- used for package that are not correctly updated.
- #- should only be used when nothing else can be done correctly.
- my %upgradeNeedRemove = (
- #'libstdc++' => 1,
- #'compat-glibc' => 1,
- #'compat-libs' => 1,
- );
-
- #- installed flag on id.
- my %installed;
-
- #- help removing package which may have different release numbering
- my %toRemove;
-
- #- help searching package to upgrade in regard to already installed files.
- my %installedFilesForUpgrade;
-
- #- help keeping memory by this set of package that have been obsoleted.
- my %obsoletedPackages;
-
- #- select packages which obseletes other package, obselete package are not removed,
- #- should we remove them ? this could be dangerous !
- foreach my $pkg (@{$urpm->{depslist}}) {
- defined $pkg->id && $pkg->arch ne 'src' or next;
- foreach ($pkg->obsoletes) {
- #- take care of flags and version and release if present
- if (my ($n,$o,$v) = /^([^\s\[]*)(?:\[\*\])?(?:\s+|\[)?([^\s\]]*)\s*([^\s\]]*)/) {
- my $obsoleted = 0;
- my $check_obsoletes = sub {
- my ($p) = @_;
- eval($p->compare($v) . $o . 0) or return;
- ++$obsoleted;
- };
- $db->traverse_tag("name", [ $n ], $check_obsoletes);
- if ($obsoleted > 0) {
- $urpm->{log}(_("selecting %s using obsoletes", $pkg->fullname));
- $obsoletedPackages{$n} = undef;
- exists $packages->{$pkg->id} or $packages->{$pkg->id} = 1;
- }
- }
- }
- }
-
- #- mark all files which are not in /dev or /etc/rc.d/ for packages which are already installed
- #- but which are not in the packages list to upgrade.
- #- the 'installed' property will make a package unable to be selected, look at select.
- $db->traverse(sub {
- my ($p) = @_;
- my $otherPackage = $p->release !~ /mdk\w*$/ && ($p->name.'-'.$p->version.'-'.$p->release);
- my $pkg = $urpm->{names}{$p->name};
-
- if ($pkg) {
- if ($p->compare_pkg($pkg) >= 0) {
- if ($otherPackage && $p->compare($pkg->version) <= 0) {
- $toRemove{$otherPackage} = 0;
- exists $packages->{$pkg->id} or $packages->{$pkg->id} = 1;
- $urpm->{log}(_("removing %s to upgrade to %s ...
- since it will not be updated otherwise", $otherPackage, $pkg->name.'-'.$pkg->version.'-'.$pkg->release));
- } else {
- $installed{$pkg->id} = undef;
- }
- } elsif ($upgradeNeedRemove{$pkg->name}) {
- my $otherPackage = $p->name.'-'.$p->version.'-'.$p->release;
- $toRemove{$otherPackage} = 0;
- exists $packages->{$pkg->id} or $packages->{$pkg->id} = 1;
- $urpm->{log}(_("removing %s to upgrade to %s ...
- since it will not upgrade correctly!", $otherPackage, $pkg->name.'-'.$pkg->version.'-'.$pkg->release));
- }
- } else {
- if (exists $obsoletedPackages{$p->name}) {
- @installedFilesForUpgrade{$p->upgrade_files} = ();
- }
- }
- });
-
- #- find new packages to upgrade.
- foreach my $pkg (@{$urpm->{depslist}}) {
- defined $pkg->id && $pkg->arch ne 'src' or next;
-
- my $skipThis = 0;
- my $count = $db->traverse_tag("name", [ $pkg->name ], sub {
- $skipThis ||= exists $installed{$pkg->id};
- });
-
- #- skip if not installed (package not found in current install).
- $skipThis ||= ($count == 0);
-
- #- select the package if it is already installed with a lower version or simply not installed.
- unless ($skipThis) {
- my $cumulSize;
-
- exists $packages->{$pkg->id} or $packages->{$pkg->id} = 1;
-
- #- keep in mind installed files which are not being updated. doing this costs in
- #- execution time but use less memory, else hash all installed files and unhash
- #- all file for package marked for upgrade.
- $db->traverse_tag("name", [ $pkg->name ], sub {
- my ($p) = @_;
- @installedFilesForUpgrade{$p->upgrade_files} = ();
- });
-
- foreach ($pkg->files) {
- delete $installedFilesForUpgrade{$_};
- }
- }
- }
-
- #- unmark all files for all packages marked for upgrade. it may not have been done above
- #- since some packages may have been selected by depsList.
- foreach my $pkg (@{$urpm->{depslist}}) {
- defined $pkg->id && $pkg->arch ne 'src' or next;
- if (exists $packages->{$pkg->id}) {
- foreach ($pkg->files) {
- delete $installedFilesForUpgrade{$_};
- }
- }
- }
-
- #- select packages which contains marked files, then unmark on selection.
- #- a special case can be made here, the selection is done only for packages
- #- requiring locales if the locales are selected.
- #- another special case are for devel packages where fixes over the time has
- #- made some files moving between the normal package and its devel couterpart.
- #- if only one file is affected, no devel package is selected.
- foreach my $pkg (@{$urpm->{depslist}}) {
- defined $pkg->id && $pkg->arch ne 'src' or next;
- unless (exists $packages->{$pkg->id}) {
- my $toSelect = 0;
- foreach ($pkg->upgrade_files) {
- delete $installedFilesForUpgrade{$_} and ++$toSelect;
- }
- if ($toSelect) {
- if ($toSelect <= 1 && $pkg->name =~ /-devel/) {
- $urpm->{log}(_("avoid selecting %s as not enough files will be updated", $pkg->fullname));
- } else {
- #- default case is assumed to allow upgrade.
- my @deps = grep { $_ } map { $urpm->{names}{$_} } grep { /locales-/ } $pkg->requires_nosense;
- if (@deps == 0 || @deps > 0 && (grep { ! exists $packages->{$pkg->id} &&
- ! exists $installed{$_->{id}} } @deps) == 0) {
- $urpm->{log}(_("selecting %s by selection on files", $pkg->name));
- $packages->{$pkg->id} = 1;
- } else {
- $urpm->{log}(_("avoid selecting %s as its locales language is not already selected", $pkg->fullname));
- }
- }
- }
- }
- }
-
- #- clean memory...
- %installedFilesForUpgrade = ();
-
- #- clean false value on toRemove.
- delete $toRemove{''};
-
- #- get filenames that should be saved for packages to remove.
- #- typically config files, but it may broke for packages that
- #- are very old when compabilty has been broken.
- #- but new version may saved to .rpmnew so it not so hard !
- if ($keep_files && keys %toRemove) {
- $db->traverse(sub {
- my ($p) = @_;
- my $otherPackage = $p->name.'-'.$p->version.'-'.$p->release;
- if (exists $toRemove{$otherPackage}) {
- @{$keep_files}{$p->conf_files} = ();
- }
- });
- }
-}
-
1;