src/mplib/db.pm

use v5.16;
package mplib::db;
use strict;
use warnings FATAL => 'all';
use Fcntl qw(:flock);
use Exporter 'import';
use mplib::config qw($CFG);
use mplib::util qw(fail);
 
our @EXPORT_OK = qw(read_lines read_db write_db write_manifest read_snapshot diff_snapshot find_file_conflict
    read_linkdeps write_linkdeps_for linkdeps_users read_subslot_deps write_subslot_deps_for db_lock db_unlock
    canon_lock canon_unlock);
 
sub read_lines {
	my ($path) = @_;
	my @lines;
	my $fh;
 
	unless(open($fh, '<', $path))
	{
		return @lines;
	}
	while(my $line = <$fh>)
	{
		chomp $line;
		push @lines, $line if length $line;
	}
	close($fh);
	return @lines;
}
 
# db lines: name<TAB>ver<TAB>license[<TAB>requested]. requested is 1 for
# packages explicitly installed by the user (roots), 0 for pulled-in deps;
# older 3-field lines default to requested=0.
sub read_db {
	my %db;
 
	for my $line (read_lines($CFG->{DBFILE}))
	{
		my @f = split /\t/, $line;
		my $name = $f[0];
		next unless defined $name && length $name;
		$db{$name} = { ver => $f[1], license => $f[2], requested => ($f[3] ? $f[3] : 0) };
	}
	return \%db;
}
 
# exclusive lock guarding the shared db (and manifest) so concurrent mp
# processes (e.g. two mp invocations at once) never read/write mid-state.
{
	my $lockfh;
 
	sub db_lock {
		unless(-d $CFG->{WD})
		{
			system('mkdir', '-p', $CFG->{WD}) == 0 or fail("failed making $CFG->{WD}");
		}
		open($lockfh, '>>', "$CFG->{WD}/db.lock") or fail("cannot open db lock: $!");
		flock($lockfh, LOCK_EX) or fail("cannot lock db: $!");
		return;
	}
 
	sub db_unlock {
		if(defined $lockfh)
		{
			flock($lockfh, LOCK_UN) or fail("cannot unlock db: $!");
			close($lockfh);
			$lockfh = undef;
		}
		return;
	}
}
 
# exclusive PER-CANON lock, held across a package's own whole
# reinstall lifecycle (mplib::resolve::reinstall_pkg -- remove: phase
# through the fresh install: phase's own before/after snapshot) and,
# standalone, around a single remove or install -- a separate lock
# file per canon, not the one shared db.lock above, so locking one
# package never blocks progress on a different, unrelated one: only
# two processes racing to operate on the exact SAME package ever
# actually wait on this. closes two real, confirmed exposures db_lock
# itself deliberately doesn't cover (see its own comment: held only
# around "who claims the stage dir," never across the phases that
# follow, specifically to keep cross-package parallelism):
#   1. two concurrent operations on the SAME canon each opening their
#      own install: phase's before/after snapshot window at once --
#      anything EITHER one's own phase script writes during that
#      overlap gets attributed to whichever snapshot happened to be
#      comparing at that instant, not necessarily the one that
#      actually wrote it.
#   2. two concurrent operations on the SAME canon racing on its own
#      STAGE DIRECTORY itself -- confirmed directly, two concurrent
#      "mp reinstall" calls on one already-installed package each
#      failing outright ("can't open 'remove.sh'"/"can't open
#      'install.sh'") because one process's own unstage/restage
#      landed while the other's own remove.sh or install.sh was still
#      being written or read.
#
# reentrant WITHIN one process (a depth counter per canon, real
# flock/unflock only on the outermost acquire/release): reinstall_pkg
# locks once around its own whole remove-then-install sequence, and
# install_pkg_body (reached from inside that same sequence) locks
# again around its own narrower install: window -- without
# reentrancy, that inner call would try to flock a path this SAME
# process already holds exclusively and deadlock itself forever
# (flock has no timeout). a DIFFERENT process's own first, outermost
# canon_lock($canon) call still blocks normally either way.
{
	my %lockfh;
	my %depth;
 
	sub canon_lock {
		my ($canon) = @_;
		if($depth{$canon})
		{
			$depth{$canon}++;
			return;
		}
		my $dir = "$CFG->{WD}/locks";
		unless(-d $dir)
		{
			system('mkdir', '-p', $dir) == 0 or fail("failed making $dir");
		}
		# a bare pkg_name never contains "/", but a pkg_slot_use-composed
		# canon (e.g. "gcc:12") can carry a ":" -- safe, unambiguous on
		# every real filesystem this runs on, no escaping needed beyond
		# this one substitution for the (currently theoretical, kept
		# defensive) case of a "/" ever reaching here.
		(my $safe = $canon) =~ s{/}{_}g;
		open($lockfh{$canon}, '>>', "$dir/$safe.lock") or fail("cannot open lock for $canon: $!");
		flock($lockfh{$canon}, LOCK_EX) or fail("cannot lock $canon: $!");
		$depth{$canon} = 1;
		return;
	}
 
	sub canon_unlock {
		my ($canon) = @_;
		if($depth{$canon} && $depth{$canon} > 1)
		{
			$depth{$canon}--;
			return;
		}
		delete $depth{$canon};
		if(defined $lockfh{$canon})
		{
			flock($lockfh{$canon}, LOCK_UN) or fail("cannot unlock $canon: $!");
			close($lockfh{$canon});
			delete $lockfh{$canon};
		}
		return;
	}
}
 
