src/mplib/util.pm

use v5.16;
package mplib::util;
use strict;
use warnings FATAL => 'all';
use Exporter 'import';
use mplib::config qw($CFG read_conf);
 
our @EXPORT_OK = qw(note fail ok confirm try_soft bare_name slot_key split_slot_key backend pconf_lookup pconf_section order_manifest delta_or_literal strip_flag_value spin_start spin_tick spin_stop);
our $SOFTMODE = 0;
 
sub note { print STDERR "warn: $_[0].\n"; return; }
# fail() normally prints and hard-exits, but a soft dependency or a
# speculative "would this choice conflict" probe (see mplib::resolve) needs
# to catch the failure instead of killing the whole process: SOFTMODE, set
# with local() around such a probe, makes fail() die() (catchable by the
# caller's eval) instead of exit()ing.
sub fail { $SOFTMODE ? die("$_[0]\n") : do { print STDERR "err: $_[0].\n"; exit(1); }; }
sub ok   { print STDERR "ok: $_[0].\n"; return; }
 
# interactive y/N gate for every state-changing command (install/update/
# remove/reinstall/hold/unhold/use/mask/unmask/prune/clean) -- prints
# "$msg [y/N] " and reads one line from STDIN, proceeding only on an
# explicit leading y/Y; anything else (a blank Enter included -- matching
# the "N" the prompt itself advertises as the default) exits cleanly,
# quiet (declining isn't an error, so this is exit(0), not fail()).
#
# TTY-gated (-t STDIN), same idiom as spin_start's own -t STDERR gate:
# a script/pipe driving mp non-interactively (this tree's own test suite
# runs mp thousands of times this way, and so does any real automation)
# has no user to ask and no way to answer even if asked -- skipped
# entirely there, so this is purely additive for a real interactive
# terminal and changes nothing for anything already relying on mp's
# existing non-interactive behavior. --yes/-y ($CFG->{YES}) skips it
# unconditionally even at a real terminal, for a human who wants the old
# no-prompt behavior back without redirecting stdin themselves.
sub confirm {
	my ($msg) = @_;
	return if $CFG->{YES};
	return unless -t STDIN;
	print STDERR "$msg [y/N] ";
	my $ans = <STDIN>;
	unless(defined $ans && $ans =~ /^\s*[Yy]/)
	{
		print STDERR "aborted.\n";
		exit(0);
	}
	return;
}
 
# a rotating-character progress indicator for a slow, per-package
# resolution/scan pass (mplib::resolve's own plan_resolution/_plan_dep;
# update.pl/prune.pl's own dependency-graph/closure walks; why.pl/
# verify.pl/dryrun.pl's own whole-db/whole-tree loops) -- same spirit as
# portage's own "Calculating dependencies..." message, a rotating
# character instead of a static one so a long pass doesn't look hung.
# TTY-gated (-t STDERR): redirected/logged output never sees these
# "\r"-based in-place updates, which would otherwise flood a log file
# with one line per tick for no benefit.
#
# idempotent by design: spin_tick/spin_stop are safe to call even if
# spin_start was never called (or already stopped) -- a call site
# doesn't have to carefully balance start/stop against every possible
# early-return path in between.
my @SPIN_CHARS = ('\\', '|', '/', '-');
my $spin_active = 0;
my $spin_i = 0;
my $spin_label = '';
 
sub spin_start {
	my ($label) = @_;
	return unless -t STDERR;
	$spin_active = 1;
	$spin_i = 0;
	$spin_label = $label;
}
 
# the 0.1s pace here (a plain 4-arg select(), not Time::HiRes -- no
# extra module needed for a one-shot fractional sleep) is deliberate,
# not incidental: a real resolution tick is often far faster than this
# (a single hash lookup, sometimes), so without it the animation either
# doesn't render at all between two prints sharing the same terminal
# frame, or flickers illegibly fast -- this is what actually makes it
# READ as a spinning character rather than a blur. it does mean a very
# large batch (a "mp update world"/"mp verify" with hundreds of
# packages) spends a real, non-negligible number of seconds just
# pacing the animation, entirely separate from the resolution work
# itself -- an intentional trade of a little wall-clock time for a
# spinner that's actually visible, same trade every real terminal
# spinner (portage included) makes.
sub spin_tick {
	return unless $spin_active && -t STDERR;
	print STDERR "\r$spin_label " . $SPIN_CHARS[$spin_i % @SPIN_CHARS];
	select(undef, undef, undef, 0.1);
	$spin_i++;
}
 
sub spin_stop {
	return unless $spin_active;
	print STDERR "\r" . (' ' x (length($spin_label) + 2)) . "\r" if -t STDERR;
	$spin_active = 0;
}
 
