aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorFrancois Pons <fpons@mandriva.com>2002-06-13 10:24:18 +0000
committerFrancois Pons <fpons@mandriva.com>2002-06-13 10:24:18 +0000
commite198d9c84f1f2c7e92aafc525fe7413773cfb817 (patch)
tree30bbface6bb27c8d313d7f867052d836828f3bbc
parent8fc236e1a35221fbf8c6e43e1744cc1f232bf3ff (diff)
downloadperl-URPM-e198d9c84f1f2c7e92aafc525fe7413773cfb817.tar
perl-URPM-e198d9c84f1f2c7e92aafc525fe7413773cfb817.tar.gz
perl-URPM-e198d9c84f1f2c7e92aafc525fe7413773cfb817.tar.bz2
perl-URPM-e198d9c84f1f2c7e92aafc525fe7413773cfb817.tar.xz
perl-URPM-e198d9c84f1f2c7e92aafc525fe7413773cfb817.zip
0.04-1mdk
-rw-r--r--URPM.xs71
-rw-r--r--URPM/Resolve.pm354
-rw-r--r--perl-URPM.spec5
3 files changed, 291 insertions, 139 deletions
diff --git a/URPM.xs b/URPM.xs
index 3d238ab..a8bdbe2 100644
--- a/URPM.xs
+++ b/URPM.xs
@@ -1453,49 +1453,44 @@ Urpm_ranges_overlap(a, b)
PREINIT:
char *sa = a, *sb = b;
int aflags = 0, bflags = 0;
- char *eona, *eonb;
- char *eosa, *eosb;
- char save_a, save_b;
CODE:
- while (*sa && *sa != ' ' && *sa != '[') ++sa; save_a = *sa; *(eona = sa++) = 0;
- while (*sb && *sb != ' ' && *sb != '[') ++sb; save_b = *sb; *(eonb = sb++) = 0;
- if (save_a)
+ while (*sa && *sa != ' ' && *sa != '[' && *sa != '<' && *sa != '>' && *sa != '=' && *sa == *sb) {
+ ++sa;
+ ++sb;
+ }
+ if (*sa && *sa != ' ' && *sa != '[' && *sa != '<' && *sa != '>' && *sa != '=') {
+ /* the strings are sure to be different */
+ RETVAL = 0;
+ } else {
while (*sa) {
- switch (*sa++) {
- case '<': aflags |= RPMSENSE_LESS; break;
- case '>': aflags |= RPMSENSE_GREATER; break;
- case '=': aflags |= RPMSENSE_EQUAL; break;
- case ' ':
- case '[':
- case '*':
- case ']':
- break;
- default: goto exit_a;
- }
+ if (*sa == ' ' || *sa == '[' || *sa == '*' || *sa == ']');
+ else if (*sa == '<') aflags |= RPMSENSE_LESS;
+ else if (*sa == '>') aflags |= RPMSENSE_GREATER;
+ else if (*sa == '=') aflags |= RPMSENSE_EQUAL;
+ else break;
+ ++sa;
}
-exit_a:
- if (save_b)
while (*sb) {
- switch (*sb++) {
- case '<': bflags |= RPMSENSE_LESS; break;
- case '>': bflags |= RPMSENSE_GREATER; break;
- case '=': bflags |= RPMSENSE_EQUAL; break;
- case ' ':
- case '[':
- case '*':
- case ']':
- break;
- default: goto exit_b;
- }
+ if (*sb == ' ' || *sb == '[' || *sb == '*' || *sb == ']');
+ else if (*sb == '<') bflags |= RPMSENSE_LESS;
+ else if (*sb == '>') bflags |= RPMSENSE_GREATER;
+ else if (*sb == '=') bflags |= RPMSENSE_EQUAL;
+ else break;
+ ++sb;
+ }
+ if (!aflags || !bflags)
+ RETVAL = 1; /* really faster to test it there instead of later */
+ else {
+ char *eosa = strchr(sa, ']');
+ char *eosb = strchr(sb, ']');
+
+ if (eosa) *eosa = 0;
+ if (eosb) *eosb = 0;
+ RETVAL = rpmRangesOverlap("", sa, aflags, "", sb, bflags);
+ if (eosb) *eosb = ']';
+ if (eosa) *eosa = ']';
}
-exit_b:
- if ((eosa = strchr(--sa, ']')) != NULL) *eosa = 0;
- if ((eosb = strchr(--sb, ']')) != NULL) *eosb = 0;
- RETVAL = rpmRangesOverlap(a, sa, aflags, b, sb, bflags);
- if (eosb) *eosb = ']';
- if (eosa) *eosa = ']';
- *eonb = save_b;
- *eona = save_a;
+ }
OUTPUT:
RETVAL
diff --git a/URPM/Resolve.pm b/URPM/Resolve.pm
index e13cc23..7b63be2 100644
--- a/URPM/Resolve.pm
+++ b/URPM/Resolve.pm
@@ -2,6 +2,82 @@ package URPM;
use strict;
+#- find candidates packages from a require string (or id),
+#- take care of direct choices using | sepatator.
+sub find_candidate_packages {
+ my ($urpm, $dep) = @_;
+ my %packages;
+
+ foreach (split '\|', $dep) {
+ if (/^\d+$/) {
+ my $pkg = $urpm->{depslist}[$_];
+ $pkg->arch eq 'src' || $pkg->is_arch_compat or next;
+ push @{$packages{$pkg->name}}, $pkg;
+ } elsif (my ($property, $name) = /^(([^\s\[]*).*)/) {
+ foreach (keys %{$urpm->{provides}{$name} || {}}) {
+ my $pkg = $urpm->{depslist}[$_];
+ $pkg->is_arch_compat or next;
+ #- check if at least one provide of the package overlap the property.
+ my $satisfied = 0;
+ foreach ($pkg->provides) {
+ ranges_overlap($property, $_) and ++$satisfied, last;
+ }
+ $satisfied and push @{$packages{$pkg->name}}, $pkg;
+ }
+ }
+ }
+ \%packages;
+}
+
+#- return unresolved requires of a package (a new one or a existing one).
+sub unsatisfied_requires {
+ my ($urpm, $db, $state, $pkg, $name) = @_;
+ my %properties;
+
+ #- all requires should be satisfied according to selected package, or installed packages.
+ foreach ($pkg->requires) {
+ if (my ($n, $s) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/) {
+ #- allow filtering on a given name (to speed up some search).
+ ! defined $name || $n eq $s or next;
+
+ #- avoid recomputing the same all the time.
+ exists $properties{$_} || $state->{installed}{$_} and next;
+
+ #- keep track if satisfied.
+ my $satisfied = 0;
+ #- check on selected package if a provide is satisfying the resolution (need to do the ops).
+ foreach my $sense (keys %{$state->{provided}{$n} || {}}) {
+ ranges_overlap($sense, $s) and ++$satisfied, last;
+ }
+ #- check on installed system a package which is not obsoleted is satisfying the require.
+ unless ($satisfied) {
+ if ($n =~ /^\//) {
+ $db->traverse_tag('path', [ $n ], sub {
+ my ($p) = @_;
+ exists $state->{obsoleted}{$p->fullname} and return;
+ ++$satisfied;
+ });
+ } else {
+ $db->traverse_tag('whatprovides', [ $n ], sub {
+ my ($p) = @_;
+ exists $state->{obsoleted}{$p->fullname} and return;
+ foreach ($p->provides) {
+ $state->{installed}{$_}{$p->fullname} = undef;
+ if (my ($pn, $ps) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/) {
+ $pn eq $n or next;
+ ranges_overlap($ps, $s) and ++$satisfied;
+ }
+ }
+ });
+ }
+ }
+ #- if nothing can be done, the require should be resolved.
+ $satisfied or $properties{$_} = undef;
+ }
+ }
+ keys %properties;
+}
+
#- resolve requested, keep resolution state to speed process.
#- a requested package is marked to be installed, once done, a upgrade flag or
#- installed flag is set according to needs of package.
@@ -19,76 +95,61 @@ sub resolve_requested {
#- package present or by a new package to upgrade), then requires not satisfied and
#- finally conflicts that will force a new upgrade or a remove.
@properties = keys %{$state->{requested}};
- @requested{map { split '\|', $_ } @properties} = ();
- while (defined ($dep = shift @properties)) {
- my ($allow_src, %packages, @chosen_requested, @chosen_upgrade, @chosen, %diff_provides, $pkg);
+ foreach my $dep (@properties) {
foreach (split '\|', $dep) {
- if (/^\d+$/) {
- my $pkg = $urpm->{depslist}[$_];
- $allow_src = 1;
- push @{$packages{$pkg->name}}, $pkg;
- } elsif (my ($property, $name) = /^(([^\s\[]*).*)/) {
- foreach (keys %{$urpm->{provides}{$name} || {}}) {
- my $pkg = $urpm->{depslist}[$_];
- my $satisfied = 0;
- #- check if at least one provide of the package overlap the property.
- foreach ($pkg->provides) {
- ranges_overlap($property, $_) and ++$satisfied, last;
- }
- $satisfied and push @{$packages{$pkg->name}}, $pkg;
- }
- }
+ $requested{$_} = $state->{requested}{$dep};
}
+ }
+ while (defined ($dep = shift @properties)) {
+ my (@chosen_requested, @chosen_upgrade, @chosen, %diff_provides, $pkg);
#- take the best package for each choices of same name.
- foreach (values %packages) {
+ my $packages = $urpm->find_candidate_packages($dep);
+ foreach (values %$packages) {
my $best;
foreach (@$_) {
- if (defined $allow_src && $_->arch eq 'src' || $_->is_arch_compat) {
- if ($best && $best != $_) {
- $_->compare_pkg($best) > 0 and $best = $_;
- } else {
- $best = $_;
- }
+ if ($best && $best != $_) {
+ $_->compare_pkg($best) > 0 and $best = $_;
+ } else {
+ $best = $_;
}
}
$_ = $best;
}
- if (keys %packages > 1) {
+ if (keys(%$packages) > 1) {
#- package should be prefered if one of their provides is referenced
#- in requested hash or package itself is requested (or required).
#- if there is no preference choose the first one (higher probability
#- of being chosen) by default and ask user.
- foreach my $pkg (values %packages) {
- $pkg or next; #- this could happen if no package are suitable for this arch.
- if (exists $requested{$pkg->id}) {
- push @chosen_requested, $pkg;
- } elsif ($db->traverse_tag('name', [ $pkg->name ], undef) > 0) {
- push @chosen_upgrade, $pkg;
+ foreach my $p (values %$packages) {
+ $p or next; #- this could happen if no package are suitable for this arch.
+ exists $state->{selected}{$p->id} and $pkg = $p, last; #- already selected package is taken.
+ if (exists $requested{$p->id}) {
+ push @chosen_requested, $p;
+ } elsif ($db->traverse_tag('name', [ $p->name ], undef) > 0) {
+ push @chosen_upgrade, $p;
} else {
- push @chosen, $pkg;
+ push @chosen, $p;
}
}
@chosen_requested > 0 and @chosen = @chosen_requested;
@chosen_requested == 0 and @chosen_upgrade > 0 and @chosen = @chosen_upgrade;
} else {
- @chosen = values %packages;
+ @chosen = values %$packages;
}
- if (@chosen > 1) {
- #- solve choices by asking user.
- print STDERR "asking user for ".scalar(@chosen)." choices\n";
- #TODO
+ if (!$pkg && $options{callback_choices} && @chosen > 1) {
+ $pkg ||= $options{callback_choices}->($urpm, $db, $state, \@chosen);
}
$pkg ||= $chosen[0];
$pkg && !$pkg->flag_requested && !$pkg->flag_required or next;
#- keep in mind the package has be selected.
- $pkg->set_flag_requested(exists $requested{$dep});
- $pkg->set_flag_required(! exists $requested{$dep});
+ $pkg->set_flag_requested($state->{selected}{$pkg->id} = delete $requested{$dep});
+ $pkg->set_flag_required(!$pkg->flag_requested);
#- check if package is not already installed before trying to use it, compute
#- obsoleted package too. this is valable only for non source package.
if ($pkg->arch ne 'src') {
- $pkg->flag_installed and next;
+ $pkg->flag_installed and delete $state->{selected}{$pkg->id}, next;
unless ($pkg->flag_upgrade) {
$db->traverse_tag('name', [ $pkg->name ], sub {
my ($p) = @_;
@@ -97,35 +158,34 @@ sub resolve_requested {
});
$pkg->set_flag_upgrade(!$pkg->flag_installed);
}
- $pkg->flag_installed and next;
+ $pkg->flag_installed and delete $state->{selected}{$pkg->id}, next;
#- keep in mind the provides of this package, so that future requires can be satisfied
#- with this package potentially.
foreach ($pkg->provides) {
- $state->{provided}{$_}{$pkg->id} = undef;
+ if (my ($n, $s) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/) {
+ $state->{provided}{$n}{$s}{$pkg->id} = undef;
+ }
}
foreach ($pkg->name, $pkg->obsoletes) {
if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*)\s*([^\s\]]*)/) {
$db->traverse_tag('name', [ $n ], sub {
my ($p) = @_;
- eval($p->compare($v) . $o . 0) or return;
+ !$o || eval($p->compare($v) . $o . 0) or return;
$state->{obsoleted}{$p->fullname}{$pkg->id} = undef;
foreach ($p->provides) {
- #- check if a installed property has been required which needs to be
- #- re-evaluated to solve this one.
- if (my $ip = $state->{installed}{$_}) {
- if (exists $ip->{$p->fullname} && keys(%$ip) == 1) {
- push @properties, $n;
- delete $state->{installed}{$_};
- } else {
- delete $ip->{$p->fullname};
- }
+ #- clean installed property.
+ if (my ($ip) = $state->{installed}{$_}) {
+ delete $ip->{$p->fullname};
+ %$ip or delete $state->{installed}{$_};
}
#- check differential provides between obsoleted package and newer one.
- $state->{provided}{$_} or $diff_provides{$n} = undef;
+ if (my ($pn, $ps) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/) {
+ ($state->{provided}{$pn} || {})->{$ps} or $diff_provides{$n} = undef;
+ }
}
});
}
@@ -134,66 +194,162 @@ sub resolve_requested {
foreach my $n (keys %diff_provides) {
$db->traverse_tag('whatrequires', [ $n ], sub {
my ($p) = @_;
- my ($needed, $satisfied) = (0, 0);
- foreach ($p->requires) {
- if (my ($pn, $o, $v) = /^([^\[]*)(?:\[\*\])?\[?([^\s\]]*)\s*([^\s\]]*)/) {
- if ($o) {
- $pn eq $n && $pn eq $pkg->name or next;
- ++$needed;
- eval($pkg->compare($v) . $o . 0) or next;
- #- an existing provides (propably the one examined) is satisfying.
- ++$satisfied;
+ if (my @l = $urpm->unsatisfied_requires($db, $state, $p)) {
+ #- try if upgrading the package will be satisfying all the requires
+ #- else it will be necessary to ask hte user for removing it.
+ my $packages = $urpm->find_candidate_packages($p->name);
+ my $best;
+ foreach (grep { $urpm->unsatisfied_requires($db, $state, $_, $n) == 0 }
+ @{$packages->{$p->name}}) {
+ if ($best && $best != $_) {
+ $_->compare_pkg($best) > 0 and $best = $_;
} else {
- $pn eq $n && $pn ne $pkg->name or next;
- #- a property has been removed since in diff_provides.
- ++$needed;
+ $best = $_;
}
}
- }
- #- check if the package need to be updated because it
- #- losts some of its requires regarding the current diff_provides.
- if ($needed > $satisfied) {
- push @properties, $p->name;
+ if ($best) {
+ push @properties, $best->id;
+ } else {
+ #- no package have been found, we need to remove the package examined.
+ push @{$state->{ask_remove}{$p->fullname}}, { unsatisfied => \@l, pkg => $pkg };
+ }
}
});
}
}
#- all requires should be satisfied according to selected package, or installed packages.
- foreach ($pkg->requires) {
- $state->{provided}{$_} || $state->{installed}{$_} and next;
- #- keep track if satisfied.
- my $satisfied = 0;
- #- check on selected package if a provide is satisfying the resolution (need to do the ops).
- foreach my $provide (keys %{$state->{provided}}) {
- ranges_overlap($provide, $_) and ++$satisfied, last;
- }
- #- check on installed system a package which is not obsoleted is satisfying the require.
- unless ($satisfied) {
- if (my ($file) = /^(\/[^\s\[]*)/) {
- $db->traverse_tag('path', [ $file ], sub {
- my ($p) = @_;
- exists $state->{obsoleted}{$p->fullname} and return;
- ++$satisfied;
- });
- } elsif (my ($property, $name) = /^(([^\s\[]*).*)/) {
- $db->traverse_tag('whatprovides', [ $name ], sub {
- my ($p) = @_;
- exists $state->{obsoleted}{$p->fullname} and return;
- foreach ($p->provides) {
- $state->{installed}{$_}{$p->fullname} = undef;
- ranges_overlap($_, $property) and ++$satisfied, return;
+ push @properties, $urpm->unsatisfied_requires($db, $state, $pkg);
+
+ #- examine conflicts, an existing package conflicting with this selection should
+ #- be upgraded to a new version which will be safe, else it should be removed.
+ foreach ($pkg->conflicts) {
+ if (my ($file) = /^(\/[^\s\[]*)/) {
+ $db->traverse_tag('path', [ $file ], sub {
+ my ($p) = @_;
+ $state->{conflicts}{$p->fullname}{$pkg->id} = undef;
+ #- all these packages should be removed.
+ push @{$state->{ask_remove}{$p->fullname}}, { conflicts => $file, pkg => $pkg };
+ });
+ } elsif (my ($property, $name) = /^(([^\s\[]*).*)/) {
+ $db->traverse_tag('whatprovides', [ $name ], sub {
+ my ($p) = @_;
+ if (grep { ranges_overlap($_, $property) } $p->provides) {
+ #- the existing package will conflicts with selection, check if a newer
+ #- version will be ok, else ask to remove the old.
+ my $packages = $urpm->find_candidate_packages($p->name);
+ my $best;
+ foreach (@{$packages->{$p->name}}) {
+ unless (grep { ranges_overlap($_, $property) } $_->provides) {
+ if ($best && $best != $_) {
+ $_->compare_pkg($best) > 0 and $best = $_;
+ } else {
+ $best = $_;
+ }
+ }
}
- });
+ if ($best) {
+ push @properties, $best->id;
+ } else {
+ #- no package have been found, we need to remove the package examined.
+ push @{$state->{ask_remove}{$p->fullname}}, { conflicts => $property, pkg => $pkg };
+ }
+ }
+ });
+ }
+ #- we need to check a selected package is not selected.
+ #- if true, it should be unselected.
+ if (my ($name) =~ /^([^\s\[]*)/) {
+ foreach (keys %{$urpm->{provides}{$name} || {}}) {
+ my $p = $urpm->{depslist}[$_];
+ ($pkg->flag_requested || $pkg->flag_required) && $pkg->flag_upgrade and
+ $state->{ask_unselect}{$p->id}{$pkg->id};
}
}
- #- if nothing can be done, the require should be resolved.
- $satisfied or push @properties, $_;
}
+ }
+
+ #- obsoleted packages are no longer marked as being asked to be removed.
+ delete @{$state->{ask_remove}}{keys %{$state->{obsoleted}}};
+}
- #- examine conflicts.
- #TODO
+#- select packages to upgrade, according to package already registered.
+#- by default, only takes best package and its obsoleted and compute
+#- all installed or upgrade flag.
+sub resolve_packages_to_upgrade {
+ my ($urpm, $db, $state, %options) = @_;
+ my (%names, %skip, %obsoletes);
+
+ #- build direct access to best package according to name.
+ foreach (@{$urpm->{depslist}}) {
+ if ($_->is_arch_compat) {
+ my $p = $names{$_->name};
+ if ($p) {
+ if ($_->compare_pkg($p) > 0) {
+ $names{$_->name} = $_;
+ }
+ } else {
+ $names{$_->name} = $_;
+ }
+ }
}
+
+ #- check consistency with obsoletes of eligible package.
+ #- it is important not to select a package wich obsolete
+ #- an old one.
+ foreach my $pkg (values %names) {
+ foreach ($pkg->obsoletes) {
+ if (my ($n, $o, $v) = /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*)\s*([^\s\]]*)/) {
+ if ($names{$n} && (!$o || eval($names{$n}->compare($v) . $o . 0))) {
+ #- an existing best package is obsoleted by another one.
+ $skip{$n} = undef;
+ }
+ push @{$obsoletes{$n}}, $pkg;
+ }
+ }
+ }
+
+ #- now we can examine all existing packages to find packages to upgrade.
+ $db->traverse(sub {
+ my ($p) = @_;
+ #- first try with package using the same name.
+ #- this will avoid selecting all packages obsoleting an old one.
+ if (my $pkg = $names{$p->name}) {
+ if ($pkg->compare_pkg($p) <= 0) {
+ #- this means the package is already installed (or there
+ #- is a old version in depslist).
+ $pkg->set_flag_installed(1);
+ $pkg->set_flag_upgrade(0);
+ } else {
+ #- the depslist version is better than existing one.
+ $pkg->set_flag_installed(0);
+ $pkg->set_flag_upgrade(1);
+ $state->{requested}{$pkg->id} = $options{requested};
+ return;
+ }
+ }
+
+ #- check provides of existing package to see if a obsolete
+ #- may allow selecting it.
+ foreach ($p->provides) {
+ if (my ($n) = /^([^\s\[]*)/) {
+ foreach my $pkg (@{$obsoletes{$n} || []}) {
+ next if $pkg->name eq $p->name;
+ foreach my $property ($pkg->obsoletes) {
+ if (ranges_overlap($property, $_)) {
+ #- the package being examined can be obsoleted.
+ #- do not set installed and provides flags.
+ $state->{requested}{$pkg->id} = $options{requested};
+ return;
+ }
+ }
+ }
+ }
+ }
+ });
+
+ #TODO is conflicts for selection of package, it is important to choose
+ #TODO right package to install.
}
1;
diff --git a/perl-URPM.spec b/perl-URPM.spec
index 5d1c05c..6434247 100644
--- a/perl-URPM.spec
+++ b/perl-URPM.spec
@@ -48,8 +48,9 @@ rm -rf $RPM_BUILD_ROOT
%changelog
-* Tue Jun 11 2002 François Pons <fpons@mandrakesoft.com> 0.04-1mdk
-- added Resolve.pm file.
+* Thu Jun 13 2002 François Pons <fpons@mandrakesoft.com> 0.04-1mdk
+- added Resolve.pm file (resolve requires)
+- added ranges_overlap method (uses rpmRangesOverlap in rpmlib).
* Thu Jun 6 2002 François Pons <fpons@mandrakesoft.com> 0.03-2mdk
- fixed incomplete compare_pkg not taking into account score