# write $db (installs to overlay) merged onto the freshest on-disk db,
# under the lock, dropping any names listed in $deleted -- so a concurrent
# mp's changes are never clobbered by this process's own stale in-memory
# view.
sub write_db {
	my ($db, $deleted) = @_;
	$deleted ||= [];
	my $fh;
 
	db_lock();
	my $disk = read_db();
	for my $name (keys %$db)
	{
		$disk->{$name} = $db->{$name};
	}
	for my $name (@$deleted)
	{
		delete $disk->{$name};
	}
	# write-temp-then-rename (not truncate-in-place): the lock already
	# keeps two PROCESSES from writing this file at once, but does
	# nothing for THIS process being killed (OOM, SIGKILL, power loss)
	# mid-write -- a truncate-in-place write leaves whatever was flushed
	# so far as the only content, a partial/corrupt db. rename() is
	# atomic on the same filesystem, so a reader always sees either the
	# complete old file or the complete new one, never a half-written one.
	my $tmp = "$CFG->{DBFILE}.tmp";
	open($fh, '>', $tmp) or fail("cannot write $tmp");
	for my $name (sort keys %$disk)
	{
		print $fh "$name\t$disk->{$name}{ver}\t$disk->{$name}{license}\t$disk->{$name}{requested}\n";
	}
	close($fh) or fail("cannot write $tmp: $!");
	rename($tmp, $CFG->{DBFILE}) or fail("cannot replace $CFG->{DBFILE}: $!");
	db_unlock();
	return;
}
 
# revdep/broken-linkage tracking: one "consumer_canon\tdep_canon" line per
# buildlink edge (mplib::resolve::resolved_slotted_deps/dep_slot_prefixes)
# -- a consumer that got dep_canon's private prefix wired into its own
# MP_DEP_PREFIXES at install time. root-scoped ($CFG->{WD}/linkdeps.db)
# exactly like db/manifest, so a sysroot has its own independent set.
sub read_linkdeps {
	my %edges;
 
	for my $line (read_lines("$CFG->{WD}/linkdeps.db"))
	{
		my ($consumer, $dep) = split /\t/, $line, 2;
		next unless defined $dep && length $dep;
		$edges{$consumer}{$dep} = 1;
	}
	return \%edges;
}
 
# replace $consumer's whole outgoing edge set with @$deps (an empty
# arrayref -- e.g. on remove -- just drops it entirely), under the same
# lock write_db uses so a concurrent mp process never sees a half-written
# file.
sub write_linkdeps_for {
	my ($consumer, $deps) = @_;
	my $fh;
 
	db_lock();
	my $edges = read_linkdeps();
	if(@$deps)
	{
		$edges->{$consumer} = { map { $_ => 1 } @$deps };
	}
	else
	{
		delete $edges->{$consumer};
	}
	# write-temp-then-rename, same reasoning as write_db above.
	my $path = "$CFG->{WD}/linkdeps.db";
	my $tmp = "$path.tmp";
	open($fh, '>', $tmp) or fail("cannot write $tmp");
	for my $c (sort keys %$edges)
	{
		print $fh "$c\t$_\n" for sort keys %{$edges->{$c}};
	}
	close($fh) or fail("cannot write $tmp: $!");
	rename($tmp, $path) or fail("cannot replace $path: $!");
	db_unlock();
	return;
}
 
# every consumer currently recorded as linked against $dep_canon (callers
# filter against the live db themselves -- a consumer already removed
# leaves a stale edge here until its own write_linkdeps_for($consumer, [])
# runs, which "mp remove" always does, but a caller checking safety before
# acting should still only trust entries for packages actually installed).
sub linkdeps_users {
	my ($dep_canon) = @_;
	my $edges = read_linkdeps();
	return sort grep { $edges->{$_}{$dep_canon} } keys %$edges;
}
 
