0.04-1mdk

4 files changed, 259 insertions, 24 deletions

diff --git a/URPM.pm b/URPM.pm
index 2d6bb85..4ba32ad 100644
--- a/URPM.pm
+++ b/URPM.pm
@@ -6,7 +6,7 @@ use vars qw($VERSION @ISA);
 require DynaLoader;
 
 @ISA = qw(DynaLoader);
-$VERSION = '0.03';
+$VERSION = '0.04';
 
 bootstrap URPM $VERSION;
 
@@ -66,7 +66,7 @@ sub traverse_tag {
 	    }
 	} elsif ($tag eq 'triggeredby' || $tag eq 'path') {
 	    foreach (@{$urpm->{depslist} || []}) {
-		if (grep { exists $names{$_} } $_->files) {
+		if (grep { exists $names{$_} } $_->files, grep { /^\// } $_->provides_nosense) {
 		    $callback and $callback->($_);
 		    ++$count;
 		}
@@ -128,23 +128,3 @@ sub relocate_depslist {
     $relocated_entries;
 }
 
-#- resolve requires using requested tag, 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_requires {
-    my ($urpm, $db, $state, %options);
-    my (@packages);
-
-    #- get package that need to be evaluated.
-    foreach (0 .. $#{$urpm->{depslist}}) {
-	my $pkg = $urpm->{depslist}[$_];
-	$pkg->flag_requested && !($pkg->flag_installed || $pkg->flag_upgrade) and push @packages, $_;
-    }
-    #TODO
-}
-
diff --git a/URPM.xs b/URPM.xs
index fcaee43..3d238ab 100644
--- a/URPM.xs
+++ b/URPM.xs
@@ -1446,6 +1446,59 @@ Db_traverse_tag(db,tag,names,callback)
 
 MODULE = URPM            PACKAGE = URPM                PREFIX = Urpm_
 
+int
+Urpm_ranges_overlap(a, b)
+  char *a
+  char *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) {
+      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;
+      }
+    }
+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;
+      }
+    }
+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
+
 void
 Urpm_parse_synthesis(urpm, filename)
   SV *urpm
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;
diff --git a/perl-URPM.spec b/perl-URPM.spec
index 34ea04a..5d1c05c 100644
--- a/perl-URPM.spec
+++ b/perl-URPM.spec
@@ -1,7 +1,7 @@
 %define name perl-URPM
 %define real_name URPM
-%define version 0.03
-%define release 2mdk
+%define version 0.04
+%define release 1mdk
 
 %{expand:%%define rpm_version %(rpm -q --queryformat '%{VERSION}-%{RELEASE}' rpm)}
 
@@ -48,6 +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  6 2002 François Pons <fpons@mandrakesoft.com> 0.03-2mdk
 - fixed incomplete compare_pkg not taking into account score
   of arch.