File Coverage

blib/lib/urpm/orphans.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package urpm::orphans;
2              
3 2     2   3603 use strict;
  2         6  
  2         102  
4 2     2   15 use urpm::util qw(add2hash_ append_to_file cat_ output_safe partition put_in_hash uniq wc_l);
  2         6  
  2         197  
5 2     2   245 use urpm::msg;
  0            
  0            
6             use urpm;
7              
8              
9             my $fullname2name_re = qr/^(.*)-[^\-]*-[^\-]*\.[^\.\-]*$/;
10              
11              
12             =head1 NAME
13              
14             urpm::orphans - The orphan management code for urpmi
15              
16             =head1 SYNOPSIS
17              
18             =head1 DESCRIPTION
19              
20             =over
21              
22             =cut
23              
24             #- side-effects: none
25             sub installed_packages_packed {
26             my ($urpm) = @_;
27              
28             my $db = urpm::db_open_or_die_($urpm);
29             my @l;
30             $db->traverse(sub {
31             my ($pkg) = @_;
32             $pkg->pack_header;
33             push @l, $pkg;
34             });
35             \@l;
36             }
37              
38              
39             =item unrequested_list__file($urpm)
40              
41             Return the path of the unrequested list file.
42              
43             =cut
44              
45             #- side-effects: none
46             sub unrequested_list__file {
47             my ($urpm) = @_;
48             ($urpm->{env_dir} || "$urpm->{root}/var/lib/rpm") . '/installed-through-deps.list';
49             }
50              
51             =item unrequested_list($urpm)
52              
53             Returns the list of potentiel files (ake files installed as requires for others)
54              
55             =cut
56              
57             #- side-effects: none
58             sub unrequested_list {
59             my ($urpm) = @_;
60             +{ map {
61             chomp;
62             s/\s+\(.*\)$//;
63             $_ => 1;
64             } cat_(unrequested_list__file($urpm)) };
65             }
66              
67             =item mark_as_requested($urpm, $state, $test)
68              
69             Mark some packages as explicitly requested (usually because
70             they were manually installed).
71              
72             =cut
73              
74             #- side-effects: those of _write_unrequested_list__file
75             sub mark_as_requested {
76             my ($urpm, $state, $test) = @_;
77             my $unrequested = unrequested_list($urpm);
78             my $dirty;
79              
80             foreach (keys %{$state->{rejected_already_installed}},
81             grep { $state->{selected}{$_}{requested} } keys %{$state->{selected}}) {
82             my $name = $urpm->{depslist}[$_]->name;
83             if (defined($unrequested->{$name})) {
84             $urpm->{info}(N("Marking %s as manually installed, it won't be auto-orphaned", $name));
85             $dirty = 1;
86             } else {
87             $urpm->{debug}("$name is not in potential orphans") if $urpm->{debug};
88             }
89             delete $unrequested->{$name};
90             }
91              
92             if ($dirty && !$test) {
93             _write_unrequested_list__file($urpm, [keys %$unrequested]);
94             }
95             }
96              
97             =item _installed_req_and_unreq($urpm)
98              
99             Returns :
100              
101             =over
102              
103             =item * req: list of installed packages that were installed as requires of others
104              
105             =item * unreq: list of installed packages that were not installed as requres of others (ie the ones that were explicitely selected for install)
106              
107             =back
108              
109             =cut
110              
111             #- side-effects:
112             #- + those of _installed_req_and_unreq_and_update_unrequested_list (/var/lib/rpm/installed-through-deps.list)
113             sub _installed_req_and_unreq {
114             my ($urpm) = @_;
115             my ($req, $unreq, $_unrequested) = _installed_req_and_unreq_and_update_unrequested_list($urpm);
116             ($req, $unreq);
117             }
118              
119             =item _installed_and_unrequested_lists($urpm)
120              
121             Returns :
122              
123             =over
124              
125             =item * pkgs: list of installed packages
126              
127             =item * unrequested: list of packages that were installed as requires of others (the sum of the previous lists)
128              
129             =back
130              
131             =cut
132              
133             #- side-effects:
134             #- + those of _installed_req_and_unreq_and_update_unrequested_list (/var/lib/rpm/installed-through-deps.list)
135             sub _installed_and_unrequested_lists {
136             my ($urpm) = @_;
137             my ($pkgs, $pkgs2, $unrequested) = _installed_req_and_unreq_and_update_unrequested_list($urpm);
138             push @$pkgs, @$pkgs2;
139             ($pkgs, $unrequested);
140             }
141              
142             #- side-effects: /var/lib/rpm/installed-through-deps.list
143             sub _write_unrequested_list__file {
144             my ($urpm, $unreq) = @_;
145             return if $>;
146              
147             $urpm->{info}("writing " . unrequested_list__file($urpm));
148            
149             output_safe(unrequested_list__file($urpm),
150             join('', sort map { $_ . "\n" } @$unreq),
151             ".old") if !$urpm->{env_dir};
152             }
153              
154             =item _installed_req_and_unreq_and_update_unrequested_list ($urpm)
155              
156             Returns :
157              
158             =over
159              
160             =item * req: list of installed packages that were installed as requires of others
161              
162             =item * unreq: list of installed packages that were not installed as requres of others (ie the ones that were explicitely selected for install)
163              
164             =item * unrequested: list of packages that were installed as requires of others (the sum of the previous lists)
165              
166             =back
167              
168             =cut
169              
170             #- side-effects: those of _write_unrequested_list__file
171             sub _installed_req_and_unreq_and_update_unrequested_list {
172             my ($urpm) = @_;
173              
174             my $pkgs = installed_packages_packed($urpm);
175              
176             $urpm->{debug}("reading and cleaning " . unrequested_list__file($urpm)) if $urpm->{debug};
177             my $unrequested = unrequested_list($urpm);
178             my ($unreq, $req) = partition { $unrequested->{$_->name} } @$pkgs;
179            
180             # update the list (to filter dups and now-removed-pkgs)
181             my @old = keys %$unrequested;
182             my @new = map { $_->name } @$unreq;
183             if (@new != @old) {
184             _write_unrequested_list__file($urpm, \@new);
185             }
186              
187             ($req, $unreq, $unrequested);
188             }
189              
190             =item _selected_unrequested($urpm, $selected, $rejected)
191              
192             Returns the new "unrequested" packages.
193             The reason can be "required by xxx" or "recommended"
194              
195             =cut
196              
197             #- side-effects: none
198             sub _selected_unrequested {
199             my ($urpm, $selected, $rejected) = @_;
200              
201             require urpm::select;
202             map {
203             if (my $from = $selected->{$_}{from}) {
204             my $pkg = $urpm->{depslist}[$_];
205             my $name = $pkg->name;
206             $pkg->flag_requested || urpm::select::was_pkg_name_installed($rejected, $name) ? () :
207             ($name => "(required by " . $from->fullname . ")");
208             } elsif ($selected->{$_}{recommended}) {
209             ($urpm->{depslist}[$_]->name => "(recommended)");
210             } else {
211             ();
212             }
213             } keys %$selected;
214             }
215              
216             =item _renamed_unrequested($urpm, $selected, $rejected)
217              
218             Returns the packages obsoleting packages marked "unrequested"
219              
220             =cut
221              
222             #- side-effects: none
223             sub _renamed_unrequested {
224             my ($urpm, $selected, $rejected) = @_;
225            
226             my @obsoleted = grep { $rejected->{$_}{obsoleted} } keys %$rejected or return;
227              
228             # we have to read the list to know if the old package was marked "unrequested"
229             my $current = unrequested_list($urpm);
230              
231             my %l;
232             foreach my $fn (@obsoleted) {
233             my ($n) = $fn =~ $fullname2name_re;
234             $current->{$n} or next;
235              
236             my ($new_fn) = keys %{$rejected->{$fn}{closure}};
237             my ($new_n) = $new_fn =~ $fullname2name_re;
238              
239             grep { my $pkg = $urpm->{depslist}[$_]; ($pkg->name eq $new_n) && $pkg->flag_installed && $pkg->flag_upgrade } keys %$selected and next;
240             if ($new_n ne $n) {
241             $l{$new_n} = "(obsoletes $fn)";
242             }
243             }
244             %l;
245             }
246              
247             sub new_unrequested {
248             my ($urpm, $state) = @_;
249             (
250             _selected_unrequested($urpm, $state->{selected}, $state->{rejected}),
251             _renamed_unrequested($urpm, $state->{selected}, $state->{rejected}),
252             );
253             }
254              
255             #- side-effects: /var/lib/rpm/installed-through-deps.list
256             sub add_unrequested {
257             my ($urpm, $state) = @_;
258              
259             my %l = new_unrequested($urpm, $state);
260             append_to_file(unrequested_list__file($urpm), join('', map { "$_\t\t$l{$_}\n" } keys %l));
261             }
262              
263             =item check_unrequested_orphans_after_auto_select($urpm)
264              
265             We don't want to check orphans on every auto-select.
266             We do it only after many packages have been added.
267              
268             Returns whether we should look for orphans depending on a threshold.
269              
270             =cut
271              
272             #- side-effects: none
273             sub check_unrequested_orphans_after_auto_select {
274             my ($urpm) = @_;
275             my $f = unrequested_list__file($urpm);
276             my $nb_added = wc_l($f) - wc_l("$f.old");
277             $nb_added >= $urpm->{options}{'nb-of-new-unrequested-pkgs-between-auto-select-orphans-check'};
278             }
279              
280              
281             =item unrequested_orphans_after_remove($urpm, $toremove)
282              
283             This function computes whether removing $toremove packages will create
284             unrequested orphans.
285              
286             It does not return the new orphans since "whatrecommends" is not
287             available,
288              
289             If it detects there are new orphans, _all_unrequested_orphans() must
290             be used to have the list of the orphans
291              
292             =cut
293              
294             #- side-effects: none
295             sub unrequested_orphans_after_remove {
296             my ($urpm, $toremove) = @_;
297              
298             my $db = urpm::db_open_or_die_($urpm);
299             my %toremove = map { $_ => 1 } @$toremove;
300             _unrequested_orphans_after_remove_once($urpm, $db, unrequested_list($urpm), \%toremove);
301             }
302              
303             #- side-effects: none
304             sub _unrequested_orphans_after_remove_once {
305             my ($urpm, $db, $unrequested, $toremove) = @_;
306              
307             # first we get the list of requires/recommends that may be unneeded after removing $toremove
308             my @requires;
309             foreach my $fn (keys %$toremove) {
310             my ($n) = $fn =~ $fullname2name_re;
311              
312             $db->traverse_tag('name', [ $n ], sub {
313             my ($p) = @_;
314             $p->fullname eq $fn or return;
315             push @requires, $p->requires, $p->recommends_nosense;
316             });
317             }
318              
319             foreach my $req (uniq(@requires)) {
320             $db->traverse_tag_find('whatprovides', URPM::property2name($req), sub {
321             my ($p) = @_;
322             $toremove->{$p->fullname} and return; # already done
323             $unrequested->{$p->name} or return;
324             $p->provides_overlap($req) or return;
325              
326             # cool, $p is "unrequested" and will potentially be newly unneeded
327             if (_will_package_be_unneeded($urpm, $db, $toremove, $p)) {
328             $urpm->{debug}("installed " . $p->fullname . " can now be removed") if $urpm->{debug};
329             return 1;
330             } else {
331             $urpm->{debug}("installed " . $p->fullname . " can not be removed") if $urpm->{debug};
332             }
333             0;
334             }) and return 1;
335             }
336             0;
337             }
338              
339             =item _will_package_be_unneeded($urpm, $db, $toremove, $pkg)
340              
341             Return true if $pkg will no more be required after removing $toremove
342              
343             nb: it may wrongly return false for complex loops,
344             but will never wrongly return true
345              
346             =cut
347              
348             #- side-effects: none
349             sub _will_package_be_unneeded {
350             my ($urpm, $db, $toremove, $pkg) = @_;
351              
352             my $required_maybe_loop;
353              
354             foreach my $prop ($pkg->provides) {
355             _will_prop_still_be_needed($urpm, $db, $toremove,
356             scalar($pkg->fullname), $prop, \$required_maybe_loop)
357             and return;
358             }
359              
360             if ($required_maybe_loop) {
361             my ($fullname, @provides) = @$required_maybe_loop;
362             $urpm->{debug}("checking whether $fullname is a dependency loop") if $urpm->{debug};
363              
364             # doing it locally, since we may fail (and so we must backtrack this change)
365             my %ignore = %$toremove;
366             $ignore{$pkg->fullname} = 1;
367              
368             foreach my $prop (@provides) {
369             #- nb: here we won't loop.
370             _will_prop_still_be_needed($urpm, $db, \%ignore,
371             $fullname, $prop, \$required_maybe_loop)
372             and return;
373             }
374             }
375             1;
376             }
377              
378             =item _will_prop_still_be_needed($urpm, $db, $toremove, $fullname, $prop, $required_maybe_loop)
379              
380             Return true if $prop will still be required after removing $toremove
381              
382             =cut
383              
384             #- side-effects: none
385             sub _will_prop_still_be_needed {
386             my ($urpm, $db, $toremove, $fullname, $prop, $required_maybe_loop) = @_;
387              
388             my ($prov, $range) = URPM::property2name_range($prop) or return;
389            
390             $db->traverse_tag_find('whatrequires', $prov, sub {
391             my ($p2) = @_;
392             $toremove->{$p2->fullname} and return 0; # this one is going to be removed, skip it
393              
394             foreach ($p2->requires) {
395             my ($pn, $ps) = URPM::property2name_range($_) or next;
396             if ($pn eq $prov && URPM::ranges_overlap($ps, $range)) {
397             #- we found $p2 which requires $prop
398              
399             if ($$required_maybe_loop) {
400             $urpm->{debug}(" installed " . $p2->fullname . " still requires " . $fullname) if $urpm->{debug};
401             return 1;
402             }
403             $urpm->{debug}(" installed " . $p2->fullname . " may still requires " . $fullname) if $urpm->{debug};
404             $$required_maybe_loop = [ scalar $p2->fullname, $p2->provides ];
405             }
406             }
407             0;
408             });
409             }
410              
411             =item _get_current_kernel_package()
412              
413             Return the current kernel's package so that we can filter out current running
414             kernel:
415              
416             =cut
417              
418             sub _get_current_kernel_package() {
419             my $release = (POSIX::uname())[2];
420             # --qf '%{name}' is used in order to provide the right format:
421             -e "/boot/vmlinuz-$release" && ($release, `rpm -qf --qf '%{name}' /boot/vmlinuz-$release`);
422             }
423              
424              
425             =item _kernel_callback ($pkg, $unreq_list)
426              
427             Returns list of kernels
428              
429             _fast_ version w/o looking at all non kernel packages requires on
430             kernels (like "urpmi_find_leaves '^kernel'" would)
431              
432             _all_unrequested_orphans blacklists nearly all kernels b/c of packages
433             like 'ndiswrapper' or 'basesystem' that requires 'kernel'
434              
435             rationale: other packages only require 'kernel' or a sub package we
436             do not care about (eg: kernel-devel, kernel-firmware, kernel-latest)
437             so it's useless to look at them
438              
439             =cut
440              
441             my (@req_by_latest_kernels, %requested_kernels, %kernels);
442             sub _kernel_callback {
443             my ($pkg, $unreq_list) = @_;
444             my $shortname = $pkg->name;
445             my $n = $pkg->fullname;
446              
447             # only consider kernels (and not main 'kernel' package):
448             # but perform a pass on their requires for dkms like packages that require a specific kernel:
449             if ($shortname !~ /^kernel-/) {
450             foreach (grep { /^kernel/ } $pkg->requires_nosense) {
451             $requested_kernels{$_}{$shortname} = $pkg;
452             }
453             return;
454             }
455              
456             # only consider real kernels (and not kernel-doc and the like):
457             return if $shortname =~ /-(?:source|doc|headers|firmware(?:|-extra|-nonfree))$/;
458              
459             # ignore requested kernels (aka that are not in /var/lib/rpm/installed-through-deps.list)
460             return if !$unreq_list->{$shortname} && $shortname !~ /latest/;
461              
462             # keep track of packages required by latest kernels in order not to try removing requested kernels:
463             if ($n =~ /latest/) {
464             push @req_by_latest_kernels, $pkg->requires;
465             } else {
466             $kernels{$shortname} = $pkg;
467             }
468             }
469              
470              
471             =item _get_orphan_kernels()
472              
473             Returns list of orphan kernels
474              
475             =cut
476              
477             sub _get_orphan_kernels() {
478             # keep kernels required by kernel-*-latest:
479             delete $kernels{$_} foreach @req_by_latest_kernels;
480             # return list of unused/orphan kernels:
481             \%kernels;
482             }
483              
484              
485             =item _all_unrequested_orphans($urpm, $req, $unreq)
486              
487             Returns the list of "unrequested" orphans.
488              
489             =cut
490              
491             #- side-effects: none
492             sub _all_unrequested_orphans {
493             my ($urpm, $req, $unreq) = @_;
494              
495             my (%l, %provides);
496             # 1- list explicit provides (not files) from installed packages:
497             foreach my $pkg (@$unreq) {
498             $l{$pkg->name} = $pkg;
499             push @{$provides{$_}}, $pkg foreach $pkg->provides_nosense;
500             }
501             my $unreq_list = unrequested_list($urpm);
502              
503             my ($current_kernel_version, $current_kernel) = _get_current_kernel_package();
504              
505             # 2- check if "unrequested" packages are still needed:
506             while (my $pkg = shift @$req) {
507             # do not do anything regarding kernels if we failed to detect the running one (ie: chroot)
508             _kernel_callback($pkg, $unreq_list) if $current_kernel;
509             foreach my $prop ($pkg->requires, $pkg->recommends_nosense) {
510             my $n = URPM::property2name($prop);
511             foreach my $p (@{$provides{$n} || []}) {
512             if ($p != $pkg && $l{$p->name} && $p->provides_overlap($prop)) {
513             delete $l{$p->name};
514             push @$req, $p;
515             }
516             }
517             }
518             }
519              
520             # add orphan kernels to the list:
521             my $a = _get_orphan_kernels();
522             add2hash_(\%l, $a);
523              
524             # add packages that require orphan kernels to the list:
525             foreach (keys %$a) {
526             add2hash_(\%l, $requested_kernels{$_});
527             }
528              
529             # do not offer to remove current kernel or DKMS modules for current kernel:
530             delete $l{$current_kernel};
531             # prevent removing orphan kernels if we failed to detect running kernel version:
532             if ($current_kernel_version) {
533             do { delete $l{$_} } foreach grep { /$current_kernel_version/ } keys %l;
534             }
535              
536             [ values %l ];
537             }
538              
539             =item compute_future_unrequested_orphans($urpm, $state)
540              
541             Compute the list of packages that will be unrequested and
542             could potently be removed.
543              
544             =cut
545              
546             #- side-effects: $state->{orphans_to_remove}
547             #- + those of _installed_and_unrequested_lists (/var/lib/rpm/installed-through-deps.list)
548             sub compute_future_unrequested_orphans {
549             my ($urpm, $state) = @_;
550              
551             $urpm->{log}("computing unrequested orphans");
552              
553             my ($current_pkgs, $unrequested) = _installed_and_unrequested_lists($urpm);
554              
555             put_in_hash($unrequested, { new_unrequested($urpm, $state) });
556              
557             my %toremove = map { $_ => 1 } URPM::removed_or_obsoleted_packages($state);
558             my @pkgs = grep { !$toremove{$_->fullname} } @$current_pkgs;
559             push @pkgs, map { $urpm->{depslist}[$_] } keys %{$state->{selected} || {}};
560              
561             my ($unreq, $req) = partition { $unrequested->{$_->name} } @pkgs;
562              
563             $state->{orphans_to_remove} = _all_unrequested_orphans($urpm, $req, $unreq);
564              
565             # nb: $state->{orphans_to_remove} is used when computing ->selected_size
566             }
567              
568              
569             =item get_orphans($urpm)
570              
571             Returns the list of unrequested packages (aka orphans).
572              
573             It is quite fast. the slow part is the creation of
574             $installed_packages_packed (using installed_packages_packed())
575              
576             =cut
577              
578             #
579             #- side-effects:
580             #- + those of _installed_req_and_unreq (/var/lib/rpm/installed-through-deps.list)
581             sub get_orphans {
582             my ($urpm) = @_;
583              
584             $urpm->{log}("computing unrequested orphans");
585              
586             my ($req, $unreq) = _installed_req_and_unreq($urpm);
587             _all_unrequested_orphans($urpm, $req, $unreq);
588             }
589              
590             sub _get_now_orphans_raw_msg {
591             my ($urpm) = @_;
592              
593             my $orphans = get_orphans($urpm);
594             my @orphans = map { scalar $_->fullname } @$orphans or return;
595              
596             (scalar(@orphans), add_leading_spaces(join("\n", sort @orphans)));
597             }
598              
599             =item get_now_orphans_gui_msg($urpm)
600              
601             Like get_now_orphans_msg() but more suited for GUIes, it return
602             message about orphan packages.
603              
604             Used by rpmdrake.
605              
606             =cut
607              
608             sub get_now_orphans_gui_msg {
609             my ($urpm) = @_;
610              
611             my ($count, $list) = _get_now_orphans_raw_msg($urpm) or return;
612             join("\n",
613             P("The following package:\n%s\nis now orphaned.",
614             "The following packages:\n%s\nare now orphaned.", $count, $list),
615             undef,
616             P("You may wish to remove it.",
617             "You may wish to remove them.", $count)
618             );
619             }
620              
621              
622             =item get_now_orphans_msg($urpm)
623              
624             Similar to get_now_orphans_gui_msg() but more suited for CLI, it
625             return message about orphan packages.
626              
627             =cut
628              
629             sub get_now_orphans_msg {
630             my ($urpm) = @_;
631              
632             my ($count, $list) = _get_now_orphans_raw_msg($urpm) or return;
633             P("The following package:\n%s\nis now orphaned, if you wish to remove it, you can use \"urpme --auto-orphans\"",
634             "The following packages:\n%s\nare now orphaned, if you wish to remove them, you can use \"urpme --auto-orphans\"",
635             $count, $list) . "\n";
636             }
637              
638              
639             =item add_leading_spaces($string)
640              
641             Add leading spaces to the string and return it.
642              
643             =cut
644              
645             #- side-effects: none
646             sub add_leading_spaces {
647             my ($s) = @_;
648             $s =~ s/^/ /gm;
649             $s;
650             }
651              
652             #- side-effects: none
653             sub installed_leaves {
654             my ($urpm, $o_discard) = @_;
655              
656             my $packages = installed_packages_packed($urpm);
657              
658             my (%l, %provides);
659             foreach my $pkg (@$packages) {
660             next if $o_discard && $o_discard->($pkg);
661             $l{$pkg->name} = $pkg;
662             push @{$provides{$_}}, $pkg foreach $pkg->provides_nosense;
663             }
664              
665             foreach my $pkg (@$packages) {
666             foreach my $prop ($pkg->requires, $pkg->recommends_nosense) {
667             my $n = URPM::property2name($prop);
668             foreach my $p (@{$provides{$n} || []}) {
669             $p != $pkg && $p->provides_overlap($prop) and
670             delete $l{$p->name};
671             }
672             }
673             }
674              
675             [ values %l ];
676             }
677              
678             1;
679              
680              
681             =back
682              
683             =head1 COPYRIGHT
684              
685              
686             Copyright (C) 2008-2010 Mandriva SA
687              
688             Copyright (C) 2011-2017 Mageia
689              
690             =cut