# slot-operator tracking ("@dep" in pkg_deps=, mplib::resolve's own
# leading-sigil strip -- same convention as the existing "?" soft-dep
# marker): one "consumer_canon\tdep_canon\tsubslot" line per tracked
# dependency, recording exactly what pkg_subslot value $dep had the
# moment $consumer last built against it. same shape as linkdeps.db
# just above (one file per relationship-kind, not a single db shared by
# every concern), but VALUE-carrying, not a plain edge -- "mp update"'s
# own rebuild-cascade check (mplib::resolve::subslot_changed_targets)
# compares this recorded value against $dep's CURRENT pkg_subslot to
# decide whether $consumer needs rebuilding, the same spirit as
# Portage's own ":=" slot operator. root-scoped
# ($CFG->{WD}/subslots.db), same reasoning as linkdeps.db.
sub read_subslot_deps {
	my %edges;
 
	for my $line (read_lines("$CFG->{WD}/subslots.db"))
	{
		my ($consumer, $dep, $subslot) = split /\t/, $line, 3;
		next unless defined $subslot && length $consumer && length $dep;
		$edges{$consumer}{$dep} = $subslot;
	}
	return \%edges;
}
 
# replace $consumer's whole tracked set with %$deps ({dep_canon =>
# subslot, ...} -- an empty hashref, e.g. on remove, just drops it
# entirely), under the same lock write_db/write_linkdeps_for use.
sub write_subslot_deps_for {
	my ($consumer, $deps) = @_;
	my $fh;
 
	db_lock();
	my $edges = read_subslot_deps();
	if(%$deps)
	{
		$edges->{$consumer} = { %$deps };
	}
	else
	{
		delete $edges->{$consumer};
	}
	# write-temp-then-rename, same reasoning as write_db above.
	my $path = "$CFG->{WD}/subslots.db";
	my $tmp = "$path.tmp";
	open($fh, '>', $tmp) or fail("cannot write $tmp");
	for my $c (sort keys %$edges)
	{
		print $fh "$c\t$_\t$edges->{$c}{$_}\n" for sort keys %{$edges->{$c}};
	}
	close($fh) or fail("cannot write $tmp: $!");
	rename($tmp, $path) or fail("cannot replace $path: $!");
	db_unlock();
	return;
}
 
sub write_manifest {
	my ($name, $files) = @_;
	my $fh;
 
	unless(-d $CFG->{MANDIR})
	{
		system('mkdir', '-p', $CFG->{MANDIR}) == 0 or fail("failed making $CFG->{MANDIR}");
	}
	# write-temp-then-rename, same reasoning as write_db.
	my $path = "$CFG->{MANDIR}/$name";
	my $tmp = "$path.tmp";
	open($fh, '>', $tmp) or fail("cannot write manifest for $name");
	print $fh "$_\n" for @$files;
	close($fh) or fail("cannot write manifest for $name: $!");
	rename($tmp, $path) or fail("cannot replace manifest for $name: $!");
	return;
}
 
sub read_snapshot {
	my ($path) = @_;
	my %m;
 
	for my $line (read_lines($path))
	{
		my ($p, $mtime) = split /\t/, $line, 2;
		$m{$p} = $mtime;
	}
	return %m;
}
 
# known limitation: for regular files this is an mtime-only signal (full
# nanosecond precision from walktree/fstree.c, not truncated anywhere in
# this comparison), not a content hash. a write that overwrites an
# already-installed file's content while preserving its exact original
# mtime (e.g. a timestamp-preserving extraction, or a reproducible build
# using a fixed SOURCE_DATE_EPOCH) produces a file this function can't
# tell apart from an untouched one -- it's silently excluded from
# @changed, so find_file_conflict never even considers it. narrow and
# requires a fairly deliberate build step to trigger (an ordinary rebuild
# always changes mtime), so treated as an accepted gap rather than
# switching to a full content hash for every file on every install.
#
# symlinks are the one exception: fstree.c's walktree records a symlink's
# readlink() target instead of its mtime, specifically because installing
# any shared library via libtool runs libtool's "--finish" step, which
# recreates EVERY versioned .so symlink already in that libdir (not just
# its own) as a normal side effect -- same target, fresh mtime. comparing
# by mtime alone made that harmless recreation look like a changed file
# and produced a false "conflicts with" against whichever package
# actually owns the symlink; comparing the target instead (a symlink's
# actual content) fixes it at the source instead of papering over it with
# --force on every affected install.
sub diff_snapshot {
	my ($before, $after) = @_;
	my %b = read_snapshot($before);
	my %a = read_snapshot($after);
	my @changed;
 
	for my $p (sort keys %a)
	{
		if(!exists $b{$p} || $b{$p} ne $a{$p})
		{
			push @changed, $p;
		}
	}
	return @changed;
}
 
sub find_file_conflict {
	my ($newfiles, $name, $db) = @_;
	my %new = map { $_ => 1 } @$newfiles;
 
	for my $other (sort keys %$db)
	{
		next if $other eq $name;
		for my $f (read_lines("$CFG->{MANDIR}/$other"))
		{
			return $other if $new{$f};
		}
	}
	return undef;
}
 
1;