0.04-1mdk

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