diff options
Diffstat (limited to 'URPM')
| -rw-r--r-- | URPM/Resolve.pm | 199 |
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; |