diff options
Diffstat (limited to 'urpm.pm')
| -rw-r--r-- | urpm.pm | 456 |
1 files changed, 4 insertions, 452 deletions
@@ -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; |