src/owns.pl

#!/usr/bin/env perl
# mp owns <path...> -- which installed package's own manifest (if any)
# claims a given path, walking a chain of symlinks hop by hop rather
# than checking only the exact path given or only its final resolved
# target. real motivating case this session: /usr/bin/gcc is a
# symlink to /usr/gcc-git/bin/gcc -- a naive "resolve fully then check
# once" tool would only ever report on gcc-git/bin/gcc (the real
# file), silently saying nothing about whether the SYMLINK ITSELF
# (bin/gcc) is tracked by anything, which is exactly the gap that let
# gcc's own manifest go stale (fstree.c's snapshot tracks a symlink by
# its target-path STRING, not mtime -- a symlink whose target string
# never changes across reinstalls never re-registers as "changed," so
# a manifest can lose track of a symlink entry with zero indication
# anything is wrong until a tool like this one actually asks).
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use Cwd qw(getcwd abs_path);
use mplib::config qw($CFG);
use mplib::util qw(fail);
use mplib::db qw(read_lines read_db);
use mplib::resolve qw(init);
 
my $flags = mplib::config::parse_flags(\@ARGV);
mplib::config::load($flags);
fail("path required") unless @ARGV;
init();
 
my $db = read_db();
 
# collapses "." and ".." segments textually (NOT Cwd::abs_path, which
# calls realpath() and needs every path component to actually exist --
# this has to keep working for a dangling symlink's own nonexistent
# target too, printing a sensible answer instead of silently
# undef'ing).
sub normalize {
	my ($path) = @_;
	my @parts;
	for my $seg (split m{/}, $path)
	{
		next if $seg eq '' || $seg eq '.';
		if($seg eq '..') { pop @parts; next; }
		push @parts, $seg;
	}
	return '/' . join('/', @parts);
}
 
# resolves any symlinked DIRECTORY components leading up to $path's
# own final element, leaving that final element exactly as given --
# real, hit-for-real case: /bin is itself a symlink to usr/bin on a
# usrmerge system, so "/bin/busybox" and "/usr/bin/busybox" are the
# exact same file, but a naive check against the literal, unresolved
# "/bin/busybox" string never falls under $CFG->{INSTPREFIX} (usually
# "/usr") at all -- reported "outside /usr, no installed package could
# own it" for a file that plainly IS owned by one. Cwd::abs_path (not
# the textual normalize() above) is what actually walks the real
# filesystem here, since only a real lstat/readlink chain can know
# "/bin" resolves to "usr/bin" in the first place -- textual "../"
# collapsing alone has no way to know that. wrapped in eval and left
# unresolved on failure (a nonexistent or unreadable directory in the
# chain) so a dangling target still gets a sensible "does not exist"
# report below instead of crashing.
sub canon_dir {
	my ($path) = @_;
	return $path if $path eq '/';
	(my $dir = $path) =~ s{/[^/]*$}{};
	$dir = '/' if $dir eq '';
	(my $base = $path) =~ s{^.*/}{};
	my $real = eval { abs_path($dir) };
	return (defined $real ? normalize("$real/$base") : $path);
}
 
# undef if $abs falls outside $CFG->{INSTPREFIX} entirely (nothing a
# manifest could ever claim), else the INSTPREFIX-relative path
# manifests actually store (mplib::db::write_manifest's own format,
# same one mp files already prints against).
sub rel_under_prefix {
	my ($abs) = @_;
	my $prefix = $CFG->{INSTPREFIX};
	return '' if $abs eq $prefix;
	return undef unless index($abs, "$prefix/") == 0;
	return substr($abs, length($prefix) + 1);
}
 
# linear scan of every installed package's own manifest -- same
# approach mplib::db::find_file_conflict already uses for the
# identical "does ANY other package's manifest already list this
# path" question, just answering it for one exact path instead of a
# whole about-to-be-installed set.
sub owner_of_rel {
	my ($rel) = @_;
	return undef unless length $rel;
	for my $canon (sort keys %$db)
	{
		for my $f (read_lines("$CFG->{MANDIR}/$canon"))
		{
			return $canon if $f eq $rel;
		}
	}
	return undef;
}
 
my $cwd = getcwd();
for my $arg (@ARGV)
{
	my $path = normalize($arg =~ m{^/} ? $arg : "$cwd/$arg");
 
	print "$path:\n";
	my %seen;
	my $depth = 0;
	while(1)
	{
		# directory-symlink resolution happens BEFORE the ownership
		# check at every hop, not just once up front: a relative
		# symlink target computed below can itself land back inside
		# another symlinked directory (e.g. a target that starts
		# "../lib/..." where "lib" is itself a symlink).
		my $canon = canon_dir($path);
		if($canon ne $path)
		{
			print "  -> $canon\n";
			$path = $canon;
		}
 
		if($seen{$path}++)
		{
			print "  symlink loop detected, stopping.\n";
			last;
		}
 
		my $rel = rel_under_prefix($path);
		unless(defined $rel)
		{
			print "  outside $CFG->{INSTPREFIX}, no installed package could own it.\n";
			last;
		}
 
		my $owner = owner_of_rel($rel);
		if(defined $owner)
		{
			print "  owned by $owner.\n";
		}
		elsif(-e $path || -l $path)
		{
			print "  exists, but no installed package's manifest claims it.\n";
		}
		else
		{
			print "  does not exist" . ($depth ? " (broken symlink target)" : '') . ".\n";
		}
 
		last unless -l $path;
		my $target = readlink($path);
		unless(defined $target)
		{
			print "  (unreadable symlink target)\n";
			last;
		}
		# a relative symlink target resolves against ITS OWN containing
		# directory, not $cwd -- same as real filesystem symlink
		# resolution (readlink -f, realpath(3)).
		unless($target =~ m{^/})
		{
			(my $dir = $path) =~ s{/[^/]*$}{};
			$dir = '/' if $dir eq '';
			$target = "$dir/$target";
		}
		$target = normalize($target);
		print "  -> $target\n";
		$path = $target;
		$depth++;
	}
	print "\n";
}