File Coverage

blib/lib/urpm/select.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package urpm::select;
2              
3              
4 1     1   2143 use strict;
  1         2  
  1         29  
5 1     1   25 use urpm::msg;
  0            
  0            
6             use urpm::util qw(any formatList intersection member min partition uniq);
7             use urpm::sys;
8             use URPM;
9              
10             my $default_priority_list = 'rpm,perl-base,perl-URPM,perl-MDV-Distribconf,urpmi,meta-task,glibc,aria2';
11             my @priority_list = split(',', $default_priority_list);
12              
13             my $evr_re = qr/[^\-]*-[^\-]*\.[^\.\-]*$/;
14              
15              
16             =head1 NAME
17              
18             urpm::select - package selection routines for urpmi
19              
20             =head1 SYNOPSIS
21              
22             =head1 DESCRIPTION
23              
24             =over
25              
26             =cut
27              
28              
29             sub add_packages_to_priority_upgrade_list {
30             @priority_list = uniq(@priority_list, @_);
31             }
32              
33             sub set_priority_upgrade_option {
34             my ($urpm, $previous) = @_;
35              
36             exists $urpm->{options}{'priority-upgrade'} and return;
37              
38             # comma-separated list of packages that should be installed first,
39             # and that trigger an urpmi restart
40             my $list = join(',', @priority_list);
41             if ($previous) {
42             if ($previous eq $list) {
43             $list = '';
44             $urpm->{log}(N("urpmi was restarted, and the list of priority packages did not change"));
45             } else {
46             $urpm->{log}(N("urpmi was restarted, and the list of priority packages did change: %s vs %s", $previous, $list));
47             }
48             }
49             $urpm->{options}{'priority-upgrade'} = $list;
50             }
51              
52             sub _findindeps {
53             my ($urpm, $found, $qv, $v, $caseinsensitive, $src) = @_;
54              
55             foreach (keys %{$urpm->{provides}}) {
56             #- search through provides to find if a provide matches this one;
57             #- but manage choices correctly (as a provides may be virtual or
58             #- defined several times).
59             /$qv/ || !$caseinsensitive && /$qv/i or next;
60              
61             my @list = grep { defined $_ } map {
62             my $pkg = $_;
63             $pkg && ($src ? $pkg->arch eq 'src' : $pkg->arch ne 'src')
64             ? $pkg->id : undef;
65             } $urpm->packages_providing($_);
66             @list > 0 and push @{$found->{$v}}, join '|', @list;
67             }
68             }
69              
70             sub pkg_in_searchmedia {
71             my ($urpm, $pkg) = @_;
72              
73             foreach my $medium (grep { $_->{searchmedia} } @{$urpm->{media}}) {
74             $medium->{start} <= $pkg->id
75             && $medium->{end} >= $pkg->id and return 1;
76             }
77             0;
78             }
79             sub searchmedia_idlist {
80             my ($urpm) = @_;
81             $urpm->{searchmedia} && [
82             map { $_->{start} .. $_->{end} }
83             grep { $_->{searchmedia} } @{$urpm->{media}}
84             ];
85             }
86             sub build_listid_ {
87             my ($urpm) = @_;
88             $urpm->build_listid(undef, undef, searchmedia_idlist($urpm));
89             }
90              
91              
92             =item search_packages($urpm, $packages, $names, %options)
93              
94             Search packages registered by their names by storing their ids into the $packages hash.
95              
96             Returns either 0 (error), 1 (OK) or 'substring' (fuzzy match).
97              
98             Recognized options:
99              
100             =over
101              
102              
103             =item * all
104              
105             =item * caseinsensitive
106              
107             =item * fuzzy
108              
109             =item * no_substring: in --auto, do not allow to install a package substring match (you can use -a to force it)
110              
111             =item * src
112              
113             =item * use_provides
114              
115             =back
116              
117             =cut
118              
119             #- side-effects: $packages, flag_skip
120             sub search_packages {
121             my ($urpm, $packages, $names, %options) = @_;
122              
123             my ($name2ids, $result) = _search_packages($urpm, $names, %options) or return;
124              
125             foreach my $v (@$names) {
126             my @ids = split /\|/, $name2ids->{$v};
127              
128             #- in case we have a substring match, we want individual selection (for urpmq --fuzzy)
129             $packages->{$_} = 1 foreach $result eq 'substring' || $options{all} ? @ids : $name2ids->{$v};
130              
131             foreach (@ids) {
132             my $pkg = $urpm->{depslist}[$_] or next;
133             $urpm->{debug} and $urpm->{debug}("search_packages: found " . $pkg->fullname . " matching $v");
134             $pkg->set_flag_skip(0); #- reset skip flag as manually selected.
135             }
136             }
137             $result;
138             }
139              
140             #- side-effects: none
141             sub _search_packages {
142             my ($urpm, $names, %options) = @_;
143             my (%exact, %exact_a, %exact_ra, %found, %foundi);
144             foreach my $v (@$names) {
145             my $qv = quotemeta $v;
146             my @found;
147             $qv = '(?i)' . $qv if $options{caseinsensitive};
148              
149             # First: try to find an exact match
150             if (!$options{fuzzy}) {
151             #- try to search through provides.
152             my @l = map {
153             $_
154             && ($options{src} ? $_->arch eq 'src' : $_->is_arch_compat)
155             && ($options{use_provides} || $_->name eq $v)
156             && defined($_->id)
157             && (!$urpm->{searchmedia} || pkg_in_searchmedia($urpm, $_))
158             ? $_ : @{[]};
159             } $urpm->packages_providing($v);
160              
161             if (@l) {
162             $exact{$v} = _search_packages_keep_best($v, \@l, $options{all});
163             next;
164             }
165             } elsif ($options{use_provides}) {
166             _findindeps($urpm, \%found, $qv, $v, $options{caseinsensitive}, $options{src});
167             }
168              
169             # Second pass: try to find a partial match (substring) [slow]
170             foreach my $id (build_listid_($urpm)) {
171             my $pkg = $urpm->{depslist}[$id];
172             ($options{src} ? $pkg->arch eq 'src' : $pkg->is_arch_compat) or next;
173             my $pack_name = $pkg->name;
174             my $pack_ra = $pack_name . '-' . $pkg->version;
175             my $pack_a = "$pack_ra-" . $pkg->release;
176             my $pack = "$pack_a." . $pkg->arch;
177             if (!$options{fuzzy}) {
178             if ($pack eq $v) {
179             $exact{$v} = $id;
180             } elsif ($pack_a eq $v) {
181             push @{$exact_a{$v}}, $id;
182             } elsif ($pack_ra eq $v || $options{src} && $pack_name eq $v) {
183             push @{$exact_ra{$v}}, $id;
184             }
185             next;
186             }
187             if ($pack =~ /$qv/) {
188             next if member($pack, @found);
189             push @found, $pack;
190             push @{$found{$v}}, $id;
191             }
192             next if !$options{caseinsensitive};
193             if ($pack =~ /$qv/i) {
194             next if member($pack, @found);
195             push @found, $pack;
196             push @{$foundi{$v}}, $id;
197             }
198             }
199             }
200              
201             my $result = 1;
202             my %name2ids;
203             foreach my $v (@$names) {
204             if (defined $exact{$v}) {
205             $name2ids{$v} = $exact{$v};
206             } else {
207             #- at this level, we need to search the best package given for a given name,
208             #- always prefer already found package.
209             my %l;
210             foreach (@{$exact_a{$v} || $exact_ra{$v} || $found{$v} || $foundi{$v} || []}) {
211             my $pkg = $urpm->{depslist}[$_];
212             push @{$l{$pkg->name}}, $pkg;
213             }
214             #- non-exact match?
215             my $is_substring_match = !@{$exact_a{$v} || $exact_ra{$v} || []};
216              
217             if (values(%l) == 0
218             || !$options{all} && (values(%l) > 1 || $is_substring_match && $options{no_substring})) {
219             $urpm->{error}(N("No package named %s", $v));
220             values(%l) != 0 and $urpm->{error}(
221             N("The following packages contain %s: %s",
222             $v, formatList(4, sort { $a cmp $b } keys %l)) . "\n" .
223             N("You should use \"-a\" to use all of them")
224             );
225             $result = 0;
226             } else {
227             $is_substring_match and $result = 'substring';
228              
229             $name2ids{$v} = join('|', map {
230             my $best;
231             foreach (@$_) {
232             if ($best && $best != $_) {
233             $_->compare_pkg($best) > 0 and $best = $_;
234             } else {
235             $best = $_;
236             }
237             }
238             map { $_->id } grep { $_->fullname eq $best->fullname } @$_;
239             } values %l);
240             }
241             }
242             }
243              
244             #- return 0 if error, 'substring' if fuzzy match, 1 if ok
245             \%name2ids, $result;
246             }
247              
248             #- side-effects: none
249             sub _search_packages_keep_best {
250             my ($name, $pkgs, $all) = @_;
251              
252             #- find the lowest value of is_arch_compat
253             my ($noarch, $arch) = partition { $_->arch eq 'noarch' } @$pkgs;
254             my %compats;
255             push @{$compats{$_->is_arch_compat}}, $_ foreach @$arch;
256            
257             delete $compats{0}; #- means not compatible
258             #- if there are pkgs matching arch, prefer them
259             if (%compats && !$all) {
260             my $best_arch = min(keys %compats);
261             %compats = ($best_arch => $compats{$best_arch});
262             }
263             my @l = %compats ? (@$noarch, map { @$_ } values %compats) : @$pkgs;
264              
265             #- we assume that if there is at least one package providing
266             #- the resource exactly, this should be the best one; but we
267             #- first check if one of the packages has the same name as searched.
268             if (my @l2 = grep { $_->name eq $name } @l) {
269             @l = @l2;
270             }
271             join('|', map { $_->id } @l);
272             }
273              
274              
275             =item resolve_dependencies($urpm, $state, $requested, %options)
276              
277              
278             Resolves dependencies between requested packages (and auto selection if any).
279             Handles parallel option if any.
280              
281             The return value is true if program should be restarted (in order to take
282             care of important packages being upgraded (priority upgrades)
283              
284             $state->{selected} will contain the selection of packages to be
285             installed or upgraded
286              
287              
288             %options :
289              
290             =over
291              
292             =item * auto_select
293              
294             =item * install_src
295              
296             =item * priority_upgrade
297              
298             =back
299              
300             %options passed to ->resolve_requested:
301              
302             =over
303              
304             =item * callback_choices
305              
306             =item * keep
307              
308             =item * nodeps
309              
310             =item * no_recommends
311              
312             =back
313              
314             =cut
315              
316             sub resolve_dependencies {
317             #- $state->{selected} will contain the selection of packages to be
318             #- installed or upgraded
319             my ($urpm, $state, $requested, %options) = @_;
320             my $need_restart;
321              
322             if ($urpm->{parallel_handler}) {
323             require urpm::parallel; #- help perl_checker;
324             urpm::parallel::resolve_dependencies($urpm, $state, $requested, %options);
325             } else {
326             my $db = urpm::db_open_or_die_($urpm);
327              
328             my $sig_handler = sub { undef $db; exit 3 };
329             local $SIG{INT} = $sig_handler;
330             local $SIG{QUIT} = $sig_handler;
331              
332             #- auto select package for upgrading the distribution.
333             if ($options{auto_select}) {
334             $urpm->request_packages_to_upgrade($db, $state, $requested, requested => undef,
335             $urpm->{searchmedia} ? (idlist => searchmedia_idlist($urpm)) : (),
336             );
337             }
338              
339             if ($options{priority_upgrade} && !$urpm->{env_rpmdb}) {
340             #- first check if a priority_upgrade package is requested
341             #- (it should catch all occurences in --auto-select mode)
342             #- (nb: a package "foo" may appear twice, and only one will be set flag_upgrade)
343             $need_restart = resolve_priority_upgrades_after_auto_select($urpm, $db, $state, $requested, %options);
344             }
345              
346             if (!$need_restart) {
347             $urpm->resolve_requested($db, $state, $requested, %options);
348              
349             #- now check if a priority_upgrade package has been required
350             #- by a requested package
351             if (my @l = grep { $state->{selected}{$_->id} } _priority_upgrade_pkgs($urpm, $options{priority_upgrade})) {
352             $need_restart = _resolve_priority_upgrades($urpm, $db, $state, $state->{selected}, \@l, %options);
353             }
354             }
355             $urpm->{options}{'split-length'} = 0 if $need_restart;
356             }
357             $need_restart;
358             }
359              
360             sub select_replacepkgs {
361             my ($urpm, $state, $requested) = @_;
362              
363             my $db = urpm::db_open_or_die_($urpm);
364             foreach my $id (keys %$requested) {
365             my @pkgs = $urpm->find_candidate_packages($id);
366             if (my ($pkg) = grep { URPM::is_package_installed($db, $_) } @pkgs) {
367             $urpm->{debug_URPM}("selecting replacepkg " . $pkg->fullname) if $urpm->{debug_URPM};
368             $pkg->set_flag_requested;
369             $state->{selected}{$pkg->id} = undef;
370             } else {
371             $urpm->{fatal}(1, N("found package(s) %s in urpmi db, but none are installed", join(', ', map { scalar($_->fullname) } @pkgs)));
372             }
373             }
374             }
375              
376             sub _priority_upgrade_pkgs {
377             my ($urpm, $priority_upgrade_string) = @_;
378              
379             map {
380             $urpm->packages_by_name($_);
381             } split(/,/, $priority_upgrade_string);
382             }
383              
384              
385             sub resolve_priority_upgrades_after_auto_select {
386             my ($urpm, $db, $state, $selected, %options) = @_;
387              
388             my $need_restart;
389              
390             if (my @l = grep { $_->flag_upgrade } _priority_upgrade_pkgs($urpm, $options{priority_upgrade})) {
391             $need_restart = _resolve_priority_upgrades($urpm, $db, $state, $selected, \@l, %options);
392             }
393             $need_restart;
394             }
395              
396             sub _resolve_priority_upgrades {
397             my ($urpm, $db, $state, $selected, $priority_pkgs, %options) = @_;
398              
399             my ($need_restart, %priority_state);
400            
401             my %priority_requested = map { $_->id => undef } @$priority_pkgs;
402              
403             $urpm->resolve_requested($db, \%priority_state, \%priority_requested, %options);
404             if (any { ! exists $priority_state{selected}{$_} } keys %priority_requested) {
405             #- some packages which were selected previously have not been selected, strange!
406             } elsif (any { ! exists $priority_state{selected}{$_} } keys %$selected) {
407             #- there are other packages to install after this priority transaction.
408             %$state = %priority_state;
409             $need_restart = 1;
410             }
411             $need_restart;
412             }
413              
414             sub cooked_prefer {
415             my ($urpm, $cmdline_prefer) = @_;
416              
417             $urpm->{prefer_regexps} ||= [
418             map {
419             m!^/(.*)/$! ? "($1)" : '^' . quotemeta($_) . '$';
420             } map { @$_ }
421             urpm::sys::get_packages_list($urpm->{prefer_list}, $cmdline_prefer),
422             urpm::sys::get_packages_list($urpm->{prefer_vendor_list})
423             ];
424             @{$urpm->{prefer_regexps}};
425             }
426              
427             sub get_preferred {
428             my ($urpm, $choices, $cmdline_prefer) = @_;
429              
430             my @prefer;
431             my @l = @$choices;
432             foreach my $re (cooked_prefer($urpm, $cmdline_prefer)) {
433             my ($prefer, $other) = partition { $_->name =~ $re } @l;
434             push @prefer, @$prefer;
435             @l = @$other;
436              
437             if (@$prefer) {
438             my $prefer_s = join(',', map { $_->name } @$prefer);
439             my $other_s = join(',', map { $_->name } @l);
440             $urpm->{log}("preferring $prefer_s over $other_s");
441             }
442             }
443            
444             #- only keep the best prefered
445             #- then put the other prefered packages first
446             my $best = shift @prefer;
447             $best ? [$best] : [], [@prefer, @l];
448             }
449              
450             =item find_packages_to_remove($urpm, $state, $l, %options)
451              
452             Find packages to remove.
453              
454             Options:
455              
456             =over
457              
458             =item * callback_base
459              
460             =item * callback_fuzzy
461              
462             =item * callback_notfound
463              
464             =item * force
465              
466             =item * matches
467              
468             =item * test
469              
470             =back
471              
472             =cut
473              
474             sub find_packages_to_remove {
475             my ($urpm, $state, $l, %options) = @_;
476              
477             if ($urpm->{parallel_handler}) {
478             #- invoke parallel finder.
479             $urpm->{parallel_handler}->parallel_find_remove($urpm, $state, $l, %options, find_packages_to_remove => 1);
480             } else {
481             my $db = urpm::db_open_or_die_($urpm);
482             my (@m, @notfound);
483              
484             if (!$options{matches}) {
485             foreach (@$l) {
486             my ($found);
487              
488             $db->traverse_tag('nvra', [ $_ ], sub {
489             my ($p) = @_;
490             $urpm->resolve_rejected($db, $state, $p, removed => 1);
491             push @m, scalar $p->fullname;
492             $found = 1;
493             });
494              
495             if ($found) {
496             next;
497             } else {
498             push @notfound, $_;
499             }
500             }
501             if (!$options{force} && @notfound && @$l > 1) {
502             $options{callback_notfound} && $options{callback_notfound}->($urpm, @notfound)
503             or return ();
504             }
505             }
506             if ($options{matches} || @notfound) {
507             my $match = join "|", map { quotemeta } @$l;
508             my $qmatch = qr/$match/;
509              
510             #- reset what has been already found.
511             %$state = ();
512             @m = ();
513              
514             $urpm->{log}(qq(going through installed packages looking for "$match"...));
515             #- search for packages that match, and perform closure again.
516             $db->traverse(sub {
517             my ($p) = @_;
518             my $f = scalar $p->fullname;
519             $f =~ $qmatch or return;
520             $urpm->resolve_rejected($db, $state, $p, removed => 1);
521             push @m, $f;
522             });
523             $urpm->{log}("...done, packages found [" . join(' ', @m) . "]");
524              
525             if (!$options{force} && @notfound) {
526             if (@m) {
527             $options{callback_fuzzy} && $options{callback_fuzzy}->($urpm, @$l > 1 ? $match : $l->[0], @m)
528             or return ();
529             } else {
530             $options{callback_notfound} && $options{callback_notfound}->($urpm, @notfound)
531             or return ();
532             }
533             }
534             if (!@m) {
535             $options{callback_notfound} && $options{callback_notfound}->($urpm, @$l)
536             or return ();
537             }
538             }
539              
540             #- check if something needs to be removed.
541             find_removed_from_basesystem($urpm, $db, $state, $options{callback_base})
542             or return ();
543             }
544             removed_packages($state);
545             }
546              
547             sub find_removed_from_basesystem {
548             my ($urpm, $db, $state, $callback_base) = @_;
549             $callback_base or return 1;
550              
551             if (my @l = _prohibit_packages_that_would_be_removed($urpm, $db, $state)) {
552             $callback_base->($urpm, @l);
553             } else {
554             1;
555             }
556              
557             }
558             sub _prohibit_packages_that_would_be_removed {
559             my ($urpm, $db, $state) = @_;
560              
561             my @to_remove = removed_packages($state) or return 1;
562              
563             my @dont_remove = ('basesystem', 'basesystem-minimal',
564             split /,\s*/, $urpm->{global_config}{'prohibit-remove'});
565             my (@base_fn, %base);
566             $db->traverse_tag('whatprovides', \@dont_remove, sub {
567             my ($p) = @_;
568             $base{$p->name} = 1;
569             push @base_fn, scalar $p->fullname;
570             });
571              
572             grep {
573             ! any { $base{$_} } rejected_unsatisfied($state, $_);
574             } intersection(\@to_remove, \@base_fn);
575             }
576              
577              
578             =item unselected_packages($state)
579              
580             misc functions to help finding ask_unselect and ask_remove elements with their reasons translated.
581              
582             =cut
583              
584             sub unselected_packages {
585             my ($state) = @_;
586             grep { $state->{rejected}{$_}{backtrack} } keys %{$state->{rejected} || {}};
587             }
588              
589             =item already_installed($state)
590              
591             misc functions to help finding ask_unselect and ask_remove elements with their reasons translated.
592              
593             =cut
594              
595             sub already_installed {
596             my ($state) = @_;
597             uniq(map { scalar $_->fullname } values %{$state->{rejected_already_installed} || {}});
598             }
599              
600             sub translate_already_installed {
601             my ($state) = @_;
602              
603             my @l = already_installed($state) or return;
604              
605             @l == 1 ?
606             N("Package %s is already installed", join(', ', @l)) :
607             N("Packages %s are already installed", join(', ', @l));
608             }
609              
610             sub translate_why_unselected {
611             my ($urpm, $state, @fullnames) = @_;
612              
613             join("\n", map { translate_why_unselected_one($urpm, $state, $_) } sort @fullnames);
614             }
615              
616             sub translate_why_unselected_one {
617             my ($urpm, $state, $fullname) = @_;
618              
619             my $obj = $state->{rejected}{$fullname};
620             my $rb = $obj->{backtrack};
621             my @unsatisfied = @{$rb->{unsatisfied} || []};
622             my @conflicts = @{$rb->{conflicts} || []};
623             my $s = join ", ", (
624             (map { N("due to conflicts with %s", $_) } @conflicts),
625             (map { N("due to unsatisfied %s", $_) } uniq(map {
626             #- XXX in theory we shouldn't need this, dependencies (and not ids) should
627             #- already be present in @unsatisfied. But with biarch packages this is
628             #- not always the case.
629             /\D/ ? $_ : scalar($urpm->{depslist}[$_]->fullname);
630             } @unsatisfied)),
631             $rb->{promote} && !$rb->{keep} ? N("trying to promote %s", join(", ", @{$rb->{promote}})) : (),
632             $rb->{keep} ? N("in order to keep %s", join(", ", @{$rb->{keep}})) : (),
633             );
634             $fullname . ($s ? " ($s)" : '');
635             }
636              
637             sub selected_packages_providing {
638             my ($urpm, $state, $name) = @_;
639             map { $urpm->{depslist}[$_] } grep { $state->{selected}{$_} } keys %{$urpm->{provides}{$name} || {}};
640             }
641              
642             sub was_pkg_name_installed {
643             my ($rejected, $name) = @_;
644              
645             foreach (keys %$rejected) {
646             /^\Q$name\E-$evr_re/ or next;
647             $rejected->{$_}{obsoleted} and return 1;
648             }
649             0;
650             }
651              
652             sub removed_packages {
653             my ($state) = @_;
654             grep {
655             $state->{rejected}{$_}{removed} && !$state->{rejected}{$_}{obsoleted};
656             } keys %{$state->{rejected} || {}};
657             }
658             sub rejected_closure {
659             my ($state, $fullname) = @_;
660             $state->{rejected} && $state->{rejected}{$fullname} && $state->{rejected}{$fullname}{closure};
661             }
662             sub rejected_unsatisfied {
663             my ($state, $fullname) = @_;
664             my $closure = rejected_closure($state, $fullname) or return;
665             map { $_ ? @$_ : () } map { $_->{unsatisfied} } values %$closure;
666             }
667              
668             sub conflicting_packages_msg_ {
669             my ($removed_packages_msgs) = @_;
670              
671             my $list = join("\n", @$removed_packages_msgs) or return;
672             @$removed_packages_msgs == 1 ?
673             N("The following package has to be removed for others to be upgraded:\n%s", $list)
674             : N("The following packages have to be removed for others to be upgraded:\n%s", $list);
675             }
676             sub conflicting_packages_msg {
677             my ($urpm, $state) = @_;
678             conflicting_packages_msg_([ removed_packages_msgs($urpm, $state) ]);
679             }
680              
681             sub removed_packages_msgs {
682             my ($urpm, $state) = @_;
683             map { translate_why_removed_one($urpm, $state, $_) } sort(removed_packages($state));
684             }
685              
686             sub translate_why_removed {
687             my ($urpm, $state, @fullnames) = @_;
688             join("\n", map { translate_why_removed_one($urpm, $state, $_) } sort @fullnames);
689             }
690             sub translate_why_removed_one {
691             my ($urpm, $state, $fullname) = @_;
692              
693             my $closure = rejected_closure($state, $fullname) or return $fullname;
694              
695             my ($from) = keys %$closure;
696             my ($whyk) = sort { $b ne 'avoid' } keys %{$closure->{$from}};
697             my $whyv = $closure->{$from}{$whyk};
698             my $frompkg = $urpm->search($from, strict_fullname => 1);
699             my $s = do {
700             if ($whyk =~ /old_requested/) {
701             N("in order to install %s", $frompkg ? scalar $frompkg->fullname : $from);
702             } elsif ($whyk =~ /unsatisfied/) {
703             join(",\n ", map {
704             if (/([^\[\s]*)(?:\[\*\])?(?:\[|\s+)([^\]]*)\]?$/ && $2 ne '*') {
705             N("due to unsatisfied %s", "$1 $2");
706             } else {
707             N("due to missing %s", $_);
708             }
709             } @$whyv);
710             } elsif ($whyk =~ /conflicts/) {
711             N("due to conflicts with %s", $whyv);
712             } else {
713             $whyk;
714             }
715             };
716             #- now insert the reason if available.
717             $fullname . ($s ? "\n ($s)" : '');
718             }
719              
720             sub _libdb_version { $_[0] =~ /libdb-(\S+)\.so/ ? version->new("v$1") : () }
721             sub _rpm_version() { `rpm --version` =~ /version ([0-9.]+)(?:-(beta|rc).*)?$/ ? version->new("v$1") : () }
722              
723             sub should_we_migrate_back_rpmdb_db_version {
724             my ($urpm, $state) = @_;
725              
726             my ($pkg) = urpm::select::selected_packages_providing($urpm, $state, 'rpm') or return;
727             urpm::select::was_pkg_name_installed($state->{rejected}, 'rpm') and return;
728             my ($rooted_librpm_version) = map { _libdb_version($_) } $pkg->requires; # perl_checker: $self = revision
729             my $rooted_rpm_version = version->new("v" . $pkg->version); # perl_checker: $self = revision
730              
731             my $urpmi_librpm_version = _libdb_version(scalar `ldd /bin/rpm`); # perl_checker: $self = revision
732              
733             if (_rpm_version() ge v4.9.0) { # perl_checker: $self = revision
734             if ($rooted_rpm_version && $rooted_rpm_version ge v4.9) {
735             $urpm->{debug} and $urpm->{debug}("chrooted db version used by librpm is at least as good as non-rooted one");
736             } else {
737             $urpm->{need_migrate_rpmdb} = '4.8';
738             return 1;
739             }
740             } elsif ($urpmi_librpm_version ge v4.6) {
741             if ($rooted_librpm_version && $rooted_librpm_version ge v4.6) {
742             $urpm->{debug} and $urpm->{debug}("chrooted db version used by librpm is at least as good as non-rooted one");
743             } else {
744             foreach my $bin ('db_dump', 'db42_load') {
745             urpm::sys::whereis_binary($bin)
746             or $urpm->{error}("can not migrate rpm db from Hash version 9 to Hash version 8 without $bin"),
747             return;
748             }
749             $urpm->{need_migrate_rpmdb} = '4.6';
750             return 1;
751             }
752             }
753             0;
754             }
755              
756             1;
757              
758             =back
759              
760             =cut