summaryrefslogtreecommitdiffstats
path: root/urpm/orphans.pm
blob: e1d900a61ec4ab81647d519097c423ddb35f1c2f (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
package urpm::orphans;

use strict;
use urpm::util qw(add2hash_ append_to_file cat_ output_safe partition put_in_hash uniq wc_l);
use urpm::msg;
use urpm;


my $fullname2name_re = qr/^(.*)-[^\-]*-[^\-]*\.[^\.\-]*$/;


=head1 NAME

urpm::orphans - The orphan management code for urpmi

=head1 SYNOPSIS

=head1 DESCRIPTION

=over

=cut

#- side-effects: none
sub installed_packages_packed {
    my ($urpm) = @_;

    my $db = urpm::db_open_or_die_($urpm);
    my @l;
    $db->traverse(sub {
        my ($pkg) = @_;
	$pkg->pack_header;
	push @l, $pkg;
    });
    \@l;
}


=item unrequested_list__file($urpm)

Return the path of the unrequested list file.

=cut

#- side-effects: none
sub unrequested_list__file {
    my ($urpm) = @_;
    ($urpm->{env_dir} || "$urpm->{root}/var/lib/rpm") . '/installed-through-deps.list';
}

=item unrequested_list($urpm)

Returns the list of potentiel files (ake files installed as requires for others)

=cut

#- side-effects: none
sub unrequested_list {
    my ($urpm) = @_;
    +{ map { 
	chomp; 
	s/\s+\(.*\)$//; 
	$_ => 1;
    } cat_(unrequested_list__file($urpm)) };
}

=item mark_as_requested($urpm, $state, $test)

Mark some packages as explicitly requested (usually because
they were manually installed).

=cut

#- side-effects: those of _write_unrequested_list__file
sub mark_as_requested {
    my ($urpm, $state, $test) = @_;
    my $unrequested = unrequested_list($urpm);
    my $dirty;

    foreach (keys %{$state->{rejected_already_installed}}, 
	     grep { $state->{selected}{$_}{requested} } keys %{$state->{selected}}) {
	my $name = $urpm->{depslist}[$_]->name;
	if (defined($unrequested->{$name})) {
	    $urpm->{info}(N("Marking %s as manually installed, it won't be auto-orphaned", $name));
	    $dirty = 1;
	} else {
	    $urpm->{debug}("$name is not in potential orphans") if $urpm->{debug};
	}
	delete $unrequested->{$name};
    }

    if ($dirty && !$test) {
	_write_unrequested_list__file($urpm, [keys %$unrequested]);
    }
}

=item _installed_req_and_unreq($urpm)

Returns :

=over

=item * req: list of installed packages that were installed as requires of others 

=item * unreq: list of installed packages that were not installed as requres of others (ie the ones that were explicitely selected for install)

=back

=cut

#- side-effects:
#-   + those of _installed_req_and_unreq_and_update_unrequested_list (<root>/var/lib/rpm/installed-through-deps.list)
sub _installed_req_and_unreq {
    my ($urpm) = @_;
    my ($req, $unreq, $_unrequested) = _installed_req_and_unreq_and_update_unrequested_list($urpm);
    ($req, $unreq);
}

=item _installed_and_unrequested_lists($urpm)

Returns :

=over

=item * pkgs: list of installed packages

=item * unrequested: list of packages that were installed as requires of others (the sum of the previous lists)

=back

=cut

#- side-effects:
#-   + those of _installed_req_and_unreq_and_update_unrequested_list (<root>/var/lib/rpm/installed-through-deps.list)
sub _installed_and_unrequested_lists {
    my ($urpm) = @_;
    my ($pkgs, $pkgs2, $unrequested) = _installed_req_and_unreq_and_update_unrequested_list($urpm);
    push @$pkgs, @$pkgs2;
    ($pkgs, $unrequested);
}

#- side-effects: <root>/var/lib/rpm/installed-through-deps.list
sub _write_unrequested_list__file {
    my ($urpm, $unreq) = @_;
    return if $>;

    $urpm->{info}("writing " . unrequested_list__file($urpm));
    
    output_safe(unrequested_list__file($urpm), 
		join('', sort map { $_ . "\n" } @$unreq),
		".old") if !$urpm->{env_dir};
}

=item _installed_req_and_unreq_and_update_unrequested_list ($urpm)

Returns :

=over

=item * req: list of installed packages that were installed as requires of others 

=item * unreq: list of installed packages that were not installed as requres of others (ie the ones that were explicitely selected for install)

=item * unrequested: list of packages that were installed as requires of others (the sum of the previous lists)

=back

=cut

#- side-effects: those of _write_unrequested_list__file
sub _installed_req_and_unreq_and_update_unrequested_list {
    my ($urpm) = @_;

    my $pkgs = installed_packages_packed($urpm);

    $urpm->{debug}("reading and cleaning " . unrequested_list__file($urpm)) if $urpm->{debug};
    my $unrequested = unrequested_list($urpm);
    my ($unreq, $req) = partition { $unrequested->{$_->name} } @$pkgs;
    
    # update the list (to filter dups and now-removed-pkgs)
    my @old = keys %$unrequested;
    my @new = map { $_->name } @$unreq;
    if (@new != @old) {
        _write_unrequested_list__file($urpm, \@new);
    }

    ($req, $unreq, $unrequested);
}

=item _selected_unrequested($urpm, $selected, $rejected)

Returns the new "unrequested" packages.
The reason can be "required by xxx" or "recommended"

=cut

#- side-effects: none
sub _selected_unrequested {
    my ($urpm, $selected, $rejected) = @_;

    require urpm::select;
    map {
	if (my $from = $selected->{$_}{from}) {
	    my $pkg = $urpm->{depslist}[$_];
	    my $name = $pkg->name;
	    $pkg->flag_requested || urpm::select::was_pkg_name_installed($rejected, $name) ? () : 
		($name => "(required by " . $from->fullname . ")");
	} elsif ($selected->{$_}{recommended}) {
	    ($urpm->{depslist}[$_]->name => "(recommended)");
	} else {
	    ();
	}
    } keys %$selected;
}

=item _renamed_unrequested($urpm, $selected, $rejected)

Returns the packages obsoleting packages marked "unrequested"

=cut

#- side-effects: none
sub _renamed_unrequested {
    my ($urpm, $selected, $rejected) = @_;
    
    my @obsoleted = grep { $rejected->{$_}{obsoleted} } keys %$rejected or return;

    # we have to read the list to know if the old package was marked "unrequested"
    my $current = unrequested_list($urpm);

    my %l;
    foreach my $fn (@obsoleted) {
	my ($n) = $fn =~ $fullname2name_re;
	$current->{$n} or next;

	my ($new_fn) = keys %{$rejected->{$fn}{closure}};
	my ($new_n) = $new_fn =~ $fullname2name_re;

	grep { my $pkg = $urpm->{depslist}[$_]; ($pkg->name eq $new_n) && $pkg->flag_installed && $pkg->flag_upgrade } keys %$selected and next;
	if ($new_n ne $n) {
	    $l{$new_n} = "(obsoletes $fn)";
	}
    }
    %l;
}

sub new_unrequested {
    my ($urpm, $state) = @_;
    (
	_selected_unrequested($urpm, $state->{selected}, $state->{rejected}),
	_renamed_unrequested($urpm, $state->{selected}, $state->{rejected}),
    );
}

#- side-effects: <root>/var/lib/rpm/installed-through-deps.list
sub add_unrequested {
    my ($urpm, $state) = @_;

    my %l = new_unrequested($urpm, $state);
    append_to_file(unrequested_list__file($urpm), join('', map { "$_\t\t$l{$_}\n" } keys %l));
}

=item check_unrequested_orphans_after_auto_select($urpm)

We don't want to check orphans on every auto-select.
We do it only after many packages have been added.

Returns whether we should look for orphans depending on a threshold.

=cut

#- side-effects: none
sub check_unrequested_orphans_after_auto_select {
    my ($urpm) = @_;
    my $f = unrequested_list__file($urpm);
    my $nb_added = wc_l($f) - wc_l("$f.old");
    $nb_added >= $urpm->{options}{'nb-of-new-unrequested-pkgs-between-auto-select-orphans-check'};
}


=item unrequested_orphans_after_remove($urpm, $toremove)

This function computes whether removing $toremove packages will create
unrequested orphans.

It does not return the new orphans since "whatrecommends" is not
available,

If it detects there are new orphans, _all_unrequested_orphans() must
be used to have the list of the orphans

=cut

#- side-effects: none
sub unrequested_orphans_after_remove {
    my ($urpm, $toremove) = @_;

    my $db = urpm::db_open_or_die_($urpm);
    my %toremove = map { $_ => 1 } @$toremove;
    _unrequested_orphans_after_remove_once($urpm, $db, unrequested_list($urpm), \%toremove);
}

#- side-effects: none
sub _unrequested_orphans_after_remove_once {
    my ($urpm, $db, $unrequested, $toremove) = @_;

    # first we get the list of requires/recommends that may be unneeded after removing $toremove
    my @requires;
    foreach my $fn (keys %$toremove) {
	my ($n) = $fn =~ $fullname2name_re;

	$db->traverse_tag('name', [ $n ], sub {
	    my ($p) = @_;
	    $p->fullname eq $fn or return;
	    push @requires, $p->requires, $p->recommends_nosense;
	});
    }

    foreach my $req (uniq(@requires)) {
	$db->traverse_tag_find('whatprovides', URPM::property2name($req), sub {
            my ($p) = @_;
	    $toremove->{$p->fullname} and return; # already done
	    $unrequested->{$p->name} or return;
	    $p->provides_overlap($req) or return;

	    # cool, $p is "unrequested" and will potentially be newly unneeded
	    if (_will_package_be_unneeded($urpm, $db, $toremove, $p)) {
		$urpm->{debug}("installed " . $p->fullname . " can now be removed") if $urpm->{debug};
		return 1;
	    } else {
		$urpm->{debug}("installed " . $p->fullname . " can not be removed") if $urpm->{debug};
	    }
	    0;
	}) and return 1;
    }
    0;
}

=item _will_package_be_unneeded($urpm, $db, $toremove, $pkg)

Return true if $pkg will no more be required after removing $toremove

nb: it may wrongly return false for complex loops,
but will never wrongly return true

=cut

#- side-effects: none
sub _will_package_be_unneeded {
    my ($urpm, $db, $toremove, $pkg) = @_;

    my $required_maybe_loop;

    foreach my $prop ($pkg->provides) {
	_will_prop_still_be_needed($urpm, $db, $toremove, 
				   scalar($pkg->fullname), $prop, \$required_maybe_loop)
	  and return;	
    }

    if ($required_maybe_loop) {
	my ($fullname, @provides) = @$required_maybe_loop;
	$urpm->{debug}("checking whether $fullname is a dependency loop") if $urpm->{debug};

	# doing it locally, since we may fail (and so we must backtrack this change)
	my %ignore = %$toremove;
	$ignore{$pkg->fullname} = 1;

	foreach my $prop (@provides) {
	    #- nb: here we won't loop.
	    _will_prop_still_be_needed($urpm, $db, \%ignore, 
				       $fullname, $prop, \$required_maybe_loop)
	      and return;
	}
    }
    1;
}

=item _will_prop_still_be_needed($urpm, $db, $toremove, $fullname, $prop, $required_maybe_loop)

Return true if $prop will still be required after removing $toremove

=cut

#- side-effects: none
sub _will_prop_still_be_needed {
    my ($urpm, $db, $toremove, $fullname, $prop, $required_maybe_loop) = @_;

    my ($prov, $range) = URPM::property2name_range($prop) or return;
    
    $db->traverse_tag_find('whatrequires', $prov, sub {
	my ($p2) = @_;
	$toremove->{$p2->fullname} and return 0; # this one is going to be removed, skip it

	foreach ($p2->requires) {
	    my ($pn, $ps) = URPM::property2name_range($_) or next;
	    if ($pn eq $prov && URPM::ranges_overlap($ps, $range)) {
		#- we found $p2 which requires $prop

		if ($$required_maybe_loop) {
		    $urpm->{debug}("  installed " . $p2->fullname . " still requires " . $fullname) if $urpm->{debug};
		    return 1;
		}
		$urpm->{debug}("  installed " . $p2->fullname . " may still requires " . $fullname) if $urpm->{debug};
		$$required_maybe_loop = [ scalar $p2->fullname, $p2->provides ];
	    }
	}
	0;
    });
}

=item _get_current_kernel_package()

Return the current kernel's package so that we can filter out current running
kernel:

=cut

sub _get_current_kernel_package() {
    my $release = (POSIX::uname())[2];
    # --qf '%{name}' is used in order to provide the right format:
    -e "/boot/vmlinuz-$release" && ($release, `rpm -qf --qf '%{name}' /boot/vmlinuz-$release`);
}


=item _kernel_callback ($pkg, $unreq_list)

Returns list of kernels

_fast_ version w/o looking at all non kernel packages requires on
kernels (like "urpmi_find_leaves '^kernel'" would)

_all_unrequested_orphans blacklists nearly all kernels b/c of packages
like 'ndiswrapper' or 'basesystem' that requires 'kernel'

rationale: other packages only require 'kernel' or a sub package we
do not care about (eg: kernel-devel, kernel-firmware, kernel-latest)
so it's useless to look at them

=cut

my (@req_by_latest_kernels, %requested_kernels, %kernels);
sub _kernel_callback { 
    my ($pkg, $unreq_list) = @_;
    my $shortname = $pkg->name;
    my $n = $pkg->fullname;

    # only consider kernels (and not main 'kernel' package):
    # but perform a pass on their requires for dkms like packages that require a specific kernel:
    if ($shortname !~ /^kernel-/) {
	foreach (grep { /^kernel/ } $pkg->requires_nosense) {
	    $requested_kernels{$_}{$shortname} = $pkg;
	}
	return;
    }

    # only consider real kernels (and not kernel-doc and the like):
    return if $shortname =~ /-(?:source|doc|headers|firmware(?:|-extra|-nonfree))$/;

    # ignore requested kernels (aka that are not in /var/lib/rpm/installed-through-deps.list)
    return if !$unreq_list->{$shortname} && $shortname !~ /latest/;

    # keep track of packages required by latest kernels in order not to try removing requested kernels:
    if ($n =~ /latest/) {
        push @req_by_latest_kernels, $pkg->requires;
    } else {
        $kernels{$shortname} = $pkg;
    }
}


=item _get_orphan_kernels()

Returns list of orphan kernels

=cut

sub _get_orphan_kernels() {
    # keep kernels required by kernel-*-latest:
    delete $kernels{$_} foreach @req_by_latest_kernels;
    # return list of unused/orphan kernels:
    \%kernels;
}


=item _all_unrequested_orphans($urpm, $req, $unreq)

Returns the list of "unrequested" orphans.

=cut

#- side-effects: none
sub _all_unrequested_orphans {
    my ($urpm, $req, $unreq) = @_;

    my (%l, %provides);
    # 1- list explicit provides (not files) from installed packages:
    foreach my $pkg (@$unreq) {
	$l{$pkg->name} = $pkg;
	push @{$provides{$_}}, $pkg foreach $pkg->provides_nosense;
    }
    my $unreq_list = unrequested_list($urpm);

    my ($current_kernel_version, $current_kernel) = _get_current_kernel_package();

    # 2- check if "unrequested" packages are still needed:
    while (my $pkg = shift @$req) {
        # do not do anything regarding kernels if we failed to detect the running one (ie: chroot)
 	_kernel_callback($pkg, $unreq_list) if $current_kernel;
	foreach my $prop ($pkg->requires, $pkg->recommends_nosense) {
	    my $n = URPM::property2name($prop);
	    foreach my $p (@{$provides{$n} || []}) {
		if ($p != $pkg && $l{$p->name} && $p->provides_overlap($prop)) {
		    delete $l{$p->name};
		    push @$req, $p;
		}
	    }
	}
    }

    # add orphan kernels to the list:
    my $a = _get_orphan_kernels();
    add2hash_(\%l, $a);

    # add packages that require orphan kernels to the list:
    foreach (keys %$a) {
	add2hash_(\%l, $requested_kernels{$_});
    }

    # do not offer to remove current kernel or DKMS modules for current kernel:
    delete $l{$current_kernel};
    # prevent removing orphan kernels if we failed to detect running kernel version:
    if ($current_kernel_version) {
        do { delete $l{$_} } foreach grep { /$current_kernel_version/ } keys %l;
    }

    [ values %l ];
}

=item compute_future_unrequested_orphans($urpm, $state)

Compute the list of packages that will be unrequested and
could potently be removed.

=cut

#- side-effects: $state->{orphans_to_remove}
#-   + those of _installed_and_unrequested_lists (<root>/var/lib/rpm/installed-through-deps.list)
sub compute_future_unrequested_orphans {
    my ($urpm, $state) = @_;

    $urpm->{log}("computing unrequested orphans");

    my ($current_pkgs, $unrequested) = _installed_and_unrequested_lists($urpm);

    put_in_hash($unrequested, { new_unrequested($urpm, $state) });

    my %toremove = map { $_ => 1 } URPM::removed_or_obsoleted_packages($state);
    my @pkgs = grep { !$toremove{$_->fullname} } @$current_pkgs;
    push @pkgs, map { $urpm->{depslist}[$_] } keys %{$state->{selected} || {}};

    my ($unreq, $req) = partition { $unrequested->{$_->name} } @pkgs;

    $state->{orphans_to_remove} = _all_unrequested_orphans($urpm, $req, $unreq);

    # nb: $state->{orphans_to_remove} is used when computing ->selected_size
}


=item get_orphans($urpm)

Returns the list of unrequested packages (aka orphans).

It is quite fast. the slow part is the creation of
$installed_packages_packed (using installed_packages_packed())

Used by C<urpmq --auto_orphans>

=cut

#
#- side-effects:
#-   + those of _installed_req_and_unreq (<root>/var/lib/rpm/installed-through-deps.list)
sub get_orphans {
    my ($urpm) = @_;

    $urpm->{log}("computing unrequested orphans");

    my ($req, $unreq) = _installed_req_and_unreq($urpm);
    _all_unrequested_orphans($urpm, $req, $unreq);
}

sub _get_now_orphans_raw_msg {
    my ($urpm) = @_;

    my $orphans = get_orphans($urpm);
    my @orphans = map { scalar $_->fullname } @$orphans or return;

    (scalar(@orphans), add_leading_spaces(join("\n", sort @orphans)));
}

=item get_now_orphans_gui_msg($urpm)

Like get_now_orphans_msg() but more suited for GUIes, it return
message about orphan packages.

Used by rpmdrake.

=cut

sub get_now_orphans_gui_msg {
    my ($urpm) = @_;

    my ($count, $list) = _get_now_orphans_raw_msg($urpm) or return;
    join("\n",
       P("The following package:\n%s\nis now orphaned.",
         "The following packages:\n%s\nare now orphaned.", $count, $list),
        undef,
	P("You may wish to remove it.",
	  "You may wish to remove them.", $count)
    );
}


=item get_now_orphans_msg($urpm)

Similar to get_now_orphans_gui_msg() but more suited for CLI, it
return message about orphan packages.

=cut

sub get_now_orphans_msg {
    my ($urpm) = @_;

    my ($count, $list) = _get_now_orphans_raw_msg($urpm) or return;
    P("The following package:\n%s\nis now orphaned, if you wish to remove it, you can use \"urpme --auto-orphans\"",
      "The following packages:\n%s\nare now orphaned, if you wish to remove them, you can use \"urpme --auto-orphans\"",
      $count, $list) . "\n";
}


=item add_leading_spaces($string)

Add leading spaces to the string and return it.

=cut

#- side-effects: none
sub add_leading_spaces {
    my ($s) = @_;
    $s =~ s/^/  /gm;
    $s;
}

#- side-effects: none
sub installed_leaves {
    my ($urpm, $o_discard) = @_;

    my $packages = installed_packages_packed($urpm);

    my (%l, %provides);
    foreach my $pkg (@$packages) {
	next if $o_discard && $o_discard->($pkg);
	$l{$pkg->name} = $pkg;
	push @{$provides{$_}}, $pkg foreach $pkg->provides_nosense;
    }

    foreach my $pkg (@$packages) {
	foreach my $prop ($pkg->requires, $pkg->recommends_nosense) {
	    my $n = URPM::property2name($prop);
	    foreach my $p (@{$provides{$n} || []}) {
		$p != $pkg && $p->provides_overlap($prop) and 
		  delete $l{$p->name};
	    }
	}
    }

    [ values %l ];
}

1;


=back

=head1 COPYRIGHT


Copyright (C) 2008-2010 Mandriva SA

Copyright (C) 2011-2020 Mageia

=cut