diff options
Diffstat (limited to 'URPM')
| -rw-r--r-- | URPM/.perl_checker | 1 | ||||
| -rw-r--r-- | URPM/Build.pm | 528 | ||||
| -rw-r--r-- | URPM/Query.pm | 40 | ||||
| -rw-r--r-- | URPM/Resolve.pm | 2003 | ||||
| -rw-r--r-- | URPM/Signature.pm | 91 |
5 files changed, 2663 insertions, 0 deletions
diff --git a/URPM/.perl_checker b/URPM/.perl_checker new file mode 100644 index 0000000..202e053 --- /dev/null +++ b/URPM/.perl_checker @@ -0,0 +1 @@ +Basedir .. diff --git a/URPM/Build.pm b/URPM/Build.pm new file mode 100644 index 0000000..f298707 --- /dev/null +++ b/URPM/Build.pm @@ -0,0 +1,528 @@ +package URPM; + +# $Id: Build.pm 270395 2010-07-30 00:55:59Z nanardon $ + +use strict; +use warnings; + +sub _get_tmp_dir () { + my $t = $ENV{TMPDIR}; + $t && -w $t or $t = '/tmp'; + "$t/.build_hdlist"; +} + +# DEPRECATED. ONLY USED BY MKCD +# +#- prepare build of an hdlist from a list of files. +#- it can be used to start computing depslist. +#- parameters are : +#- rpms : array of all rpm file name to parse (mandatory) +#- dir : directory which will contain headers (defaults to /tmp/.build_hdlist) +#- callback : perl code to be called for each package read (defaults pack_header) +#- clean : bool to clean cache before (default no). +#- packing : bool to create info (default is weird) +# +# deprecated +sub parse_rpms_build_headers { + my ($urpm, %options) = @_; + my ($dir, %cache, @headers); + + #- check for mandatory options. + if (@{$options{rpms} || []} > 0) { + #- build a working directory which will hold rpm headers. + $dir = $options{dir} || _get_tmp_dir(); + $options{clean} and system($ENV{LD_LOADER} ? $ENV{LD_LOADER} : @{[]}, "rm", "-rf", $dir); + -d $dir or mkdir $dir, 0755 or die "cannot create directory $dir\n"; + + #- examine cache if it contains any headers which will be much faster to read + #- than parsing rpm file directly. + unless ($options{clean}) { + my $dirh; + opendir $dirh, $dir; + while (defined (my $file = readdir $dirh)) { + my ($fullname, $filename) = $file =~ /(.+?-[^:\-]+-[^:\-]+\.[^:\-\.]+)(?::(\S+))?$/ or next; + my @stat = stat "$dir/$file"; + $cache{$filename || $fullname} = { + file => $file, + size => $stat[7], + 'time' => $stat[9], + }; + } + closedir $dirh; + } + + foreach (@{$options{rpms}}) { + my ($key) = m!([^/]*)\.rpm$! or next; #- get rpm filename. + my ($id, $filename); + + if ($cache{$key} && $cache{$key}{time} > 0 && $cache{$key}{time} >= (stat $_)[9]) { + ($id, undef) = $urpm->parse_hdlist("$dir/$cache{$key}{file}", packing => $options{packing}, keep_all_tags => $options{keep_all_tags}); + unless (defined $id) { + if ($options{dontdie}) { + print STDERR "bad header $dir/$cache{$key}{file}\n"; + next; + } else { + die "bad header $dir/$cache{$key}{file}\n"; + } + } + + $options{callback} and $options{callback}->($urpm, $id, %options, (file => $_)); + + $filename = $cache{$key}{file}; + } else { + ($id, undef) = $urpm->parse_rpm($_, keep_all_tags => $options{keep_all_tags}); + unless (defined $id) { + if ($options{dontdie}) { + print STDERR "bad rpm $_\n"; + next; + } else { + die "bad rpm $_\n"; + } + } + + my $pkg = $urpm->{depslist}[$id]; + + $filename = $pkg->fullname; + + unless (-s "$dir/$filename") { + open my $fh, ">$dir/$filename" or die "unable to open $dir/$filename for writing\n"; + $pkg->build_header(fileno $fh); + close $fh; + } + -s "$dir/$filename" or unlink("$dir/$filename"), die "can create header $dir/$filename\n"; + + #- make smart use of memory (no need to keep header in memory now). + if ($options{callback}) { + $options{callback}->($urpm, $id, %options, (file => $_)); + } else { + $pkg->pack_header; + } + + # Olivier Thauvin <thauvin@aerov.jussieu.fr> + # isn't this code better, but maybe it will break some tools: + # $options{callback}->($urpm, $id, %options, (file => $_)) if ($options{callback}); + # $pkg->pack_header; + } + + #- keep track of header associated (to avoid rereading rpm filename directly + #- if rereading has been made neccessary). + push @headers, $filename; + } + } + @headers; +} + +# DEPRECATED. ONLY USED BY MKCD +# +#- allow rereading of hdlist and clean. +sub unresolved_provides_clean { + my ($urpm) = @_; + $urpm->{depslist} = []; + $urpm->{provides}{$_} = undef foreach keys %{$urpm->{provides} || {}}; +} + +# DEPRECATED. ONLY USED BY MKCD +# +#- read a list of headers (typically when building an hdlist when provides have +#- been cleaned). +#- parameters are : +#- headers : array containing all headers filenames to parse (mandatory) +#- dir : directory which contains headers (defaults to /tmp/.build_hdlist) +#- callback : perl code to be called for each package read (defaults to pack_header) +sub parse_headers { + my ($urpm, %options) = @_; + my ($dir, $start, $id); + + $dir = $options{dir} || _get_tmp_dir(); + -d $dir or die "no directory $dir\n"; + + $start = @{$urpm->{depslist} || []}; + foreach (@{$options{headers} || []}) { + #- make smart use of memory (no need to keep header in memory now). + ($id, undef) = $urpm->parse_hdlist("$dir/$_", packing => !$options{callback}); + defined $id or die "bad header $dir/$_\n"; + $options{callback} and $options{callback}->($urpm, $id, %options); + } + defined $id ? ($start, $id) : @{[]}; +} + +# DEPRECATED. ONLY USED BY MKCD +#- compute dependencies, result in stored in info values of urpm. +#- operations are incremental, it is possible to read just one hdlist, compute +#- dependencies and read another hdlist, and again. +#- parameters are : +#- callback : callback to relocate reference to package id. +sub compute_deps { + my ($urpm, %options) = @_; + my %propagated_weight = ( + basesystem => 10000, + msec => 20000, + filesystem => 50000, + ); + my ($locales_weight, $step_weight, $fixed_weight) = (-5000, 10000, $propagated_weight{basesystem}); + + #- avoid recomputing already present infos, take care not to modify + #- existing entries, as the array here is used instead of values of infos. + my $start = @{$urpm->{deps} ||= []}; + my $end = $#{$urpm->{depslist} || []}; + + #- check if something has to be done. + $start > $end and return; + + #- keep track of prereqs. + my %prereqs; + + #- take into account in which hdlist a package has been found. + #- this can be done by an incremental take into account generation + #- of depslist.ordered part corresponding to the hdlist. + #- compute closed requires, do not take into account choices. + foreach ($start .. $end) { + my $pkg = $urpm->{depslist}[$_]; + + my %required_packages; + my @required_packages; + my %requires; + + foreach ($pkg->requires) { + my ($n, $prereq) = /^([^\s\[]*)(\[\*\])?/; + $requires{$n} = $prereq && 1; + } + my @requires = keys %requires; + + while (my $req = shift @requires) { + $req =~ /^basesystem/ and next; #- never need to requires basesystem directly as always required! what a speed up! + my $treq = ( + $req =~ /^\d+$/ ? [ $req ] + : $urpm->{provides}{$req} ? [ keys %{$urpm->{provides}{$req}} ] + : [ ($req !~ /NOTFOUND_/ ? "NOTFOUND_" : "") . $req ] + ); + if (@$treq > 1) { + #- this is a choice, no closure need to be done here. + push @required_packages, $treq; + } else { + #- this could be nothing if the provides is a file not found. + #- and this has been fixed above. + foreach (@$treq) { + my $pkg_ = /^\d+$/ && $urpm->{depslist}[$_]; + exists $required_packages{$_} and $pkg_ = undef; + $required_packages{$_} ||= $requires{$req}; $pkg_ or next; + foreach ($pkg_->requires_nosense) { + exists $requires{$_} or push @requires, $_; + $requires{$_} ||= $requires{$req}; + } + } + } + } + #- examine choice to remove those which are not mandatory. + foreach (@required_packages) { + unless (grep { exists $required_packages{$_} } @$_) { + $required_packages{join '|', sort { $a <=> $b } @$_} = undef; + } + } + + #- store a short representation of requires. + $urpm->{requires}[$_] = join ' ', keys %required_packages; + foreach my $d (keys %required_packages) { + $required_packages{$d} or next; + $prereqs{$d}{$_} = undef; + } + } + + #- expand choices and closure again. + my %ordered; + foreach ($start .. $end) { + my @requires = $_; + my ($dep, %requires); + while (defined ($dep = shift @requires)) { + exists $requires{$dep} || /^[^\d\|]*$/ and next; + foreach ($dep, split ' ', (defined $urpm->{deps}[$dep] ? $urpm->{deps}[$dep] : $urpm->{requires}[$dep])) { + if (/\|/) { + push @requires, split /\|/, $_; + } else { + /^\d+$/ and $requires{$_} = undef; + } + } + } + + my $pkg = $urpm->{depslist}[$_]; + my $delta = 1 + $propagated_weight{$pkg->name}; + foreach (keys %requires) { + $ordered{$_} += $delta; + } + } + + #- some package should be sorted at the beginning. + foreach (qw(basesystem msec rpm locales filesystem setup glibc sash bash libtermcap2 termcap readline ldconfig)) { + foreach (keys %{$urpm->{provides}{$_} || {}}) { + /^\d+$/ and $ordered{$_} = $fixed_weight; + } + /locales/ and $locales_weight += $fixed_weight; + $fixed_weight += $step_weight; + } + foreach ($start .. $end) { + my $pkg = $urpm->{depslist}[$_]; + + $pkg->name =~ /locales-[a-zA-Z]/ and $ordered{$_} = $locales_weight; + } + + #- compute base flag, consists of packages which are required without + #- choices of basesystem and are ALWAYS installed. these packages can + #- safely be removed from requires of others packages. + foreach (qw(basesystem glibc kernel)) { + foreach (keys %{$urpm->{provides}{$_} || {}}) { + foreach ($_, split ' ', (defined $urpm->{deps}[$_] ? $urpm->{deps}[$_] : $urpm->{requires}[$_])) { + /^\d+$/ and $urpm->{depslist}[$_] and $urpm->{depslist}[$_]->set_flag_base(1); + } + } + } + + #- give an id to each packages, start from number of package already + #- registered in depslist. + my %remap_ids; @remap_ids{sort { + exists $prereqs{$b}{$a} && ! exists $prereqs{$a}{$b} ? 1 : + $ordered{$b} <=> $ordered{$a} or do { + my ($na, $nb) = map { $urpm->{depslist}[$_]->name } ($a, $b); + my ($sa, $sb) = map { /^lib(.*)/ ? $1 : '' } ($na, $nb); + $sa && $sb ? $sa cmp $sb : $sa ? -1 : $sb ? 1 : $na cmp $nb; + } } ($start .. $end)} = ($start .. $end); + + #- now it is possible to clean ordered and prereqs. + %ordered = %prereqs = (); + + #- recompute requires to use packages id, drop any base packages or + #- reference of a package to itself. + my @depslist; + foreach ($start .. $end) { + my $pkg = $urpm->{depslist}[$_]; + + #- set new id. + $pkg->set_id($remap_ids{$_}); + + my ($id, $base, %requires_id, %not_founds); + foreach (split ' ', $urpm->{requires}[$_]) { + if (/\|/) { + #- all choices are grouped together at the end of requires, + #- this allow computation of dropable choices. + my ($to_drop, @choices_base_id, @choices_id); + foreach (split /\|/, $_) { + my ($id, $base) = (exists($remap_ids{$_}) ? $remap_ids{$_} : $_, $urpm->{depslist}[$_]->flag_base); + $base and push @choices_base_id, $id; + $base &&= ! $pkg->flag_base; + $to_drop ||= $id == $pkg->id || exists $requires_id{$id} || $base; + push @choices_id, $id; + } + + #- package can safely be dropped as it will be selected in requires directly. + $to_drop and next; + + #- if a base package is in a list, keep it instead of the choice. + if (@choices_base_id) { + @choices_id = @choices_base_id; + $base = 1; + } + if (@choices_id == 1) { + $id = $choices_id[0]; + } else { + my $choices_key = join '|', sort { $a <=> $b } @choices_id; + $requires_id{$choices_key} = undef; + next; + } + } elsif (/^\d+$/) { + ($id, $base) = (exists($remap_ids{$_}) ? $remap_ids{$_} : $_, $urpm->{depslist}[$_]->flag_base); + } else { + $not_founds{$_} = undef; + next; + } + + #- select individual package from choices or defined package. + $base &&= ! $pkg->flag_base; + $base || $id == $pkg->id or $requires_id{$id} = undef; + } + #- be smart with memory usage. + delete $urpm->{requires}[$_]; + $urpm->{deps}[$remap_ids{$_}] = join ' ', ((sort { ($a =~ /^(\d+)/)[0] <=> ($b =~ /^(\d+)/)[0] } keys %requires_id), + keys %not_founds); + $depslist[$remap_ids{$_}-$start] = $pkg; + } + + #- remap all provides ids for new package position and update depslist. + delete $urpm->{requires}; + @{$urpm->{depslist}}[$start .. $end] = @depslist; + foreach my $h (values %{$urpm->{provides}}) { + my %provided; + foreach (keys %{$h || {}}) { + $provided{exists($remap_ids{$_}) ? $remap_ids{$_} : $_} = delete $h->{$_}; + } + $h = \%provided; + } + $options{callback} and $options{callback}->($urpm, \%remap_ids, %options); + + ($start, $end); +} + +# DEPRECATED. ONLY USED BY MKCD +# +#- build an hdlist from existing depslist, from start to end inclusive. +#- parameters are : +#- hdlist : hdlist file to use. +#- dir : directory which contains headers (defaults to /tmp/.build_hdlist) +#- start : index of first package (defaults to first index of depslist). +#- end : index of last package (defaults to last index of depslist). +#- idlist : id list of rpm to compute (defaults is start .. end) +#- ratio : compression ratio (default 4). +#- split : split ratio (default 400kb, see MDV::Packdrakeng). +sub build_hdlist { + my ($urpm, %options) = @_; + my ($dir, $ratio, @idlist); + + $dir = $options{dir} || _get_tmp_dir(); + -d $dir or die "no directory $dir\n"; + + @idlist = $urpm->build_listid($options{start}, $options{end}, $options{idlist}); + + #- compression ratio are not very high, sample for cooker + #- gives the following (main only and cache fed up): + #- ratio compression_time size + #- 9 21.5 sec 8.10Mb -> good for installation CD + #- 6 10.7 sec 8.15Mb + #- 5 9.5 sec 8.20Mb + #- 4 8.6 sec 8.30Mb -> good for urpmi + #- 3 7.6 sec 8.60Mb + $ratio = $options{ratio} || 4; + + require MDV::Packdrakeng; + my $pack = MDV::Packdrakeng->new( + archive => $options{hdlist}, + compress => "gzip", + uncompress => "gzip -d", + block_size => $options{split}, + comp_level => $ratio, + ) or die "Can't create archive"; + foreach my $pkg (@{$urpm->{depslist}}[@idlist]) { + my $filename = $pkg->fullname; + -s "$dir/$filename" or die "bad header $dir/$filename\n"; + $pack->add($dir, $filename); + } +} + +#- build synthesis file. +#- used by genhdlist2 and mkcd +#- +#- parameters are : +#- synthesis : synthesis file to create (mandatory if fd not given). +#- fd : file descriptor (mandatory if synthesis not given). +#- start : index of first package (defaults to first index of depslist). +#- end : index of last package (defaults to last index of depslist). +#- idlist : id list of rpm to compute (defaults is start .. end) +#- ratio : compression ratio (default 9). +#- filter : program to filter through (default is 'gzip -$ratio'). +#- returns true on success +sub build_synthesis { + my ($urpm, %options) = @_; + my ($ratio, $filter, @idlist); + + @idlist = $urpm->build_listid($options{start}, $options{end}, $options{idlist}); + + $ratio = $options{ratio} || 9; + $filter = $options{filter} ? $options{filter} : "gzip -$ratio"; + $options{synthesis} || defined $options{fd} or die "invalid parameters given"; + + #- first pass: traverse provides to find files provided. + my %provided_files; + foreach (keys %{$urpm->{provides}}) { + m!^/! or next; + foreach my $id (keys %{$urpm->{provides}{$_} || {}}) { + push @{$provided_files{$id} ||= []}, $_; + } + } + + + #- second pass: write each info including files provided. + $options{synthesis} and open my $fh, "| " . ($ENV{LD_LOADER} || '') . " $filter >'$options{synthesis}'"; + foreach (@idlist) { + my $pkg = $urpm->{depslist}[$_]; + my %files; + + if ($provided_files{$_}) { + @files{@{$provided_files{$_}}} = undef; + delete @files{$pkg->provides_nosense}; + } + + $pkg->build_info($options{synthesis} ? fileno $fh : $options{fd}, join('@', keys %files)); + } + close $fh; # returns true on success +} + +# DEPRECATED. ONLY USED BY MKCD +#- write depslist.ordered file according to info in params. +#- parameters are : +#- depslist : depslist.ordered file to create. +#- provides : provides file to create. +#- compss : compss file to create. +sub build_base_files { + my ($urpm, %options) = @_; + + if ($options{depslist}) { + open my $fh, ">", $options{depslist} or die "Can't write to $options{depslist}: $!\n"; + foreach (0 .. $#{$urpm->{depslist}}) { + my $pkg = $urpm->{depslist}[$_]; + + printf $fh ("%s-%s-%s.%s%s %s %s\n", $pkg->fullname, + ($pkg->epoch ? ':' . $pkg->epoch : ''), $pkg->size || 0, $urpm->{deps}[$_]); + } + close $fh; + } + + if ($options{provides}) { + open my $fh, ">", $options{provides} or die "Can't write to $options{provides}: $!\n"; + while (my ($k, $v) = each %{$urpm->{provides}}) { + printf $fh "%s\n", join '@', $k, map { scalar $urpm->{depslist}[$_]->fullname } keys %{$v || {}}; + } + close $fh; + } + + if ($options{compss}) { + my %p; + + open my $fh, ">", $options{compss} or die "Can't write to $options{compss}: $!\n"; + foreach (@{$urpm->{depslist}}) { + $_->group or next; + push @{$p{$_->group} ||= []}, $_->name; + } + foreach (sort keys %p) { + print $fh $_, "\n"; + foreach (@{$p{$_}}) { + print $fh "\t", $_, "\n"; + } + print $fh "\n"; + } + close $fh; + } + + 1; +} + +our $MAKEDELTARPM = '/usr/bin/makedeltarpm'; + +#- make_delta_rpm($old_rpm_file, $new_rpm_file) +# Creates a delta rpm in the current directory. + +# DEPRECATED. UNUSED +sub make_delta_rpm ($$) { + @_ == 2 or return 0; + -e $_[0] && -e $_[1] && -x $MAKEDELTARPM or return 0; + my @id; + my $urpm = new URPM; + foreach my $i (0, 1) { + ($id[$i]) = $urpm->parse_rpm($_[$i]); + defined $id[$i] or return 0; + } + my $oldpkg = $urpm->{depslist}[$id[0]]; + my $newpkg = $urpm->{depslist}[$id[1]]; + $oldpkg->arch eq $newpkg->arch or return 0; + #- construct filename of the deltarpm + my $patchrpm = $oldpkg->name . '-' . $oldpkg->version . '-' . $oldpkg->release . '_' . $newpkg->version . '-' . $newpkg->release . '.' . $oldpkg->arch . '.delta.rpm'; + !system($MAKEDELTARPM, @_, $patchrpm); +} + +1; diff --git a/URPM/Query.pm b/URPM/Query.pm new file mode 100644 index 0000000..14256a4 --- /dev/null +++ b/URPM/Query.pm @@ -0,0 +1,40 @@ +package URPM; + +use strict; +use warnings; + +# Olivier Thauvin <thauvin@aerov.jussieu.fr> +# This package extend URPM functions to permit +# URPM low level query on rpm header +# $Id: Query.pm 270395 2010-07-30 00:55:59Z nanardon $ + +# tag2id +# INPUT array of rpm tag name +# Return an array of ID tag + +sub tag2id { + my @l = @_; + my %taglist = URPM::list_rpm_tag(); + map { $taglist{uc($_)} || undef } @l; +} + +sub query_pkg { + my (undef, $pkg, $query) = @_; + my @tags = map { + [ $pkg->get_tag(tag2id($_)) ] + } $query =~ m/\%\{([^{}]*)\}*/g; + + $query =~ s/\%\{[^{}]*\}/%s/g; + $query =~ s/\\n/\n/g; + $query =~ s/\\t/\t/g; + my ($max, @res) = 0; + + foreach (@tags) { $max < $#{$_} and $max = $#{$_} }; + + foreach my $i (0 .. $max) { + push(@res, sprintf($query, map { ${$_}[ $#{$_} < $i ? $#{$_} : $i ] } @tags)); + } + @res +} + +1; diff --git a/URPM/Resolve.pm b/URPM/Resolve.pm new file mode 100644 index 0000000..b82b45b --- /dev/null +++ b/URPM/Resolve.pm @@ -0,0 +1,2003 @@ +package URPM; +#package URPM::Resolve; +#use URPM; + +# $Id: Resolve.pm 270395 2010-07-30 00:55:59Z nanardon $ + +use strict; +use warnings; +use Config; + + +#- a few functions from MDK::Common copied here: +sub listlength { scalar @_ } +sub min { my $n = shift; $_ < $n and $n = $_ foreach @_; $n } +sub uniq { my %l; $l{$_} = 1 foreach @_; grep { delete $l{$_} } @_ } +sub find(&@) { + my $f = shift; + $f->($_) and return $_ foreach @_; + undef; +} + +#- property2name* functions below parse things like "mageia-release[>= 1]" +#- which is the format returned by URPM.xs for ->requires, ->provides, ->conflicts... +sub property2name { + $_[0] =~ /^([^\s\[]*)/ && $1; +} +sub property2name_range { + $_[0] =~ /^([^\s\[]*)(?:\[\*\])?\[?([^\s\]]*\s*[^\s\]]*)/; +} +sub property2name_op_version { + $_[0] =~ /^([^\s\[]*)(?:\[\*\])?\s*\[?([^\s\]]*)\s*([^\s\]]*)/; +} + +#- wrappers around $state (cf "The $state object" in "perldoc URPM") +sub packages_to_remove { + my ($state) = @_; + grep { + $state->{rejected}{$_}{removed} && !$state->{rejected}{$_}{obsoleted}; + } keys %{$state->{rejected} || {}}; +} +sub removed_or_obsoleted_packages { + my ($state) = @_; + grep { + $state->{rejected}{$_}{removed} || $state->{rejected}{$_}{obsoleted}; + } keys %{$state->{rejected} || {}}; +} + +#- Find candidates packages from a require string (or id). +#- Takes care of choices using the '|' separator. +#- (nb: see also find_required_package()) +#- +#- side-effects: none +sub find_candidate_packages_ { + my ($urpm, $id_prop, $o_rejected) = @_; + my @packages; + + foreach (split /\|/, $id_prop) { + if (/^\d+$/) { + my $pkg = $urpm->{depslist}[$_]; + $pkg->flag_skip and next; + $pkg->arch eq 'src' || $pkg->is_arch_compat or next; + $o_rejected && exists $o_rejected->{$pkg->fullname} and next; + push @packages, $pkg; + } elsif (my $name = property2name($_)) { + my $property = $_; + foreach (keys %{$urpm->{provides}{$name} || {}}) { + my $pkg = $urpm->{depslist}[$_]; + $pkg->flag_skip and next; + $pkg->is_arch_compat or next; + $o_rejected && exists $o_rejected->{$pkg->fullname} and next; + #- check if at least one provide of the package overlap the property. + !$urpm->{provides}{$name}{$_} || $pkg->provides_overlap($property, 1) + and push @packages, $pkg; + } + } + } + @packages; +} + +#- deprecated, use find_candidate_packages_() directly +#- +#- side-effects: none +sub find_candidate_packages { + my ($urpm, $id_prop, $o_rejected) = @_; + + my %packages; + foreach (find_candidate_packages_($urpm, $id_prop, $o_rejected)) { + push @{$packages{$_->name}}, $_; + } + \%packages; +} + +#- returns the "arch" of package $n in rpm db +sub get_installed_arch { + my ($db, $n) = @_; + my $arch; + $db->traverse_tag('name', [ $n ], sub { $arch = $_[0]->arch }); + $arch; +} + +#- is "strict-arch" wanted? (cf "man urpmi") +#- since it's slower we only force it on bi-arch +sub strict_arch { + my ($urpm) = @_; + defined $urpm->{options}{'strict-arch'} ? $urpm->{options}{'strict-arch'} : $Config{archname} =~ /x86_64|sparc64|ppc64/; +} +my %installed_arch; + +#- checks wether $pkg could be installed under strict-arch policy +#- (ie check wether $pkg->name with different arch is not installed) +#- +#- side-effects: none (but uses a cache) +sub strict_arch_check_installed { + my ($db, $pkg) = @_; + if ($pkg->arch ne 'src' && $pkg->arch ne 'noarch') { + my $n = $pkg->name; + defined $installed_arch{$n} or $installed_arch{$n} = get_installed_arch($db, $n); + if ($installed_arch{$n} && $installed_arch{$n} ne 'noarch') { + $pkg->arch eq $installed_arch{$n} or return; + } + } + 1; +} + +#- check wether $installed_pkg and $pkg have same arch +#- (except for src/noarch of course) +#- +#- side-effects: none +sub strict_arch_check { + my ($installed_pkg, $pkg) = @_; + if ($pkg->arch ne 'src' && $pkg->arch ne 'noarch') { + if ($installed_pkg->arch ne 'noarch') { + $pkg->arch eq $installed_pkg->arch or return; + } + } + 1; +} + +#- is $pkg->name installed? +#- +#- side-effects: none +sub is_package_installed { + my ($db, $pkg) = @_; + + my $found; + $db->traverse_tag('name', [ $pkg->name ], sub { + my ($p) = @_; + $found ||= $p->fullname eq $pkg->fullname; + }); + $found; +} + +sub _is_selected_or_installed { + my ($urpm, $db, $name) = @_; + + (grep { $_->flag_available } $urpm->packages_providing($name)) > 0 || + $db->traverse_tag('name', [ $name ], undef) > 0; +} + +#- finds $pkg "provides" that matches $provide_name, and returns the version provided +#- eg: $pkg provides "a = 3", $provide_name is "a > 1", returns "3" +sub provided_version_that_overlaps { + my ($pkg, $provide_name) = @_; + + my $version; + foreach my $property ($pkg->provides) { + my ($n, undef, $v) = property2name_op_version($property) or next; + $n eq $provide_name or next; + + if ($version) { + $version = $v if URPM::rpmvercmp($v, $version) > 0; + } else { + $version = $v; + } + } + $version; +} + +#- deprecated function, use find_required_package() +sub find_chosen_packages { &find_required_package } + +#- find the package (or packages) to install matching $id_prop +#- returns (list ref of matches, list ref of preferred matches) +#- (see also find_candidate_packages_()) +#- +#- side-effects: flag_install, flag_upgrade (and strict_arch_check_installed cache) +sub find_required_package { + my ($urpm, $db, $state, $id_prop) = @_; + my (%packages, %provided_version); + my $strict_arch = strict_arch($urpm); + + my $may_add_to_packages = sub { + my ($pkg) = @_; + + if (my $p = $packages{$pkg->name}) { + $pkg->flag_requested > $p->flag_requested || + $pkg->flag_requested == $p->flag_requested && $pkg->compare_pkg($p) > 0 and $packages{$pkg->name} = $pkg; + } else { + $packages{$pkg->name} = $pkg; + } + }; + + #- search for possible packages, try to be as fast as possible, backtrack can be longer. + foreach (split /\|/, $id_prop) { + if (/^\d+$/) { + my $pkg = $urpm->{depslist}[$_]; + $pkg->arch eq 'src' || $pkg->is_arch_compat or next; + $pkg->flag_skip || $state->{rejected}{$pkg->fullname} and next; + #- determine if this package is better than a possibly previously chosen package. + $pkg->flag_selected || exists $state->{selected}{$pkg->id} and return [$pkg]; + !$strict_arch || strict_arch_check_installed($db, $pkg) or next; + $may_add_to_packages->($pkg); + } elsif (my $name = property2name($_)) { + my $property = $_; + foreach (keys %{$urpm->{provides}{$name} || {}}) { + my $pkg = $urpm->{depslist}[$_]; + $pkg->is_arch_compat or next; + $pkg->flag_skip || $state->{rejected}{$pkg->fullname} and next; + #- check if at least one provide of the package overlaps the property + if (!$urpm->{provides}{$name}{$_} || $pkg->provides_overlap($property)) { + #- determine if this package is better than a possibly previously chosen package. + $pkg->flag_selected || exists $state->{selected}{$pkg->id} and return [$pkg]; + !$strict_arch || strict_arch_check_installed($db, $pkg) or next; + $provided_version{$pkg} = provided_version_that_overlaps($pkg, $name); + $may_add_to_packages->($pkg); + } + } + } + } + my @packages = values %packages; + + if (@packages > 1) { + #- packages should be preferred if one of their provides is referenced + #- in the "requested" hash, or if the package itself is requested (or + #- required). + #- If there is no preference, choose the first one by default (higher + #- probability of being chosen) and ask the user. + #- Packages with more compatibles architectures are always preferred. + #- Puts the results in @chosen. Other are left unordered. + foreach my $pkg (@packages) { + _set_flag_installed_and_upgrade_if_no_newer($db, $pkg); + } + + if (my @kernel_source = _find_required_package__kernel_source($urpm, $db, \@packages)) { + $urpm->{debug_URPM}("packageCallbackChoices: kernel source chosen " . join(",", map { $_->name } @kernel_source) . " in " . join(",", map { $_->name } @packages)) if $urpm->{debug_URPM}; + return \@kernel_source, \@kernel_source; + } + if (my @kmod = _find_required_package__kmod($urpm, $db, \@packages)) { + $urpm->{debug_URPM}("packageCallbackChoices: kmod packages " . join(",", map { $_->name } @kmod) . " in " . join(",", map { $_->name } @packages)) if $urpm->{debug_URPM}; + return \@kmod, \@kmod; + } + + _find_required_package__sort($urpm, $db, \@packages, \%provided_version); + } else { + \@packages; + } +} + +# nb: _set_flag_installed_and_upgrade_if_no_newer must be done on $packages +sub _find_required_package__sort { + my ($urpm, $db, $packages, $provided_version) = @_; + + my ($best, @other) = sort { + $a->[1] <=> $b->[1] #- we want the lowest (ie preferred arch) + || $b->[2] <=> $a->[2]; #- and the higher score + } map { + my $score = 0; + $score += 2 if $_->flag_requested; + $score += $_->flag_upgrade ? 1 : -1 if $_->flag_installed; + [ $_, $_->is_arch_compat, $score ]; + } @$packages; + + my @chosen_with_score = ($best, grep { $_->[1] == $best->[1] && $_->[2] == $best->[2] } @other); + my @chosen = map { $_->[0] } @chosen_with_score; + + #- return immediately if there is only one chosen package + if (@chosen == 1) { return \@chosen } + + #- if several packages were selected to match a requested installation, + #- and if --more-choices wasn't given, trim the choices to the first one. + if (!$urpm->{options}{morechoices} && $chosen_with_score[0][2] == 3) { + return [ $chosen[0] ]; + } + + if ($urpm->{media}) { + @chosen_with_score = sort { + $a->[2] != $b->[2] ? + $a->[0]->id <=> $b->[0]->id : + $b->[1] <=> $a->[1] || $b->[0]->compare_pkg($a->[0]); + } map { [ $_, _score_for_locales($urpm, $db, $_), pkg2media($urpm->{media}, $_) ] } @chosen; + } else { + # obsolete code which should not happen, kept just in case + $urpm->{debug_URPM}("can't sort choices by media") if $urpm->{debug_URPM}; + @chosen_with_score = sort { + $b->[1] <=> $a->[1] || + $b->[0]->compare_pkg($a->[0]) || $a->[0]->id <=> $b->[0]->id; + } map { [ $_, _score_for_locales($urpm, $db, $_) ] } @chosen; + } + if (!$urpm->{options}{morechoices}) { + if (my @valid_locales = grep { $_->[1] } @chosen_with_score) { + #- get rid of invalid locales + @chosen_with_score = @valid_locales; + } + } + # propose to select all packages for installed locales + my @prefered = grep { $_->[1] == 3 } @chosen_with_score; + + @chosen = map { $_->[0] } @chosen_with_score; + if (%$provided_version) { + # highest provided version first + # (nb: this sort overrules the sort on media (cf ->id above)) + @chosen = sort { URPM::rpmvercmp($provided_version->{$b} || 0, $provided_version->{$a} || 0) } @chosen; + } + \@chosen, [ map { $_->[0] } @prefered ]; +} + +#- prefer the pkgs corresponding to installed/selected kernels +sub _find_required_package__kernel_source { + my ($urpm, $db, $choices) = @_; + + $choices->[0]->name =~ /^kernel-(.*source-|.*-devel-)/ or return; + + grep { + if ($_->name =~ /^kernel-.*source-stripped-(.*)/) { + my $version = quotemeta($1); + find { + $_->name =~ /-$version$/ && ($_->flag_installed || $_->flag_selected); + } $urpm->packages_providing('kernel'); + } elsif ($_->name =~ /(kernel-.*)-devel-(.*)/) { + my $kernel = "$1-$2"; + _is_selected_or_installed($urpm, $db, $kernel); + } elsif ($_->name =~ /^kernel-.*source-/) { + #- hopefully we don't have a media with kernel-source but not kernel-source-stripped nor kernel-.*-devel + 0; + } else { + $urpm->{debug_URPM}("unknown kernel-source package " . $_->fullname) if $urpm->{debug_URPM}; + 0; + } + } @$choices; +} + +#- prefer the pkgs corresponding to installed/selected kernels +sub _find_required_package__kmod { + my ($urpm, $db, $choices) = @_; + + $choices->[0]->name =~ /^dkms-|-kernel-2\./ or return; + + grep { + if (my ($_name, $version, $flavor, $release) = $_->name =~ /(.*)-kernel-(2\..*)-(.*)-(.*)/) { + my $kernel = "kernel-$flavor-$version-$release"; + _is_selected_or_installed($urpm, $db, $kernel); + } elsif ($_->name =~ /^dkms-/) { + 0; # we prefer precompiled dkms + } else { + $urpm->{debug_URPM}("unknown kmod package " . $_->fullname) if $urpm->{debug_URPM}; + 0; + } + } @$choices; +} + +#- Packages that require locales-xxx when the corresponding locales are +#- already installed should be preferred over packages that require locales +#- which are not installed. +#- +#- eg: locales-fr & locales-de are installed, +#- prefer firefox-fr & firefox-de which respectively require locales-fr & locales-de +sub _score_for_locales { + my ($urpm, $db, $pkg) = @_; + + my @r = $pkg->requires_nosense; + + if (my ($specific_locales) = grep { /locales-(?!en)/ } @r) { + if (_is_selected_or_installed($urpm, $db, $specific_locales)) { + 3; # good locale + } else { + 0; # bad locale + } + } elsif (grep { /locales-en/ } @r) { + 2; # + } else { + 1; + } +} + +#- side-effects: $properties, $choices +#- + those of backtrack_selected ($state->{backtrack}, $state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) +sub _choose_required { + my ($urpm, $db, $state, $dep, $properties, $choices, $diff_provides, %options) = @_; + + #- take the best choice possible. + my ($chosen, $prefered) = find_required_package($urpm, $db, $state, $dep->{required}); + + #- If no choice is found, this means that nothing can be possibly selected + #- according to $dep, so we need to retry the selection, allowing all + #- packages that conflict or anything similar to see which strategy can be + #- tried. Backtracking is used to avoid trying multiple times the same + #- packages. If multiple packages are possible and properties is not + #- empty, postpone the choice for a later time as one of the packages + #- may be selected for another reason. Otherwise simply ask the user which + #- one to choose; else take the first one available. + if (!@$chosen) { + $urpm->{debug_URPM}("no packages match " . _dep_to_name($urpm, $dep) . " (it is either in skip.list or already rejected)") if $urpm->{debug_URPM}; + unshift @$properties, backtrack_selected($urpm, $db, $state, $dep, $diff_provides, %options); + return; #- backtrack code choose to continue with same package or completely new strategy. + } elsif (@$chosen > 1) { + if (@$properties) { + unshift @$choices, $dep; + return; + } elsif ($options{callback_choices}) { + my @l = grep { ref $_ } $options{callback_choices}->($urpm, $db, $state, $chosen, _dep_to_name($urpm, $dep), $prefered); + $urpm->{debug_URPM}("replacing " . _dep_to_name($urpm, $dep) . " with " . + join(' ', map { $_->name } @l)) if $urpm->{debug_URPM}; + unshift @$properties, map { + +{ + required => $_->id, + _choices => $dep->{required}, + exists $dep->{from} ? (from => $dep->{from}) : @{[]}, + exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, + }; + } @l; + return; #- always redo according to choices. + } + } + + + #- now do the real work, select the package. + my $pkg = shift @$chosen; + if ($urpm->{debug_URPM} && $pkg->name ne _dep_to_name($urpm, $dep)) { + $urpm->{debug_URPM}("chosen " . $pkg->fullname . " for " . _dep_to_name($urpm, $dep)); + @$chosen and $urpm->{debug_URPM}(" (it could also have chosen " . join(' ', map { scalar $_->fullname } @$chosen)); + } + + $pkg; +} + +sub pkg2media { + my ($mediums, $p) = @_; + my $id = $p->id; + #- || 0 to avoid undef, but is it normal to have undef ? + find { $id >= ($_->{start} || 0) && $id <= ($_->{end} || 0) } @$mediums; +} + +sub whatrequires { + my ($urpm, $state, $property_name) = @_; + + map { $urpm->{depslist}[$_] } whatrequires_id($state, $property_name); +} +sub whatrequires_id { + my ($state, $property_name) = @_; + + keys %{$state->{whatrequires}{$property_name} || {}}; +} + +#- return unresolved requires of a package (a new one or an existing one). +#- +#- side-effects: none (but uses a $state->{cached_installed}) +sub unsatisfied_requires { + my ($urpm, $db, $state, $pkg, %options) = @_; + my %unsatisfied; + + #- all requires should be satisfied according to selected packages or installed packages, + #- or the package itself. + REQUIRES: foreach my $prop ($pkg->requires) { + my ($n, $s) = property2name_range($prop) or next; + + if (defined $options{name} && $n ne $options{name}) { + #- allow filtering on a given name (to speed up some search). + } elsif (exists $unsatisfied{$prop}) { + #- avoid recomputing the same all the time. + } else { + #- check for installed packages in the installed cache. + foreach (keys %{$state->{cached_installed}{$n} || {}}) { + exists $state->{rejected}{$_} and next; + next REQUIRES; + } + + #- check on the selected package if a provide is satisfying the resolution (need to do the ops). + foreach (grep { exists $state->{selected}{$_} } keys %{$urpm->{provides}{$n} || {}}) { + my $p = $urpm->{depslist}[$_]; + !$urpm->{provides}{$n}{$_} || $p->provides_overlap($prop, 1) and next REQUIRES; + } + + #- check if the package itself provides what is necessary. + $pkg->provides_overlap($prop) and next REQUIRES; + + #- check on installed system if a package which is not obsoleted is satisfying the require. + my $satisfied = 0; + if ($n =~ m!^/!) { + $db->traverse_tag('path', [ $n ], sub { + my ($p) = @_; + exists $state->{rejected}{$p->fullname} and return; + $state->{cached_installed}{$n}{$p->fullname} = undef; + ++$satisfied; + }); + } else { + $db->traverse_tag('whatprovides', [ $n ], sub { + my ($p) = @_; + exists $state->{rejected}{$p->fullname} and return; + foreach ($p->provides) { + if (my ($pn, $ps) = property2name_range($_)) { + $ps or $state->{cached_installed}{$pn}{$p->fullname} = undef; + $pn eq $n or next; + URPM::ranges_overlap($ps, $s, 1) and ++$satisfied; + } + } + }); + } + #- if nothing can be done, the require should be resolved. + $satisfied or $unsatisfied{$prop} = undef; + } + } + + keys %unsatisfied; +} + +#- this function is "suggests vs requires" safe: +#- 'whatrequires' will give both requires & suggests, but unsatisfied_requires +#- will check $p->requires and so filter out suggests + +#- side-effects: only those done by $do +sub with_db_unsatisfied_requires { + my ($urpm, $db, $state, $name, $do) = @_; + + $db->traverse_tag('whatrequires', [ $name ], sub { + my ($p) = @_; + if (my @l = unsatisfied_requires($urpm, $db, $state, $p, name => $name)) { + $urpm->{debug_URPM}("installed " . $p->fullname . " is conflicting because of unsatisfied @l") if $urpm->{debug_URPM}; + $do->($p, @l); + } + }); +} + +#- side-effects: only those done by $do +sub with_state_unsatisfied_requires { + my ($urpm, $db, $state, $name, $do) = @_; + + foreach (whatrequires_id($state, $name)) { + $state->{selected}{$_} or next; + my $p = $urpm->{depslist}[$_]; + if (my @l = unsatisfied_requires($urpm, $db, $state, $p, name => $name)) { + $urpm->{debug_URPM}("selected " . $p->fullname . " is conflicting because of unsatisfied @l") if $urpm->{debug_URPM}; + $do->($p, @l); + } + } +} + +sub with_any_unsatisfied_requires { + my ($urpm, $db, $state, $name, $do) = @_; + with_db_unsatisfied_requires($urpm, $db, $state, $name, sub { my ($p, @l) = @_; $do->($p, 0, @l)}); + with_state_unsatisfied_requires($urpm, $db, $state, $name, sub { my ($p, @l) = @_; $do->($p, 1, @l)}); +} + + +# used when a require is not available +# +#- side-effects: $state->{backtrack}, $state->{selected} +#- + those of disable_selected_and_unrequested_dependencies ($state->{whatrequires}, flag_requested, flag_required) +#- + those of _set_rejected_from ($state->{rejected}) +#- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) +#- + those of _add_rejected_backtrack ($state->{rejected}) +sub backtrack_selected { + my ($urpm, $db, $state, $dep, $diff_provides, %options) = @_; + + if (defined $dep->{required}) { + #- avoid deadlock here... + if (!exists $state->{backtrack}{deadlock}{$dep->{required}}) { + $state->{backtrack}{deadlock}{$dep->{required}} = undef; + + #- search for all possible packages, first is to try the selection, then if it is + #- impossible, backtrack the origin. + my @packages = find_candidate_packages_($urpm, $dep->{required}); + + foreach (@packages) { + #- avoid dead loop. + exists $state->{backtrack}{selected}{$_->id} and next; + #- a package if found is problably rejected or there is a problem. + if ($state->{rejected}{$_->fullname}) { + #- keep in mind a backtrack has happening here... + exists $dep->{promote} and _add_rejected_backtrack($state, $_, { promote => [ $dep->{promote} ] }); + + my $closure = $state->{rejected}{$_->fullname}{closure} || {}; + foreach my $p (grep { exists $closure->{$_}{avoid} } keys %$closure) { + _add_rejected_backtrack($state, $_, { conflicts => [ $p ] }) + } + #- backtrack callback should return a strictly positive value if the selection of the new + #- package is prefered over the currently selected package. + next; + } + $state->{backtrack}{selected}{$_->id} = undef; + + #- in such case, we need to drop the problem caused so that rejected condition is removed. + #- if this is not possible, the next backtrack on the same package will be refused above. + my @l = map { $urpm->search($_, strict_fullname => 1) } + keys %{($state->{rejected}{$_->fullname} || {})->{closure}}; + + disable_selected_and_unrequested_dependencies($urpm, $db, $state, @l); + + return { required => $_->id, + exists $dep->{from} ? (from => $dep->{from}) : @{[]}, + exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, + exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, + exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, + }; + } + } + } + + if (defined $dep->{from}) { + if ($options{nodeps}) { + #- try to keep unsatisfied dependencies in requested. + if ($dep->{required} && exists $state->{selected}{$dep->{from}->id}) { + push @{$state->{selected}{$dep->{from}->id}{unsatisfied}}, $dep->{required}; + } + } else { + #- at this point, dep cannot be resolved, this means we need to disable + #- all selection tree, re-enabling removed and obsoleted packages as well. + unless (exists $state->{rejected}{$dep->{from}->fullname}) { + #- package is not currently rejected, compute the closure now. + my @l = disable_selected_and_unrequested_dependencies($urpm, $db, $state, $dep->{from}); + foreach (@l) { + #- disable all these packages in order to avoid selecting them again. + _set_rejected_from($state, $_, $dep->{from}); + } + } + #- the package is already rejected, we assume we can add another reason here! + $urpm->{debug_URPM}("adding a reason to already rejected package " . $dep->{from}->fullname . ": unsatisfied " . $dep->{required}) if $urpm->{debug_URPM}; + + _add_rejected_backtrack($state, $dep->{from}, { unsatisfied => [ $dep->{required} ] }); + } + } + + my @properties; + if (defined $dep->{psel}) { + if ($options{keep}) { + backtrack_selected_psel_keep($urpm, $db, $state, $dep->{psel}, $dep->{keep}); + + #- the package is already rejected, we assume we can add another reason here! + defined $dep->{promote} and _add_rejected_backtrack($state, $dep->{psel}, { promote => [ $dep->{promote} ] }); + } else { + #- the backtrack need to examine diff_provides promotion on $n. + with_db_unsatisfied_requires($urpm, $db, $state, $dep->{promote}, sub { + my ($p, @unsatisfied) = @_; + my %diff_provides_h; + set_rejected_and_compute_diff_provides($urpm, $state, \%diff_provides_h, { + rejected_pkg => $p, removed => 1, + from => $dep->{psel}, + why => { unsatisfied => \@unsatisfied } + }); + push @$diff_provides, map { +{ name => $_, pkg => $dep->{psel} } } keys %diff_provides_h; + }); + with_state_unsatisfied_requires($urpm, $db, $state, $dep->{promote}, sub { + my ($p) = @_; + _set_rejected_from($state, $p, $dep->{psel}); + disable_selected_and_unrequested_dependencies($urpm, $db, $state, $p); + }); + } + } + + #- some packages may have been removed because of selection of this one. + #- the rejected flags should have been cleaned by disable_selected above. + @properties; +} + +#- side-effects: +#- + those of _set_rejected_from ($state->{rejected}) +#- + those of _add_rejected_backtrack ($state->{rejected}) +#- + those of disable_selected_and_unrequested_dependencies ($state->{selected}, $state->{whatrequires}, flag_requested, flag_required) +sub backtrack_selected_psel_keep { + my ($urpm, $db, $state, $psel, $keep) = @_; + + #- we shouldn't try to remove packages, so psel which leads to this need to be unselected. + unless (exists $state->{rejected}{$psel->fullname}) { + #- package is not currently rejected, compute the closure now. + my @l = disable_selected_and_unrequested_dependencies($urpm, $db, $state, $psel); + foreach (@l) { + #- disable all these packages in order to avoid selecting them again. + _set_rejected_from($state, $_, $psel); + } + } + #- to simplify, a reference to list or standalone elements may be set in keep. + $keep and _add_rejected_backtrack($state, $psel, { keep => $keep }); +} + +#- side-effects: $state->{rejected} +sub _remove_all_rejected_from { + my ($state, $from_fullname) = @_; + + grep { + _remove_rejected_from($state, $_, $from_fullname); + } keys %{$state->{rejected}}; +} + +#- side-effects: $state->{rejected} +sub _remove_rejected_from { + my ($state, $fullname, $from_fullname) = @_; + + my $rv = $state->{rejected}{$fullname} or return; + + foreach (qw(removed obsoleted)) { + if (exists $rv->{$_} && exists $rv->{$_}{$from_fullname}) { + delete $rv->{$_}{$from_fullname}; + delete $rv->{$_} if !%{$rv->{$_}}; + } + } + + exists $rv->{closure}{$from_fullname} or return; + delete $rv->{closure}{$from_fullname}; + if (%{$rv->{closure}}) { + 0; + } else { + delete $state->{rejected}{$fullname}; + 1; + } +} + +#- side-effects: $state->{rejected} +sub _add_rejected_backtrack { + my ($state, $pkg, $backtrack) = @_; + + my $bt = $state->{rejected}{$pkg->fullname}{backtrack} ||= {}; + + foreach (keys %$backtrack) { + push @{$bt->{$_}}, @{$backtrack->{$_}}; + } +} + +#- useful to reject packages in advance +#- eg when selecting "a" which conflict with "b", ensure we won't select "b" +#- but it's somewhat dangerous because it's sometimes called on installed packages, +#- and in that case, a real resolve_rejected_ must be done +#- (that's why set_rejected ignores the effect of _set_rejected_from) +#- +#- side-effects: $state->{rejected} +sub _set_rejected_from { + my ($state, $pkg, $from_pkg) = @_; + + $pkg->fullname ne $from_pkg->fullname or return; + + $state->{rejected}{$pkg->fullname}{closure}{$from_pkg->fullname}{avoid} ||= undef; +} + +#- side-effects: $state->{rejected} +sub _set_rejected_old_package { + my ($state, $pkg, $new_pkg) = @_; + + if ($pkg->fullname eq $new_pkg->fullname) { + $state->{rejected_already_installed}{$pkg->id} = $pkg; + } else { + push @{$state->{rejected}{$pkg->fullname}{backtrack}{keep}}, scalar $new_pkg->fullname; + } +} + +#- side-effects: $state->{rejected} +sub set_rejected { + my ($urpm, $state, $rdep) = @_; + + my $fullname = $rdep->{rejected_pkg}->fullname; + my $rv = $state->{rejected}{$fullname} ||= {}; + + my $newly_rejected = !exists $rv->{size}; + + if ($newly_rejected) { + $urpm->{debug_URPM}("set_rejected: $fullname") if $urpm->{debug_URPM}; + #- keep track of size of package which are finally removed. + $rv->{size} = $rdep->{rejected_pkg}->size; + } + + #- keep track of what causes closure. + if ($rdep->{from}) { + my $closure = $rv->{closure}{scalar $rdep->{from}->fullname} ||= {}; + if (my $l = delete $rdep->{why}{unsatisfied}) { + my $unsatisfied = $closure->{unsatisfied} ||= []; + @$unsatisfied = uniq(@$unsatisfied, @$l); + } + $closure->{$_} = $rdep->{why}{$_} foreach keys %{$rdep->{why}}; + } + + #- set removed and obsoleted level. + foreach (qw(removed obsoleted)) { + if ($rdep->{$_}) { + if ($rdep->{from}) { + $rv->{$_}{scalar $rdep->{from}->fullname} = undef; + } else { + $rv->{$_}{asked} = undef; + } + } + } + + $newly_rejected; +} + +#- side-effects: +#- + those of set_rejected ($state->{rejected}) +#- + those of _compute_diff_provides_of_removed_pkg ($diff_provides_h) +sub set_rejected_and_compute_diff_provides { + my ($urpm, $state, $diff_provides_h, $rdep) = @_; + + my $newly_rejected = set_rejected($urpm, $state, $rdep); + + #- no need to compute diff_provides if package was already rejected + $newly_rejected or return; + + _compute_diff_provides_of_removed_pkg($urpm, $state, $diff_provides_h, $rdep->{rejected_pkg}); +} + +#- see resolve_rejected_ below +sub resolve_rejected { + my ($urpm, $db, $state, $pkg, %rdep) = @_; + $rdep{rejected_pkg} = $pkg; + resolve_rejected_($urpm, $db, $state, $rdep{unsatisfied}, \%rdep); +} + +#- close rejected (as urpme previously) for package to be removable without error. +#- +#- side-effects: $properties +#- + those of set_rejected ($state->{rejected}) +sub resolve_rejected_ { + my ($urpm, $db, $state, $properties, $rdep) = @_; + + $urpm->{debug_URPM}("resolve_rejected: " . $rdep->{rejected_pkg}->fullname) if $urpm->{debug_URPM}; + + #- check if the package has already been asked to be rejected (removed or obsoleted). + #- this means only add the new reason and return. + my $newly_rejected = set_rejected($urpm, $state, $rdep); + + $newly_rejected or return; + + my @pkgs_todo = $rdep->{rejected_pkg}; + + while (my $cp = shift @pkgs_todo) { + #- close what requires this property, but check with selected package requiring old properties. + foreach my $n ($cp->provides_nosense) { + foreach my $pkg (whatrequires($urpm, $state, $n)) { + if (my @l = unsatisfied_requires($urpm, $db, $state, $pkg, name => $n)) { + #- a selected package requires something that is no more available + #- and should be tried to be re-selected if possible. + if ($properties) { + push @$properties, map { + { required => $_, rejected => scalar $pkg->fullname }; # rejected is only there for debugging purpose (??) + } @l; + } + } + } + with_db_unsatisfied_requires($urpm, $db, $state, $n, sub { + my ($p, @unsatisfied) = @_; + + my $newly_rejected = set_rejected($urpm, $state, { + rejected_pkg => $p, + from => $rdep->{rejected_pkg}, + why => { unsatisfied => \@unsatisfied }, + obsoleted => $rdep->{obsoleted}, + removed => $rdep->{removed}, + }); + + #- continue the closure unless already examined. + $newly_rejected or return; + + $p->pack_header; #- need to pack else package is no longer visible... + push @pkgs_todo, $p; + }); + } + } +} + +# see resolve_requested__no_suggests below for information about usage +sub resolve_requested { + my ($urpm, $db, $state, $requested, %options) = @_; + + my @selected = resolve_requested__no_suggests($urpm, $db, $state, $requested, %options); + + if (!$options{no_suggests}) { + my @todo = @selected; + while (@todo) { + my $pkg = shift @todo; + my %suggests = map { $_ => 1 } $pkg->suggests or next; + + #- do not install a package that has already been suggested + $db->traverse_tag('name', [ $pkg->name ], sub { + my ($p) = @_; + delete $suggests{$_} foreach $p->suggests; + }); + + # workaround: if you do "urpmi virtual_pkg" and one virtual_pkg is already installed, + # it will ask anyway for the other choices + foreach my $suggest (keys %suggests) { + $db->traverse_tag('whatprovides', [ $suggest ], sub { + delete $suggests{$suggest}; + }); + } + + %suggests or next; + + $urpm->{debug_URPM}("requested " . join(', ', keys %suggests) . " suggested by " . $pkg->fullname) if $urpm->{debug_URPM}; + + my %new_requested = map { $_ => undef } keys %suggests; + my @new_selected = resolve_requested__no_suggests_($urpm, $db, $state, \%new_requested, %options); + $state->{selected}{$_->id}{suggested} = 1 foreach @new_selected; + push @selected, @new_selected; + push @todo, @new_selected; + } + } + @selected; +} + +#- Resolve dependencies of requested packages; keep resolution state to +#- speed up process. +#- A requested package is marked to be installed; once done, an upgrade flag or +#- an installed flag is set according to the needs of the installation of this +#- package. +#- Other required packages will have a required flag set along with an upgrade +#- flag or an installed flag. +#- Base flag should always be "installed" or "upgraded". +#- The following options are recognized : +#- callback_choices : subroutine to be called to ask the user to choose +#- between several possible packages. Returns an array of URPM::Package +#- objects, or an empty list eventually. +#- keep : +#- nodeps : +#- +#- side-effects: flag_requested +#- + those of resolve_requested__no_suggests_ +sub resolve_requested__no_suggests { + my ($urpm, $db, $state, $requested, %options) = @_; + + foreach (keys %$requested) { + #- keep track of requested packages by propating the flag. + foreach (find_candidate_packages_($urpm, $_)) { + $_->set_flag_requested; + } + } + + resolve_requested__no_suggests_($urpm, $db, $state, $requested, %options); +} + +# same as resolve_requested__no_suggests, but do not modify requested_flag +#- +#- side-effects: $state->{selected}, flag_required, flag_installed, flag_upgrade +#- + those of backtrack_selected (flag_requested, $state->{rejected}, $state->{whatrequires}, $state->{backtrack}) +#- + those of _unselect_package_deprecated_by (flag_requested, $state->{rejected}, $state->{whatrequires}, $state->{oldpackage}, $state->{unselected_uninstalled}) +#- + those of _handle_conflicts ($state->{rejected}) +#- + those of _handle_conflict ($state->{rejected}) +#- + those of backtrack_selected_psel_keep (flag_requested, $state->{whatrequires}) +#- + those of _handle_diff_provides (flag_requested, $state->{rejected}, $state->{whatrequires}) +#- + those of _no_more_recent_installed_and_providing ($state->{rejected}) +sub resolve_requested__no_suggests_ { + my ($urpm, $db, $state, $requested, %options) = @_; + + my @properties = map { + { required => $_, requested => $requested->{$_} }; + } keys %$requested; + + my (@diff_provides, @selected, @choices); + + #- 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. + do { + while (my $dep = shift @properties) { + #- we need to avoid selecting packages if the source has been disabled. + if (exists $dep->{from} && !$urpm->{keep_unrequested_dependencies}) { + exists $state->{selected}{$dep->{from}->id} or next; + } + + my $pkg = _choose_required($urpm, $db, $state, $dep, \@properties, \@choices, \@diff_provides, %options) or next; + + !$pkg || exists $state->{selected}{$pkg->id} and next; + + if ($pkg->arch eq 'src') { + $pkg->set_flag_upgrade; + } else { + _set_flag_installed_and_upgrade_if_no_newer($db, $pkg); + + if ($pkg->flag_installed && !$pkg->flag_upgrade) { + _no_more_recent_installed_and_providing($urpm, $db, $state, $pkg, $dep->{required}) or next; + } + } + + _handle_conflicts_with_selected($urpm, $db, $state, $pkg, $dep, \@properties, \@diff_provides, %options) or next; + + $urpm->{debug_URPM}("selecting " . $pkg->fullname) if $urpm->{debug_URPM}; + + #- keep in mind the package has be selected, remove the entry in requested input hash, + #- this means required dependencies have undef value in selected hash. + #- requested flag is set only for requested package where value is not false. + push @selected, $pkg; + $state->{selected}{$pkg->id} = { exists $dep->{requested} ? (requested => $dep->{requested}) : @{[]}, + exists $dep->{from} ? (from => $dep->{from}) : @{[]}, + exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, + exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, + $pkg->flag_disable_obsolete ? (install => 1) : @{[]}, + }; + + $pkg->set_flag_required; + + #- check if the package is not already installed before trying to use it, compute + #- obsoleted packages too. This is valable only for non source packages. + my %diff_provides_h; + if ($pkg->arch ne 'src' && !$pkg->flag_disable_obsolete) { + _unselect_package_deprecated_by($urpm, $db, $state, \%diff_provides_h, $pkg); + } + + #- all requires should be satisfied according to selected package, or installed packages. + if (my @l = unsatisfied_requires($urpm, $db, $state, $pkg)) { + $urpm->{debug_URPM}("requiring " . join(',', sort @l) . " for " . $pkg->fullname) if $urpm->{debug_URPM}; + unshift @properties, map { +{ required => $_, from => $pkg, + exists $dep->{promote} ? (promote => $dep->{promote}) : @{[]}, + exists $dep->{psel} ? (psel => $dep->{psel}) : @{[]}, + } } @l; + } + + #- keep in mind what is requiring each item (for unselect to work). + foreach ($pkg->requires_nosense) { + $state->{whatrequires}{$_}{$pkg->id} = undef; + } + + #- cancel flag if this package should be cancelled but too late (typically keep options). + my @keep; + + _handle_conflicts($urpm, $db, $state, $pkg, \@properties, \%diff_provides_h, $options{keep} && \@keep); + + #- examine if an existing package does not conflict with this one. + $db->traverse_tag('whatconflicts', [ $pkg->provides_nosense ], sub { + @keep and return; + my ($p) = @_; + foreach my $property ($p->conflicts) { + if ($pkg->provides_overlap($property)) { + _handle_conflict($urpm, $state, $pkg, $p, $property, $property, \@properties, \%diff_provides_h, $options{keep} && \@keep); + } + } + }); + + #- keep existing package and therefore cancel current one. + if (@keep) { + backtrack_selected_psel_keep($urpm, $db, $state, $pkg, \@keep); + } + + push @diff_provides, map { +{ name => $_, pkg => $pkg } } keys %diff_provides_h; + } + if (my $diff = shift @diff_provides) { + _handle_diff_provides($urpm, $db, $state, \@properties, \@diff_provides, $diff->{name}, $diff->{pkg}, %options); + } elsif (my $dep = shift @choices) { + push @properties, $dep; + } + } while @diff_provides || @properties || @choices; + + #- return what has been selected by this call (not all selected hash which may be not empty + #- previously. avoid returning rejected packages which weren't selectable. + grep { exists $state->{selected}{$_->id} } @selected; +} + +#- pre-disables packages that $pkg has conflict entries for, and +#- unselects $pkg if such a package is already selected +#- side-effects: +#- + those of _set_rejected_from ($state->{rejected}) +#- + those of _remove_all_rejected_from ($state->{rejected}) +#- + those of backtrack_selected ($state->{backtrack}, $state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) +sub _handle_conflicts_with_selected { + my ($urpm, $db, $state, $pkg, $dep, $properties, $diff_provides, %options) = @_; + foreach ($pkg->conflicts) { + if (my ($n, $o, $v) = property2name_op_version($_)) { + foreach my $p ($urpm->packages_providing($n)) { + $pkg == $p and next; + $p->provides_overlap($_) or next; + if (exists $state->{selected}{$p->id}) { + $urpm->{debug_URPM}($pkg->fullname . " conflicts with already selected package " . $p->fullname) if $urpm->{debug_URPM}; + _remove_all_rejected_from($state, $pkg); + _set_rejected_from($state, $pkg, $p); + unshift @$properties, backtrack_selected($urpm, $db, $state, $dep, $diff_provides, %options); + return; + } + _set_rejected_from($state, $p, $pkg); + } + } + } + 1; +} + +#- side-effects: +#- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) +#- + those of _handle_conflict ($properties, $keep, $diff_provides_h) +sub _handle_conflicts { + my ($urpm, $db, $state, $pkg, $properties, $diff_provides_h, $keep) = @_; + + #- 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) { + $keep && @$keep and last; + if (my ($file) = m!^(/[^\s\[]*)!) { + $db->traverse_tag('path', [ $file ], sub { + $keep && @$keep and return; + my ($p) = @_; + if ($keep) { + push @$keep, scalar $p->fullname; + } else { + #- all these package should be removed. + set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { + rejected_pkg => $p, removed => 1, + from => $pkg, + why => { conflicts => $file }, + }); + } + }); + } elsif (my $name = property2name($_)) { + my $property = $_; + $db->traverse_tag('whatprovides', [ $name ], sub { + $keep && @$keep and return; + my ($p) = @_; + if ($p->provides_overlap($property)) { + _handle_conflict($urpm, $state, $pkg, $p, $property, scalar($pkg->fullname), $properties, $diff_provides_h, $keep); + } + }); + } + } +} + +#- side-effects: +#- + those of _unselect_package_deprecated_by_property (flag_requested, flag_required, $state->{selected}, $state->{rejected}, $state->{whatrequires}, $state->{oldpackage}, $state->{unselected_uninstalled}) +sub _unselect_package_deprecated_by { + my ($urpm, $db, $state, $diff_provides_h, $pkg) = @_; + + _unselect_package_deprecated_by_property($urpm, $db, $state, $pkg, $diff_provides_h, $pkg->name, '<', $pkg->epoch . ":" . $pkg->version . "-" . $pkg->release); + + foreach ($pkg->obsoletes) { + my ($n, $o, $v) = property2name_op_version($_) or next; + + #- ignore if this package obsoletes itself + #- otherwise this can cause havoc if: to_install=v3, installed=v2, v3 obsoletes < v2 + if ($n ne $pkg->name) { + _unselect_package_deprecated_by_property($urpm, $db, $state, $pkg, $diff_provides_h, $n, $o, $v); + } + } +} + +#- side-effects: $state->{oldpackage}, $state->{unselected_uninstalled} +#- + those of set_rejected ($state->{rejected}) +#- + those of _set_rejected_from ($state->{rejected}) +#- + those of disable_selected (flag_requested, flag_required, $state->{selected}, $state->{rejected}, $state->{whatrequires}) +sub _unselect_package_deprecated_by_property { + my ($urpm, $db, $state, $pkg, $diff_provides_h, $n, $o, $v) = @_; + + #- populate avoided entries according to what is selected. + foreach my $p ($urpm->packages_providing($n)) { + if ($p->name eq $pkg->name) { + #- all packages with the same name should now be avoided except when chosen. + } else { + #- in case of obsoletes, keep track of what should be avoided + #- but only if package name equals the obsolete name. + $p->name eq $n && (!$o || eval($p->compare($v) . $o . 0)) or next; + } + #- these packages are not yet selected, if they happen to be selected, + #- they must first be unselected. + _set_rejected_from($state, $p, $pkg); + } + + #- examine rpm db too (but only according to package names as a fix in rpm itself) + $db->traverse_tag('name', [ $n ], sub { + my ($p) = @_; + + #- without an operator, anything (with the same name) is matched. + #- with an operator, check package EVR with the obsoletes EVR. + #- $satisfied is true if installed package has version newer or equal. + my $comparison = $p->compare($v); + my $satisfied = !$o || eval($comparison . $o . 0); + + my $obsoleted; + if ($p->name eq $pkg->name) { + #- all packages older than the current one are obsoleted, + #- the others are simply removed (the result is the same). + if ($o && $comparison > 0) { + #- installed package is newer + #- remove this package from the list of packages to install, + #- unless urpmi was invoked with --allow-force (in which + #- case rpm could be invoked with --oldpackage) + if (!$urpm->{options}{'allow-force'}) { + #- since the originally requested packages (or other + #- non-installed ones) could be unselected by the following + #- operation, remember them, to warn the user + $state->{unselected_uninstalled} = [ grep { + !$_->flag_installed; + } disable_selected($urpm, $db, $state, $pkg) ]; + + return; + } + } elsif ($satisfied) { + $obsoleted = 1; + } + } elsif ($satisfied) { + $obsoleted = 1; + } else { + return; + } + + set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { + rejected_pkg => $p, + obsoleted => $obsoleted, removed => !$obsoleted, + from => $pkg, why => $obsoleted ? undef : { old_requested => 1 }, + }); + $obsoleted or ++$state->{oldpackage}; + }); +} + +#- side-effects: $diff_provides +sub _compute_diff_provides_of_removed_pkg { + my ($urpm, $state, $diff_provides_h, $p) = @_; + + foreach ($p->provides) { + #- check differential provides between obsoleted package and newer one. + my ($pn, $ps) = property2name_range($_) or next; + + my $not_provided = 1; + foreach (grep { exists $state->{selected}{$_} } + keys %{$urpm->{provides}{$pn} || {}}) { + my $pp = $urpm->{depslist}[$_]; + foreach ($pp->provides) { + my ($ppn, $pps) = property2name_range($_) or next; + $ppn eq $pn && $pps eq $ps + and $not_provided = 0; + } + } + $not_provided and $diff_provides_h->{$pn} = undef; + } +} + +#- side-effects: none +sub _find_packages_obsoleting { + my ($urpm, $state, $p) = @_; + + grep { + !$_->flag_skip + && $_->is_arch_compat + && !exists $state->{rejected}{$_->fullname} + && $_->obsoletes_overlap($p->name . " == " . $p->epoch . ":" . $p->version . "-" . $p->release) + && $_->fullname ne $p->fullname + && (!strict_arch($urpm) || strict_arch_check($p, $_)); + } $urpm->packages_obsoleting($p->name); +} + +#- side-effects: $properties +#- + those of backtrack_selected_psel_keep ($state->{rejected}, $state->{selected}, $state->{whatrequires}, flag_requested, flag_required) +#- + those of resolve_rejected_ ($state->{rejected}, $properties) +#- + those of disable_selected_and_unrequested_dependencies (flag_requested, flag_required, $state->{selected}, $state->{whatrequires}, $state->{rejected}) +#- + those of _set_rejected_from ($state->{rejected}) +sub _handle_diff_provides { + my ($urpm, $db, $state, $properties, $diff_provides, $n, $pkg, %options) = @_; + + with_any_unsatisfied_requires($urpm, $db, $state, $n, sub { + my ($p, $from_state, @unsatisfied) = @_; + + #- try if upgrading the package will be satisfying all the requires... + #- there is no need to avoid promoting epoch as the package examined is not + #- already installed. + my @packages = find_candidate_packages_($urpm, $p->name, $state->{rejected}); + @packages = + grep { ($_->name eq $p->name ? $p->compare_pkg($_) < 0 : + $_->obsoletes_overlap($p->name . " == " . $p->epoch . ":" . $p->version . "-" . $p->release)) + && (!strict_arch($urpm) || strict_arch_check($p, $_)) + } @packages; + + if (!@packages) { + @packages = _find_packages_obsoleting($urpm, $state, $p); + } + + if (@packages) { + my $best = join('|', map { $_->id } @packages); + $urpm->{debug_URPM}("promoting " . $urpm->{depslist}[$best]->fullname . " because of conflict above") if $urpm->{debug_URPM}; + push @$properties, { required => $best, promote => $n, psel => $pkg }; + } else { + #- no package have been found, we may need to remove the package examined unless + #- there exists enough packages that provided the unsatisfied requires. + my @best; + foreach (@unsatisfied) { + my @packages = find_candidate_packages_($urpm, $_, $state->{rejected}); + if (@packages = grep { $_->fullname ne $p->fullname } @packages) { + push @best, join('|', map { $_->id } @packages); + } + } + + if (@best == @unsatisfied) { + $urpm->{debug_URPM}("promoting " . join(' ', _ids_to_fullnames($urpm, @best)) . " because of conflict above") if $urpm->{debug_URPM}; + push @$properties, map { +{ required => $_, promote => $n, psel => $pkg } } @best; + } else { + if ($from_state) { + disable_selected_and_unrequested_dependencies($urpm, $db, $state, $p); + _set_rejected_from($state, $p, $pkg); + } elsif ($options{keep}) { + backtrack_selected_psel_keep($urpm, $db, $state, $pkg, [ scalar $p->fullname ]); + } else { + my %diff_provides_h; + set_rejected_and_compute_diff_provides($urpm, $state, \%diff_provides_h, { + rejected_pkg => $p, removed => 1, + from => $pkg, + why => { unsatisfied => \@unsatisfied }, + }); + push @$diff_provides, map { +{ name => $_, pkg => $pkg } } keys %diff_provides_h; + } + } + } + }); +} + +#- side-effects: $properties, $keep +#- + those of set_rejected_and_compute_diff_provides ($state->{rejected}, $diff_provides_h) +sub _handle_conflict { + my ($urpm, $state, $pkg, $p, $property, $reason, $properties, $diff_provides_h, $keep) = @_; + + $urpm->{debug_URPM}("installed package " . $p->fullname . " is conflicting with " . $pkg->fullname . " (Conflicts: $property)") if $urpm->{debug_URPM}; + + #- the existing package will conflict with the selection; check + #- whether a newer version will be ok, else ask to remove the old. + my $need_deps = $p->name . " > " . ($p->epoch ? $p->epoch . ":" : "") . + $p->version . "-" . $p->release; + my @packages = grep { $_->name eq $p->name } find_candidate_packages_($urpm, $need_deps, $state->{rejected}); + @packages = grep { ! $_->provides_overlap($property) } @packages; + + if (!@packages) { + @packages = _find_packages_obsoleting($urpm, $state, $p); + @packages = grep { ! $_->provides_overlap($property) } @packages; + } + + if (@packages) { + my $best = join('|', map { $_->id } @packages); + $urpm->{debug_URPM}("promoting " . join('|', map { scalar $_->fullname } @packages) . " because of conflict above") if $urpm->{debug_URPM}; + unshift @$properties, { required => $best, promote_conflicts => $reason }; + } else { + if ($keep) { + push @$keep, scalar $p->fullname; + } else { + #- no package has been found, we need to remove the package examined. + set_rejected_and_compute_diff_provides($urpm, $state, $diff_provides_h, { + rejected_pkg => $p, removed => 1, + from => $pkg, + why => { conflicts => $reason }, + }); + } + } +} + +#- side-effects: none +sub _dep_to_name { + my ($urpm, $dep) = @_; + join('|', map { _id_to_name($urpm, $_) } split('\|', $dep->{required})); +} +#- side-effects: none +sub _id_to_name { + my ($urpm, $id_prop) = @_; + if ($id_prop =~ /^\d+/) { + my $pkg = $urpm->{depslist}[$id_prop]; + $pkg && $pkg->name; + } else { + $id_prop; + } +} +#- side-effects: none +sub _ids_to_names { + my $urpm = shift; + + map { $urpm->{depslist}[$_]->name } @_; +} +#- side-effects: none +sub _ids_to_fullnames { + my $urpm = shift; + + map { scalar $urpm->{depslist}[$_]->fullname } @_; +} + +#- side-effects: flag_installed, flag_upgrade +sub _set_flag_installed_and_upgrade_if_no_newer { + my ($db, $pkg) = @_; + + !$pkg->flag_upgrade && !$pkg->flag_installed or return; + + my $upgrade = 1; + $db->traverse_tag('name', [ $pkg->name ], sub { + my ($p) = @_; + $pkg->set_flag_installed; + $upgrade &&= $pkg->compare_pkg($p) > 0; + }); + $pkg->set_flag_upgrade($upgrade); +} + +#- side-effects: +#- + those of _set_rejected_old_package ($state->{rejected}) +sub _no_more_recent_installed_and_providing { + my ($urpm, $db, $state, $pkg, $required) = @_; + + my $allow = 1; + $db->traverse_tag('name', [ $pkg->name ], sub { + my ($p) = @_; + #- allow if a less recent package is installed, + if ($allow && $pkg->compare_pkg($p) <= 0) { + if ($required =~ /^\d+/ || $p->provides_overlap($required)) { + $urpm->{debug_URPM}("not selecting " . $pkg->fullname . " since the more recent " . $p->fullname . " is installed") if $urpm->{debug_URPM}; + _set_rejected_old_package($state, $pkg, $p); + $allow = 0; + } else { + $urpm->{debug_URPM}("the more recent " . $p->fullname . + " is installed, but does not provide $required whereas " . + $pkg->fullname . " does") if $urpm->{debug_URPM}; + } + } + }); + $allow; +} + +#- do the opposite of the resolve_requested: +#- unselect a package and extend to any package not requested that is no +#- longer needed by any other package. +#- return the packages that have been deselected. +#- +#- side-effects: flag_requested, flag_required, $state->{selected}, $state->{whatrequires} +#- + those of _remove_all_rejected_from ($state->{rejected}) +sub disable_selected { + my ($urpm, $db, $state, @pkgs_todo) = @_; + my @unselected; + + #- iterate over package needing unrequested one. + while (my $pkg = shift @pkgs_todo) { + exists $state->{selected}{$pkg->id} or next; + + #- keep a trace of what is deselected. + push @unselected, $pkg; + + #- perform a closure on rejected packages (removed, obsoleted or avoided). + my @rejected_todo = scalar $pkg->fullname; + while (my $fullname = shift @rejected_todo) { + push @rejected_todo, _remove_all_rejected_from($state, $fullname); + } + + #- the package being examined has to be unselected. + $urpm->{debug_URPM}("unselecting " . $pkg->fullname) if $urpm->{debug_URPM}; + $pkg->set_flag_requested(0); + $pkg->set_flag_required(0); + delete $state->{selected}{$pkg->id}; + + #- determine package that requires properties no longer available, so that they need to be + #- unselected too. + foreach my $n ($pkg->provides_nosense) { + foreach my $p (whatrequires($urpm, $state, $n)) { + exists $state->{selected}{$p->id} or next; + if (unsatisfied_requires($urpm, $db, $state, $p, name => $n)) { + #- this package has broken dependencies and is selected. + push @pkgs_todo, $p; + } + } + } + + #- clean whatrequires hash. + foreach ($pkg->requires_nosense) { + delete $state->{whatrequires}{$_}{$pkg->id}; + %{$state->{whatrequires}{$_}} or delete $state->{whatrequires}{$_}; + } + } + + #- return all unselected packages. + @unselected; +} + +#- determine dependencies that can safely been removed and are not requested +#- return the packages that have been deselected. +#- +#- side-effects: +#- + those of disable_selected (flag_requested, flag_required, $state->{selected}, $state->{whatrequires}, $state->{rejected}) +sub disable_selected_and_unrequested_dependencies { + my ($urpm, $db, $state, @pkgs_todo) = @_; + my @all_unselected; + + #- disable selected packages, then extend unselection to all required packages + #- no longer needed and not requested. + while (my @unselected = disable_selected($urpm, $db, $state, @pkgs_todo)) { + my %required; + + #- keep in the packages that had to be unselected. + @all_unselected or push @all_unselected, @unselected; + + if ($urpm->{keep_unrequested_dependencies}) { + last; + } + + #- search for unrequested required packages. + foreach (@unselected) { + foreach ($_->requires_nosense) { + foreach my $pkg (grep { $_ } $urpm->packages_providing($_)) { + $state->{selected}{$pkg->id} or next; + $state->{selected}{$pkg->id}{psel} && $state->{selected}{$state->{selected}{$pkg->id}{psel}->id} and next; + $pkg->flag_requested and next; + $required{$pkg->id} = undef; + } + } + } + + #- check required packages are not needed by another selected package. + foreach (keys %required) { + my $pkg = $urpm->{depslist}[$_] or next; + foreach ($pkg->provides_nosense) { + foreach my $p_id (whatrequires_id($state, $_)) { + exists $required{$p_id} and next; + $state->{selected}{$p_id} and $required{$pkg->id} = 1; + } + } + } + + #- now required values still undefined indicates packages than can be removed. + @pkgs_todo = map { $urpm->{depslist}[$_] } grep { !$required{$_} } keys %required; + } + + @all_unselected; +} + +#- compute selected size by removing any removed or obsoleted package. +#- +#- side-effects: none +sub selected_size { + my ($urpm, $state) = @_; + my ($size) = _selected_size_filesize($urpm, $state, 0); + $size; +} +#- side-effects: none +sub selected_size_filesize { + my ($urpm, $state) = @_; + _selected_size_filesize($urpm, $state, 1); +} +#- side-effects: none +sub _selected_size_filesize { + my ($urpm, $state, $compute_filesize) = @_; + my ($size, $filesize, $bad_filesize); + + foreach (keys %{$state->{selected} || {}}) { + my $pkg = $urpm->{depslist}[$_]; + $size += $pkg->size; + $compute_filesize or next; + + if (my $n = $pkg->filesize) { + $filesize += $n; + } elsif (!$bad_filesize) { + $urpm->{debug} and $urpm->{debug}("no filesize for package " . $pkg->fullname); + $bad_filesize = 1; + } + } + + foreach (values %{$state->{rejected} || {}}) { + $_->{removed} || $_->{obsoleted} or next; + $size -= $_->{size}; + } + + foreach (@{$state->{orphans_to_remove} || []}) { + $size -= $_->size; + } + + $size, $bad_filesize ? 0 : $filesize; +} + +#- compute installed flags for all packages in depslist. +#- +#- side-effects: flag_upgrade, flag_installed +sub compute_installed_flags { + my ($urpm, $db) = @_; + + #- first pass to initialize flags installed and upgrade for all packages. + foreach (@{$urpm->{depslist}}) { + $_->is_arch_compat or next; + $_->flag_upgrade || $_->flag_installed or $_->set_flag_upgrade; + } + + #- second pass to set installed flag and clean upgrade flag according to installed packages. + $db->traverse(sub { + my ($p) = @_; + #- compute flags. + foreach my $pkg ($urpm->packages_providing($p->name)) { + next if !defined $pkg; + $pkg->is_arch_compat && $pkg->name eq $p->name or next; + #- compute only installed and upgrade flags. + $pkg->set_flag_installed; #- there is at least one package installed (whatever its version). + $pkg->flag_upgrade and $pkg->set_flag_upgrade($pkg->compare_pkg($p) > 0); + } + }); +} + +#- side-effects: flag_skip, flag_disable_obsolete +sub compute_flag { + my ($urpm, $pkg, %options) = @_; + foreach (qw(skip disable_obsolete)) { + if ($options{$_} && !$pkg->flag($_)) { + $pkg->set_flag($_, 1); + $options{callback} and $options{callback}->($urpm, $pkg, %options); + } + } +} + +#- Adds packages flags according to an array containing packages names. +#- $val is an array reference (as returned by get_packages_list) containing +#- package names, or a regular expression matching against the fullname, if +#- enclosed in slashes. +#- %options : +#- callback : sub to be called for each package where the flag is set +#- skip : if true, set the 'skip' flag +#- disable_obsolete : if true, set the 'disable_obsolete' flag +#- +#- side-effects: +#- + those of compute_flag (flag_skip, flag_disable_obsolete) +sub compute_flags { + my ($urpm, $val, %options) = @_; + if (ref $val eq 'HASH') { $val = [ keys %$val ] } #- compatibility with urpmi <= 4.5-13mdk + my @regex; + + #- unless a regular expression is given, search in provides + foreach my $name (@$val) { + if ($name =~ m,^/(.*)/$,) { + push @regex, $1; + } else { + foreach my $pkg ($urpm->packages_providing($name)) { + compute_flag($urpm, $pkg, %options); + } + } + } + + #- now search packages which fullname match given regexps + if (@regex) { + #- very costly :-( + foreach my $pkg (@{$urpm->{depslist}}) { + if (grep { $pkg->fullname =~ /$_/ } @regex) { + compute_flag($urpm, $pkg, %options); + } + } + } +} + +#- side-effects: none +sub _choose_best_pkg { + my ($urpm, $pkg_installed, @pkgs) = @_; + + _choose_best_pkg_($urpm, $pkg_installed, grep { + $_->compare_pkg($pkg_installed) > 0; + } @pkgs); +} + +#- side-effects: none +sub _choose_best_pkg_ { + my ($urpm, $pkg_installed, @pkgs) = @_; + + my $best; + foreach my $pkg (grep { + !strict_arch($urpm) || strict_arch_check($pkg_installed, $_); + } @pkgs) { + if (!$best || ($pkg->compare_pkg($best) || $pkg->id < $best->id) > 0) { + $best = $pkg; + } + } + $best; +} + +#- side-effects: none +sub _choose_bests_obsolete { + my ($urpm, $db, $pkg_installed, @pkgs) = @_; + + _set_flag_installed_and_upgrade_if_no_newer($db, $_) foreach @pkgs; + + my %by_name; + push @{$by_name{$_->name}}, $_ foreach grep { $_->flag_upgrade } @pkgs; + + map { _choose_best_pkg_($urpm, $pkg_installed, @$_) } values %by_name; +} + +#- 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. +#- (used for --auto-select) +#- +#- side-effects: $requisted, flag_installed, flag_upgrade +sub request_packages_to_upgrade { + my ($urpm, $db, $state, $requested, %options) = @_; + + my %by_name; + + #- now we can examine all existing packages to find packages to upgrade. + $db->traverse(sub { + my ($pkg_installed) = @_; + my $name = $pkg_installed->name; + my $pkg; + if (exists $by_name{$name}) { + if (my $p = $by_name{$name}) { + #- here a pkg with the same name is installed twice + if ($p->compare_pkg($pkg_installed) > 0) { + #- we selected $p, and it is still a valid choice + $pkg = $p; + } else { + #- $p is no good since $pkg_installed is higher version, + } + } + } elsif ($pkg = _choose_best_pkg($urpm, $pkg_installed, $urpm->packages_by_name($name))) { + #- first try with package using the same name. + $pkg->set_flag_installed; + $pkg->set_flag_upgrade; + } + if (my @pkgs = _choose_bests_obsolete($urpm, $db, $pkg_installed, _find_packages_obsoleting($urpm, $state, $pkg_installed))) { + if (@pkgs == 1) { + $pkg and $urpm->{debug_URPM}("auto-select: prefering " . $pkgs[0]->fullname . " obsoleting " . $pkg_installed->fullname . " over " . $pkg->fullname) if $urpm->{debug_URPM}; + $pkg = $pkgs[0]; + } elsif (@pkgs > 1) { + $urpm->{debug_URPM}("auto-select: multiple packages (" . join(' ', map { scalar $_->fullname } @pkgs) . ") obsoleting " . $pkg_installed->fullname) if $urpm->{debug_URPM}; + $pkg = undef; + } + } + if ($pkg && $options{idlist} && !grep { $pkg->id == $_ } @{$options{idlist}}) { + $urpm->{debug_URPM}("not auto-selecting $pkg->fullname because it's not in search medias") if $urpm->{debug_URPM}; + $pkg = undef; + } + + $pkg and $urpm->{debug_URPM}("auto-select: adding " . $pkg->fullname . " replacing " . $pkg_installed->fullname) if $urpm->{debug_URPM}; + + $by_name{$name} = $pkg; + }); + + foreach my $pkg (values %by_name) { + $pkg or next; + $pkg->set_flag_upgrade; + $requested->{$pkg->id} = $options{requested}; + } + + $requested; +} + +#- side-effects: none +sub _sort_by_dependencies_get_graph { + my ($urpm, $state, $l) = @_; + my %edges; + foreach my $id (@$l) { + my $pkg = $urpm->{depslist}[$id]; + my @provides = map { whatrequires_id($state, $_) } $pkg->provides_nosense; + if (my $from = $state->{selected}{$id}{from}) { + unshift @provides, $from->id; + } + $edges{$id} = [ uniq(@provides) ]; + } + \%edges; +} + +#- side-effects: none +sub reverse_multi_hash { + my ($h) = @_; + my %r; + my ($k, $v); + while (($k, $v) = each %$h) { + push @{$r{$_}}, $k foreach @$v; + } + \%r; +} + +sub _merge_2_groups { + my ($groups, $l1, $l2) = @_; + my $l = [ @$l1, @$l2 ]; + $groups->{$_} = $l foreach @$l; + $l; +} +sub _add_group { + my ($groups, $group) = @_; + + my ($main, @other) = uniq(grep { $_ } map { $groups->{$_} } @$group); + $main ||= []; + if (@other) { + $main = _merge_2_groups($groups, $main, $_) foreach @other; + } + foreach (grep { !$groups->{$_} } @$group) { + $groups->{$_} ||= $main; + push @$main, $_; + my @l_ = uniq(@$main); + @l_ == @$main or die ''; + } + # warn "# groups: ", join(' ', map { join('+', @$_) } uniq(values %$groups)), "\n"; +} + +#- nb: this handles $nodes list not containing all $nodes that can be seen in $edges +#- +#- side-effects: none +sub sort_graph { + my ($nodes, $edges) = @_; + + #require Data::Dumper; + #warn Data::Dumper::Dumper($nodes, $edges); + + my %nodes_h = map { $_ => 1 } @$nodes; + my (%loops, %added, @sorted); + + my $recurse; $recurse = sub { + my ($id, @ids) = @_; +# warn "# recurse $id @ids\n"; + + my $loop_ahead; + foreach my $p_id (@{$edges->{$id}}) { + if ($p_id == $id) { + # don't care + } elsif (exists $added{$p_id}) { + # already done + } elsif (grep { $_ == $p_id } @ids) { + my $begin = 1; + my @l = grep { $begin &&= $_ != $p_id } @ids; + $loop_ahead = 1; + _add_group(\%loops, [ $p_id, $id, @l ]); + } elsif ($loops{$p_id}) { + my $take; + if (my @l = grep { $take ||= $loops{$_} && $loops{$_} == $loops{$p_id} } reverse @ids) { + $loop_ahead = 1; +# warn "# loop to existing one $p_id, $id, @l\n"; + _add_group(\%loops, [ $p_id, $id, @l ]); + } + } else { + $recurse->($p_id, $id, @ids); + #- we would need to compute loop_ahead. we will do it below only once, and if not already set + } + } + if (!$loop_ahead && $loops{$id} && grep { exists $loops{$_} && $loops{$_} == $loops{$id} } @ids) { + $loop_ahead = 1; + } + + if (!$loop_ahead) { + #- it's now a leaf or a loop we're done with + my @toadd = $loops{$id} ? @{$loops{$id}} : $id; + $added{$_} = undef foreach @toadd; +# warn "# adding ", join('+', @toadd), " for $id\n"; + push @sorted, [ uniq(grep { $nodes_h{$_} } @toadd) ]; + } + }; + !exists $added{$_} and $recurse->($_) foreach @$nodes; + +# warn "# result: ", join(' ', map { join('+', @$_) } @sorted), "\n"; + + check_graph_is_sorted(\@sorted, $nodes, $edges) or die "sort_graph failed"; + + @sorted; +} + +#- side-effects: none +sub check_graph_is_sorted { + my ($sorted, $nodes, $edges) = @_; + + my $i = 1; + my %nb; + foreach (@$sorted) { + $nb{$_} = $i foreach @$_; + $i++; + } + my $nb_errors = 0; + my $error = sub { $nb_errors++; warn "error: $_[0]\n" }; + + foreach my $id (@$nodes) { + $nb{$id} or $error->("missing $id in sort_graph list"); + } + foreach my $id (keys %$edges) { + my $id_i = $nb{$id} or next; + foreach my $req (@{$edges->{$id}}) { + my $req_i = $nb{$req} or next; + $req_i <= $id_i or $error->("$req should be before $id ($req_i $id_i)"); + } + } + $nb_errors == 0; +} + + +#- side-effects: none +sub _sort_by_dependencies__add_obsolete_edges { + my ($urpm, $state, $l, $requires) = @_; + + my @obsoletes = grep { $_->{obsoleted} } values %{$state->{rejected}} or return; + my @groups = grep { @$_ > 1 } map { [ keys %{$_->{closure}} ] } @obsoletes; + my %groups; + foreach my $group (@groups) { + _add_group(\%groups, $group); + foreach (@$group) { + my $rej = $state->{rejected}{$_} or next; + _add_group(\%groups, [ $_, keys %{$rej->{closure}} ]); + } + } + + my %fullnames = map { scalar($urpm->{depslist}[$_]->fullname) => $_ } @$l; + foreach my $group (uniq(values %groups)) { + my @group = grep { defined $_ } map { $fullnames{$_} } @$group; + foreach (@group) { + @{$requires->{$_}} = uniq(@{$requires->{$_}}, @group); + } + } +} + +#- side-effects: none +sub sort_by_dependencies { + my ($urpm, $state, @list_unsorted) = @_; + @list_unsorted = sort { $a <=> $b } @list_unsorted; # sort by ids to be more reproductable + $urpm->{debug_URPM}("getting graph of dependencies for sorting") if $urpm->{debug_URPM}; + my $edges = _sort_by_dependencies_get_graph($urpm, $state, \@list_unsorted); + my $requires = reverse_multi_hash($edges); + + _sort_by_dependencies__add_obsolete_edges($urpm, $state, \@list_unsorted, $requires); + + $urpm->{debug_URPM}("sorting graph of dependencies") if $urpm->{debug_URPM}; + sort_graph(\@list_unsorted, $requires); +} + +sub sorted_rpms_to_string { + my ($urpm, @sorted) = @_; + + "rpms sorted by dependencies:\n" . join("\n", map { + join('+', _ids_to_names($urpm, @$_)); + } @sorted); +} + +#- build transaction set for given selection +#- options: start, end, idlist, split_length, keep +#- +#- side-effects: $state->{transaction}, $state->{transaction_state} +sub build_transaction_set { + my ($urpm, $db, $state, %options) = @_; + + #- clean transaction set. + $state->{transaction} = []; + + my %selected_id; + @selected_id{$urpm->build_listid($options{start}, $options{end}, $options{idlist})} = (); + + if ($options{split_length}) { + #- first step consists of sorting packages according to dependencies. + my @sorted = sort_by_dependencies($urpm, $state, + keys(%selected_id) > 0 ? + (grep { exists($selected_id{$_}) } keys %{$state->{selected}}) : + keys %{$state->{selected}}); + $urpm->{debug_URPM}(sorted_rpms_to_string($urpm, @sorted)) if $urpm->{debug_URPM}; + + #- second step consists of re-applying resolve_requested in the same + #- order computed in first step and to update a list of packages to + #- install, to upgrade and to remove. + my %examined; + my @todo = @sorted; + while (@todo) { + my @ids; + while (@todo && @ids < $options{split_length}) { + my $l = shift @todo; + push @ids, @$l; + } + my %requested = map { $_ => undef } @ids; + + resolve_requested__no_suggests_($urpm, + $db, $state->{transaction_state} ||= {}, + \%requested, + defined $options{start} ? (start => $options{start}) : @{[]}, + defined $options{end} ? (end => $options{end}) : @{[]}, + keep => $options{keep}, + ); + + my @upgrade = grep { ! exists $examined{$_} } keys %{$state->{transaction_state}{selected}}; + my @remove = grep { ! exists $examined{$_} } packages_to_remove($state->{transaction_state}); + + @upgrade || @remove or next; + + if (my @bad_remove = grep { !$state->{rejected}{$_}{removed} || $state->{rejected}{$_}{obsoleted} } @remove) { + $urpm->{error}(sorted_rpms_to_string($urpm, @sorted)) if $urpm->{error}; + $urpm->{error}('transaction is too small: ' . join(' ', @bad_remove) . ' is rejected but it should not (current transaction: ' . join(' ', _ids_to_fullnames($urpm, @upgrade)) . ', requested: ' . join('+', _ids_to_fullnames($urpm, @ids)) . ')') if $urpm->{error}; + $state->{transaction} = []; + last; + } + + $urpm->{debug_URPM}(sprintf('transaction valid: remove=%s update=%s', + join(',', @remove), + join(',', _ids_to_names($urpm, @upgrade)))) if $urpm->{debug_URPM}; + + $examined{$_} = undef foreach @upgrade, @remove; + push @{$state->{transaction}}, { upgrade => \@upgrade, remove => \@remove }; + } + + #- check that the transaction set has been correctly created. + #- (ie that no other package was removed) + if (keys(%{$state->{selected}}) == keys(%{$state->{transaction_state}{selected}}) && + listlength(packages_to_remove($state)) == listlength(packages_to_remove($state->{transaction_state})) + ) { + foreach (keys(%{$state->{selected}})) { + exists $state->{transaction_state}{selected}{$_} and next; + $urpm->{error}('using one big transaction') if $urpm->{error}; + $state->{transaction} = []; last; + } + foreach (packages_to_remove($state)) { + $state->{transaction_state}{rejected}{$_}{removed} && + !$state->{transaction_state}{rejected}{$_}{obsoleted} and next; + $urpm->{error}('using one big transaction') if $urpm->{error}; + $state->{transaction} = []; last; + } + } + } + + #- fallback if something can be selected but nothing has been allowed in transaction list. + if (%{$state->{selected} || {}} && !@{$state->{transaction}}) { + $urpm->{debug_URPM}('using one big transaction') if $urpm->{debug_URPM}; + push @{$state->{transaction}}, { + upgrade => [ keys %{$state->{selected}} ], + remove => [ packages_to_remove($state) ], + }; + } + + if ($state->{orphans_to_remove}) { + my @l = map { scalar $_->fullname } @{$state->{orphans_to_remove}}; + push @{$state->{transaction}}, { remove => \@l }; + } + + $state->{transaction}; +} + +1; diff --git a/URPM/Signature.pm b/URPM/Signature.pm new file mode 100644 index 0000000..003af07 --- /dev/null +++ b/URPM/Signature.pm @@ -0,0 +1,91 @@ +package URPM; + +use strict; +use warnings; + +#- parse from rpmlib db. +#- +#- side-effects: $urpm +sub parse_pubkeys { + my ($urpm, %options) = @_; + + my $db = $options{db}; + $db ||= URPM::DB::open($options{root}) or die "Can't open RPM DB, aborting\n"; + my @keys = parse_pubkeys_($db); + + $urpm->{keys}{$_->{id}} = $_ foreach @keys; +} + +#- side-effects: none +sub parse_pubkeys_ { + my ($db) = @_; + + my ($block, $content); + my %keys; + + $db->traverse_tag('name', [ 'gpg-pubkey' ], sub { + my ($p) = @_; + # the first blank separates the PEM headers from key data, this + # flags we found it: + my $found_blank = 0; + foreach (split "\n", $p->description) { + if ($block) { + if (/^$/ and not $found_blank) { + # All content until now were the encapsulated pem + # headers... + $content = ''; + $found_blank = 1; + } + elsif (/^-----END PGP PUBLIC KEY BLOCK-----$/) { + $keys{$p->version} = { + $p->summary =~ /^gpg\((.*)\)$/ ? (name => $1) : @{[]}, + id => $p->version, + content => $content, + block => $p->description, + }; + $block = undef; + $content = ''; + } + else { + $content .= $_; + } + } + $block ||= /^-----BEGIN PGP PUBLIC KEY BLOCK-----$/; + } + }); + + values %keys; +} + +#- obsoleted +sub import_needed_pubkeys { + warn "import_needed_pubkeys prototype has changed, please give a file directly\n"; + return; +} + +#- import pubkeys only if it is needed. +sub import_needed_pubkeys_from_file { + my ($db, $pubkey_file, $o_callback) = @_; + + my @keys = parse_pubkeys_($db); + + my $keyid = substr get_gpg_fingerprint($pubkey_file), 8; + my ($kv) = grep { (hex($keyid) == hex($_->{id})) } @keys; + my $imported; + if (!$kv) { + if (!import_pubkey_file($db, $pubkey_file)) { + #$urpm->{debug_URPM}("Couldn't import public key from ".$pubkey_file) if $urpm->{debug_URPM}; + $imported = 0; + } else { + $imported = 1; + } + @keys = parse_pubkeys_($db); + ($kv) = grep { (hex($keyid) == hex($_->{id})) } @keys; + } + + #- let the caller know about what has been found. + #- this is an error if the key is not found. + $o_callback and $o_callback->($kv?$kv->{id}:undef, $imported); +} + +1; |