# run $code with fail() catchable (and silent -- a soft/speculative probe
# failing is not a real error, so it prints nothing rather than an
# alarming "err:" line); returns 1 on success, 0 on failure.
sub try_soft {
	my ($code) = @_;
	local $SOFTMODE = 1;
	my $ok = eval { $code->(); 1 };
	return $ok ? 1 : 0;
}
 
# strips "--$name=<value>" out of @$argv in place (if present) and
# returns its value, else undef. every mp.<cmd>'s own ad-hoc flag loop
# already does exactly this by hand for its own flags (--min=, --try=,
# --stale-years=, ...) -- shared here only for --dir=, since it's the
# one flag common to every port-authoring tool (mp new/lint/devtest/
# depcheck/fetchcheck) rather than five near-identical copies of the
# same loop.
sub strip_flag_value {
	my ($argv, $name) = @_;
	for(my $i = 0; $i < @$argv; $i = $i + 1)
	{
		if($argv->[$i] =~ /^--\Q$name\E=(.*)$/)
		{
			my $v = $1;
			splice(@$argv, $i, 1);
			return $v;
		}
	}
	return undef;
}
 
sub bare_name {
	my ($name) = @_;
	$name =~ s{^.*/}{};
	return $name;
}
 
# the db/manifest/stagedir key for a (name, slot) pair. slot "0" (the
# default, and every pre-SLOT port) renders as just the bare name, so
# existing db lines and manifests for unslotted packages stay untouched.
sub slot_key {
	my ($name, $slot) = @_;
	return (defined $slot && $slot ne '' && $slot ne '0') ? "$name:$slot" : $name;
}
 
# split a slot_key back into (name, slot); slot is '0' if none was present.
sub split_slot_key {
	my ($key) = @_;
	# the slot itself can be any compound string (pkg_slot_use joins
	# enabled flags with '-', and a static compound slot like
	# "12-glibc-znver3-O3" is a documented convention) -- match on the
	# last ':' as the delimiter and accept anything but ':' for the slot,
	# rather than a narrow alnum/underscore/dot class that silently
	# mis-splits (or fails to split at all) any slot containing a hyphen.
	return ($1, $2) if $key =~ /^(.+):([^:]+)$/;
	return ($key, '0');
}
 
# a per-package config key, checked first under the full (possibly
# slot-qualified) canon, falling back to the bare name -- a
# pkg_slot_use-composed canon (e.g. "combodep:foo") doesn't exist yet at
# the moment a user writes HOLD=/MASK=/SYSROOT=/hook_<phase>= (by hand or
# via the mp hold/mask/use sugar commands, which always key by bare name
# for exactly this reason), so the bare name is the only key they could
# plausibly have used. lives here (not mplib::resolve, which uses it for
# HOLD/MASK/SYSROOT) so mplib::hooks -- which mplib::resolve itself
# imports, so it can't import back from resolve without a cycle -- can
# reuse the identical fallback for per-package hook_<phase> lookups. a
# no-op for every unslotted port (base eq canon already).
sub pconf_lookup {
	my ($canon, $key) = @_;
	my $s = $CFG->{pconf}{$canon};
	return $s->{$key} if $s && defined $s->{$key} && $s->{$key} ne '';
	my ($base) = split_slot_key($canon);
	return undef if $base eq $canon;
	$s = $CFG->{pconf}{$base};
	return ($s && defined $s->{$key} && $s->{$key} ne '') ? $s->{$key} : undef;
}
 
