aboutsummaryrefslogtreecommitdiffstats
path: root/URPM/Resolve.pm
diff options
context:
space:
mode:
authorFrancois Pons <fpons@mandriva.com>2002-06-11 17:59:04 +0000
committerFrancois Pons <fpons@mandriva.com>2002-06-11 17:59:04 +0000
commit74c3cfe40e76d2cf047e7cbc57653298a460b658 (patch)
tree0455e964846482182d896763b9819646a6239a87 /URPM/Resolve.pm
parenta3d672d23de228cb2955f5825869154b77a7f5e0 (diff)
downloadperl-URPM-74c3cfe40e76d2cf047e7cbc57653298a460b658.tar
perl-URPM-74c3cfe40e76d2cf047e7cbc57653298a460b658.tar.gz
perl-URPM-74c3cfe40e76d2cf047e7cbc57653298a460b658.tar.bz2
perl-URPM-74c3cfe40e76d2cf047e7cbc57653298a460b658.tar.xz
perl-URPM-74c3cfe40e76d2cf047e7cbc57653298a460b658.zip
0.04-1mdk
Diffstat (limited to 'URPM/Resolve.pm')
-rw-r--r--URPM/Resolve.pm199
1 files changed, 199 insertions, 0 deletions
diff --git a/URPM/Resolve.pm b/URPM/Resolve.pm
new file mode 100644
index 0000000..e13cc23
--- /dev/null
+++ b/URPM/Resolve.pm
@@ -0,0 +1,199 @@
+package URPM;
+
+use strict;
+
+#- 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.
+#- other required package will have required flag set along with upgrade flag or
+#- installed flag.
+#- base flag should always been installed or upgraded.
+#- the following options are recognized :
+#- check : check requires of installed packages.
+sub resolve_requested {
+ my ($urpm, $db, $state, %options) = @_;
+ my (@properties, %requested, $dep);
+
+ #- for each dep property evaluated, examine which package will be obsoleted on $db,
+ #- then examine provides that will be removed (which need to be satisfied by another
+ #- package present or by a new package to upgrade), then requires not satisfied and
+ #- finally conflicts that will force a new upgrade or a remove.
+ @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 (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;
+ }
+ }
+ }
+ #- take the best package for each choices of same name.
+ 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 = $_;
+ }
+ }
+ }
+ $_ = $best;
+ }
+ 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;
+ } else {
+ push @chosen, $pkg;
+ }
+ }
+ @chosen_requested > 0 and @chosen = @chosen_requested;
+ @chosen_requested == 0 and @chosen_upgrade > 0 and @chosen = @chosen_upgrade;
+ } else {
+ @chosen = values %packages;
+ }
+ if (@chosen > 1) {
+ #- solve choices by asking user.
+ print STDERR "asking user for ".scalar(@chosen)." choices\n";
+ #TODO
+ }
+ $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});
+
+ #- 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;
+ unless ($pkg->flag_upgrade) {
+ $db->traverse_tag('name', [ $pkg->name ], sub {
+ my ($p) = @_;
+ $pkg->flag_installed or
+ $pkg->set_flag_installed($pkg->compare_pkg($p) <= 0);
+ });
+ $pkg->set_flag_upgrade(!$pkg->flag_installed);
+ }
+ $pkg->flag_installed and 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;
+ }
+
+ 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;
+
+ $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};
+ }
+ }
+ #- check differential provides between obsoleted package and newer one.
+ $state->{provided}{$_} or $diff_provides{$n} = undef;
+ }
+ });
+ }
+ }
+
+ 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;
+ } else {
+ $pn eq $n && $pn ne $pkg->name 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) {
+ push @properties, $p->name;
+ }
+ });
+ }
+ }
+
+ #- 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;
+ }
+ });
+ }
+ }
+ #- if nothing can be done, the require should be resolved.
+ $satisfied or push @properties, $_;
+ }
+
+ #- examine conflicts.
+ #TODO
+ }
+}
+
+1;