src/update.pl

#!/usr/bin/env perl
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use mplib::config qw($CFG);
use mplib::util qw(fail note confirm split_slot_key spin_start spin_tick spin_stop);
use mplib::db qw(read_db read_lines);
use mplib::resolve qw(init sync_ports expand_meta find_portdir try_pkgconf effective_deps
    resolve_dep_name resolved_db_key reinstall_pkg held_reason subslot_changed_targets);
 
my $flags = mplib::config::parse_flags(\@ARGV);
mplib::config::load($flags);
init();
 
my $db = read_db();
sync_ports();
exit 0 unless @ARGV;
# captured before expand_meta below: the raw target names (e.g. "world",
# or an explicit package list), not what they expand to -- @-set/world
# membership can shift between runs (an unrelated install/remove) but
# the REQUEST is still "the same one", so --resume should still trust a
# leftover progress file keyed on this rather than refusing to resume
# over a membership change that isn't actually relevant here.
my $request_sig = join(' ', sort @ARGV);
my @names = map { expand_meta($_, $db) } @ARGV;
 
my %todo;
for my $name (@names)
{
	# resolved_db_key (not a plain bare_name lookup): a slotted package
	# named bare on the command line -- or a bare dep token resolving to
	# one below -- needs the same "falls back to whichever slot is
	# actually installed" resolution mp remove already gets, or it's
	# silently dropped here (a bare $db->{$canon} lookup never matches a
	# "name:slot" db key).
	my $canon = resolved_db_key($name, $db);
	$todo{$canon} = 1 if defined $canon;
}
exit 0 unless %todo;
 
# subslot-triggered rebuild cascade ("@dep" in pkg_deps=, mplib::resolve's
# own record_subslot_dep/subslot_changed_targets): every package whose
# tracked dependency's subslot no longer matches what it was last built
# against joins the update set too, even if the user didn't explicitly
# name it -- Portage's own ":=" slot operator, in spirit. only applied
# once %todo already has something real in it from the user's own
# request (a request that resolves to nothing shouldn't silently start
# rebuilding unrelated packages on its own); a "world" update already
# includes everything a cascade could possibly add, so this only
# actually changes anything for a narrower, explicit request.
for my $canon (subslot_changed_targets($db))
{
	$todo{$canon} = 1;
}
 
# build direct dependency edges among the update set so a package is only
# rebuilt after everything it needs (regardless of category) is rebuilt.
# a %tag dep counts only once it has been resolved onto an in-set port;
# providers not being updated stay present, so they impose no ordering.
#
# two passes: hard deps first (unconditionally - these must never be
# violated), then soft deps (effective_deps' own "?"-prefixed marker),
# each added only if it doesn't close a cycle back through hard/already-
# accepted-soft edges. a soft dep never blocks at install time
# (resolve_dep leaves it unresolved rather than dying - see
# effective_deps' own comment), so it's still just a best-effort
# ordering hint, not something worth aborting the whole batch update
# over - but dropping EVERY soft edge outright (rather than only the
# ones that would actually cycle) throws away real, useful ordering for
# every OTHER pair that doesn't conflict: busybox's own soft dep on
# linux-headers, for instance, never cycles with anything, and losing
# that ordering meant busybox could get rebuilt before linux-headers in
# the very same batch, with no kernel headers yet in place for its own
# console-tools/capability code to compile against.
my (%deps, %rev, %ind, @softcand);
spin_start("resolving dependencies...");
for my $p (keys %todo)
{
	spin_tick();
	my ($base, $slot) = split_slot_key($p);
	my $dir = find_portdir($base, $slot);
	my $pc  = $dir ? try_pkgconf($dir) : undef;
	next unless $pc;
	for my $d (effective_deps($pc, $p))
	{
		my $is_soft = ($d =~ /^\?/);
		my $t = resolve_dep_name($d, $p, $db);
		next unless defined $t;
		# same resolved_db_key normalization as $todo's own keys above,
		# so a dependency resolving to "prov:sX" correctly matches an
		# in-set "prov" (or "prov:sX") entry instead of silently
		# missing the edge (bare_name alone never strips a slot, so it
		# can't recognize the two as the same package).
		my $key = resolved_db_key($t, $db);
		next unless defined $key && $todo{$key};
		if($is_soft)
		{
			push @softcand, [$p, $key];
			next;
		}
		push @{$deps{$p}}, $key;
		push @{$rev{$key}}, $p;
	}
}
# true if $to is reachable from $from by following already-accepted
# edges forward (i.e. $from directly or transitively depends on $to) -
# used below to check whether accepting one more edge, $p -> $key,
# would close a cycle: that's exactly the case where $key can already
# reach $p.
my $reachable = sub {
	my ($from, $to) = @_;
	my %seen;
	my @stack = ($from);
	while(@stack)
	{
		my $n = pop @stack;
		return 1 if $n eq $to;
		next if $seen{$n}++;
		push @stack, @{$deps{$n} || []};
	}
	return 0;
};
for my $edge (@softcand)
{
	my ($p, $key) = @$edge;
	next if $reachable->($key, $p);
	push @{$deps{$p}}, $key;
	push @{$rev{$key}}, $p;
}
for my $p (keys %todo)
{
	$ind{$p} = scalar(@{$deps{$p} || []});
}
spin_stop();
 