# generic manifest filter+order primitive, shared by every "several
# individually-named files, optionally governed by a declarative sibling
# config using mp.conf's own '<item>:' section grammar" mechanism (today:
# mplib::resolve::apply_patch_manifest's patches/patches.conf, and
# mplib::hooks::run_hook's HOOKS_DIR/<phase>/hooks.conf) -- one topological
# sort + cycle guard implementation instead of two near-identical copies.
# $list is the candidate items in their natural/default order (already
# discovered by the caller -- this doesn't do any filesystem globbing of
# its own); $mpath is the optional sibling manifest path (a caller with no
# such file at all can also just pass undef and skip $mpath's -f check).
# $want->($section_or_undef) decides whether to keep an item (called even
# for one with no section of its own, so "no manifest" or "item declares
# nothing but AFTER" still keeps it by returning true unconditionally) --
# the specific meaning of any OTHER key in a section (IF_DEP/IF_VER/
# IF_USE/...) is entirely the caller's business, since only the caller
# knows how to evaluate them (effective_deps/ver_satisfies/enabled_use --
# each already only reachable from specific, different modules).
# "AFTER=<item> <item>" in a section is the one key this function itself
# interprets: an ordering prerequisite among the items being kept,
# topologically sorted (an edge to something not in the kept set is just
# ignored -- AFTER only orders among what's actually running); the input
# list's own order is the DFS visit order and so the natural tiebreak/
# default when nothing declares AFTER, reproducing plain default-order
# behavior exactly when there's no manifest at all. dies via fail() on a
# real AFTER cycle. contract note: $list is assumed to hold distinct
# names -- a duplicate is silently collapsed to one entry in the output
# (the visit closure below is keyed by name, not position), not an error.
# every current caller's $list is inherently unique (real filesystem
# paths/filenames), so this has never been reachable in practice; a
# future caller with a less-guaranteed-unique $list should dedupe (or
# check for dupes and fail()) before calling this, not rely on it here.
sub order_manifest {
	my ($list, $mpath, $want) = @_;
	my $pconf = {};
	if(defined $mpath && -f $mpath)
	{
		(undef, $pconf) = read_conf($mpath);
	}
	my @kept = grep { $want->($pconf->{$_}) } @$list;
	my %inkept = map { $_ => 1 } @kept;
	my (@ordered, %done, %visiting);
	my $visit;
	$visit = sub {
		my ($item) = @_;
		return if $done{$item};
		fail("$mpath: AFTER cycle involving $item") if $visiting{$item};
		$visiting{$item} = 1;
		my $sec = $pconf->{$item};
		if($sec && defined $sec->{AFTER})
		{
			$visit->($_) for grep { $inkept{$_} } split ' ', $sec->{AFTER};
		}
		$visiting{$item} = 0;
		$done{$item} = 1;
		push @ordered, $item;
	};
	$visit->($_) for @kept;
	return @ordered;
}
 
# the full per-package config section for $canon, with its bare name's
# section (if different) merged underneath -- canon-specific keys win on
# a key-by-key basis. same rationale as pconf_lookup just above (a
# pkg_slot_use-composed canon doesn't exist yet at the moment a user
# writes a per-package section, so the bare name is the only key they
# could plausibly have used), for a caller that needs every key in the
# section (mplib::resolve::effective_deps' DEPS/DEPS+/DEPS-,
# mplib::hooks::port_env_args' whole env-export section) rather than one
# key at a time. always returns a hashref (empty if $canon is undef or
# has no section at all either way).
sub pconf_section {
	my ($canon) = @_;
	return {} unless $canon;
	my ($base) = split_slot_key($canon);
	my %sec;
	%sec = %{$CFG->{pconf}{$base}} if $base ne $canon && $CFG->{pconf}{$base};
	%sec = (%sec, %{$CFG->{pconf}{$canon}}) if $CFG->{pconf}{$canon};
	return \%sec;
}
 
# a raw space-separated mp.conf value is either a plain, complete list of
# bare names (exactly these, nothing else) or, once ANY token carries a
# leading +/-, a delta applied on top of $baseline (also space-separated)
# -- the shared mechanism behind every list-valued mp.conf key that also
# has a dedicated toggle command (USE=/"mp use", HOOKS_<phase>=/
# "mp hooks", CONFLICTS=/"mp conflicts"): each command is a convenience
# wrapper that computes and persists this exact same result, never the
# only way to express it, so hand-editing the config with +/- syntax is
# equally valid. mixing a bare token into a delta is rejected outright
# (ambiguous: "also enable this" or "this is the complete set?"), the
# same way each command's own CLI argument parsing already rejects a
# bare token among its +/- ones. $where names the value in an error
# message (e.g. "USE= for 'curl'", "HOOKS_post_install=").
sub delta_or_literal {
	my ($raw, $baseline, $where) = @_;
	my @toks = grep { /\S/ } split ' ', $raw;
	return $raw unless grep { /^[+-]/ } @toks;
	my %en = map { $_ => 1 } grep { /\S/ } split ' ', $baseline;
	for my $tok (@toks)
	{
		if($tok =~ /^\+(.+)$/)    { $en{$1} = 1; }
		elsif($tok =~ /^-(.+)$/)  { delete $en{$1}; }
		else { fail("$where mixes a bare flag ('$tok') with +/-prefixed ones -- once any flag there uses +/- syntax, every flag must (same as its own command requires)"); }
	}
	return join(' ', sort keys %en);
}
 
sub backend {
	my (@args) = @_;
	my $rc = system($CFG->{MPX}, @args);
	if($rc == -1)
	{
		fail("cannot execute backend $CFG->{MPX}: $!");
	}
	if($rc != 0)
	{
		fail("backend command failed: @args");
	}
	return;
}
 
1;