# --resume picks up a batch a previous "mp update" invocation never
# finished -- a hard failure partway through (a real build error, which
# fail() turns into an immediate exit(), not something caught and
# handled here) otherwise means every package that already succeeded
# gets rebuilt AGAIN from scratch on retry, even though nothing about
# them changed in the meantime. real cost, not hypothetical: this
# session's own static-pie rebuild hit the same class of per-port
# incompatibility (a build-time-baked prefix breaking once its
# ephemeral --inplace scratch dir was cleaned up) five separate times,
# and every retry re-rebuilt a dozen already-good packages -- tens of
# minutes and tens of thousands of log lines each time -- before ever
# reaching the actually-new failure.
#
# progress_file records, one per line: the request signature first
# (so a --resume against a DIFFERENT target list doesn't silently
# trust unrelated leftover state), then one canon per completed
# package (reinstalled OR held-skipped -- both are "nothing left to do
# here" from a resume's perspective), appended as each finishes. a
# full, successful run deletes it on the way out: nothing left to
# resume once everything actually succeeded, and a stale file from a
# fully-completed run has no business surviving to confuse some later,
# unrelated --resume.
my $progress_file = "$CFG->{WD}/update-progress";
my %done;
if($CFG->{RESUME} && -f $progress_file)
{
	my @lines = read_lines($progress_file);
	my $saved_sig = shift @lines;
	if(defined $saved_sig && $saved_sig eq $request_sig)
	{
		$done{$_} = 1 for @lines;
		my $n = scalar @lines;
		note("resuming: $n already done this batch, skipping") if $n;
	}
	else
	{
		note("--resume: leftover progress file is for a different request, starting fresh");
	}
}
{
	my $fh;
	open($fh, '>', $progress_file) or fail("cannot write $progress_file: $!");
	print $fh "$request_sig\n";
	print $fh "$_\n" for sort keys %done;
	close($fh);
}
# already-done entries still need their outgoing edges honored (a
# resumed package's own dependents must still wait for it) -- easiest
# expressed as removing them from $ind{} accounting entirely, same as
# the main loop's own "$ind{$q}-- if !$done{$q}" would do for each one
# if it went through the loop normally instead of being skipped here.
for my $p (keys %done)
{
	next unless $todo{$p};
	for my $q (@{$rev{$p} || []})
	{
		$ind{$q}-- if !$done{$q};
	}
}
my $left = scalar(grep { !$done{$_} } keys %todo);
if(!$left)
{
	unlink($progress_file);
	exit 0;
}
confirm("update: " . join(' ', sort grep { !$done{$_} } keys %todo) . " -- continue?");
 
# rebuild in dependency order, one package at a time: on each pass pick
# the first package whose in-set deps are all rebuilt (ready), reinstall
# it, then mark it done and free anything that depends on it. rebuilds
# are serial because each reinstall diffs the shared install prefix
# (snapshot before/after) to learn what files it owns; running two at
# once would let the concurrent install pollute the other's file list,
# making packages claim foreign files and report false "conflicts with
# X on installed files".
while($left)
{
	my @ready = grep { !$done{$_} && $ind{$_} == 0 } keys %todo;
	fail("update dependency cycle among: " . join(' ', sort grep { !$done{$_} } keys %todo))
		unless @ready;
 
	my $p = (sort @ready)[0];
	my $cdb = read_db();
	# a held package (mp hold) is a deliberate, permanent skip, not a
	# failure -- reinstall_pkg's own held_reason check would otherwise
	# call fail(), which exit()s the WHOLE process (reinstall_pkg is
	# never called under try_soft here, unlike a soft dep elsewhere in
	# this codebase), aborting every OTHER package still queued behind
	# it in topological order. checking first and skipping with a note
	# keeps a real build failure just as loud (and just as fatal) as
	# before -- only the well-defined "held" case is treated specially.
	if(my $why = held_reason($p))
	{
		note("$p not updated: $why");
	}
	else
	{
		reinstall_pkg($p, $cdb);
	}
	# appended immediately, not batched until the end: a hard failure on
	# some LATER package calls fail(), which exit()s the process right
	# there -- anything not already flushed to disk by that point would
	# never make it into the progress file at all, defeating the entire
	# point of --resume being able to skip $p next time.
	{
		my $fh;
		open($fh, '>>', $progress_file) or fail("cannot write $progress_file: $!");
		print $fh "$p\n";
		close($fh);
	}
	$done{$p} = 1;
	$left--;
	for my $q (@{$rev{$p} || []})
	{
		$ind{$q}-- if !$done{$q};
	}
}
unlink($progress_file);