src/mplib/portformat.pm

use v5.16;
package mplib::portformat;
use strict;
use warnings FATAL => 'all';
use Exporter 'import';
use mplib::config qw($CFG first_repo_file);
use mplib::util qw(fail note pconf_lookup delta_or_literal);
 
our @EXPORT_OK = qw(read_port resolve_port write_phase_scripts parse_pkg_use enabled_use apply_use_patches resolve_slot USE_NONE);
 
# persisted as USE=%s when mp.use toggles OFF the last still-enabled flag
# of a port that has at least one "+flag" default-on -- an ordinary empty
# string can't represent that state at all: mplib::config::set_pkgconf
# (like every other per-package config key) treats an empty value as "no
# override configured", which for a port with no defaults is harmless
# (empty override == no override == nothing enabled, same result either
# way) but for a defaults-having port would silently make enabled_use's
# own fallback chain skip straight past the "really, truly nothing"
# override and re-derive the DEFAULT set instead -- exactly backwards
# from what "mp use pkg -lastflag" just asked for. not a real flag name
# (parse_pkg_use never produces one shaped like this), so it can never
# collide with anything a port actually declares.
use constant USE_NONE => '-none-';
 
# low-level parser for one port file (or one class file, same grammar):
# unindented key="value" lines are metadata; an unindented "phase:" line
# opens a phase whose indented lines are appended verbatim (one leading
# whitespace char stripped) as that phase's raw shell body, until the next
# unindented line. returns (\%meta, \%phases), or (undef, undef) if unreadable.
sub read_port {
	my ($path) = @_;
	my (%meta, %phases);
	my $fh;
	my $phase;
	my $heredoc_term;
 
	return (undef, undef) unless open($fh, '<', $path);
	while(my $line = <$fh>)
	{
		chomp $line;
		# a shell heredoc's content is conventionally unindented (flush
		# left), which without this check gets misread by the plain
		# indentation rule below as either new global metadata (if it
		# happens to look like key=value) or a line closing the phase --
		# either way silently truncating the rest of the phase body with
		# no diagnostic. best-effort (a regex, not a real shell parser):
		# recognizes a single "<<[-]['"]?WORD['"]?" opener per body line
		# and keeps appending verbatim, unindented and unreinterpreted,
		# until the exact terminator line.
		if(defined $heredoc_term)
		{
			$phases{$phase} .= "$line\n";
			undef $heredoc_term if $line =~ /^\Q$heredoc_term\E\s*$/;
			next;
		}
		if($line =~ /^[ \t]/)
		{
			next unless defined $phase;
			(my $body = $line) =~ s/^[ \t]//;
			$phases{$phase} .= "$body\n";
			$heredoc_term = $2 if $body =~ /<<-?\s*(['"]?)(\w+)\1/;
			next;
		}
		next if $line !~ /\S/ || $line =~ /^\s*#/;
		if($line =~ /^([a-z][a-z0-9_]*):\s*(?:#.*)?$/)
		{
			$phase = $1;
			$phases{$phase} = '' unless exists $phases{$phase};
			next;
		}
		if($line =~ /^([A-Za-z0-9_]+)=(.*)$/)
		{
			my ($k, $v) = ($1, $2);
			$v =~ s/^"(.*)"$/$1/;
			$v =~ s/^'(.*)'$/$1/;
			$meta{$k} = $v;
			$phase = undef;
		}
	}
	close($fh);
	return (\%meta, \%phases);
}
 
sub read_lines_raw {
	my ($path) = @_;
	my $fh;
	local $/;
 
	return undef unless open($fh, '<', $path);
	my $text = <$fh>;
	close($fh);
	return $text;
}
 
# resolve one port: its own pkg.conf, merged with any inherit="class ..."
# classes (port's own phases always win; later class wins among classes),
# falling back to the legacy add.sh/del.sh pair as the whole "install"/
# "remove" phase body when the port declares no phases of its own at all,
# so an unmigrated port behaves exactly as it always has.
sub resolve_port {
	my ($portdir, $verover) = @_;
	my ($meta, $phases) = read_port("$portdir/pkg.conf");
	return undef unless $meta;
 
	my %merged;
	# list-like fields get UNIONED across every class plus the port's own
	# declaration (classes first, in inherit= order, port's own appended
	# last) -- previously only pkg_deps got this treatment, so a class
	# declaring e.g. pkg_bdepend (a very natural thing to share across a
	# whole family of ports via inherit=) was silently completely inert.
	# scalar fields instead take the port's own value if it declared one
	# at all, else the LAST class in inherit= order that declared one
	# (matching the "later class wins among classes" rule the phase
	# merge below already uses) -- a class contributes only a fallback
	# default, never overriding the port's own explicit choice.
	my @LISTFIELDS = qw(pkg_deps pkg_bdepend pkg_rdepend pkg_deps_soft pkg_tags pkg_use);
	my @SCALARFIELDS = qw(pkg_pref pkg_slot pkg_slot_use pkg_keywords pkg_fetch pkg_license pkg_manifest_cleanup);
	my %classlist;
	my %classscalar;
	for my $cls (split ' ', $meta->{inherit} || '')
	{
		# searched across every configured repo in priority order (same
		# as a port/profile/sysroot-overlay lookup) -- a class can ship
		# from any repo, not only the highest-priority one.
		my $cpath = first_repo_file($CFG->{REPOS}, "classes/$cls.mp");
		my ($cmeta, $cphases) = defined $cpath ? read_port($cpath) : (undef, undef);
		unless($cphases)
		{
			note("inherit=\"$cls\" not found (searched: "
			    . join(', ', map { "$_->{dir}/classes/$cls.mp" } @{$CFG->{REPOS}}) . ")");
			next;
		}
		$merged{$_} = $cphases->{$_} for keys %$cphases;
		for my $k (@LISTFIELDS)
		{
			push @{$classlist{$k}}, $cmeta->{$k} if defined $cmeta->{$k} && $cmeta->{$k} ne '';
		}
		for my $k (@SCALARFIELDS)
		{
			$classscalar{$k} = $cmeta->{$k} if defined $cmeta->{$k} && $cmeta->{$k} ne '';
		}
	}
	$merged{$_} = $phases->{$_} for keys %$phases;
	for my $k (@LISTFIELDS)
	{
		next unless $classlist{$k};
		(my $joined = join(' ', @{$classlist{$k}}, defined $meta->{$k} ? $meta->{$k} : '')) =~ s/^\s+|\s+$//g;
		$joined =~ s/\s+/ /g;
		$meta->{$k} = $joined;
	}
	for my $k (@SCALARFIELDS)
	{
		$meta->{$k} = $classscalar{$k} if defined $classscalar{$k} && !(defined $meta->{$k} && $meta->{$k} ne '');
	}
 
	# legacy ports (no phase: blocks anywhere in the port or its classes)
	# fall back to add.sh/del.sh verbatim. those scripts already do their
	# own complete cd-into/out-of the source dir for the one shell
	# invocation they were written for, so they get no auto srcname cd
	# (see write_phase_scripts) unlike genuine new-format phases below.
	my $legacy = 0;
	unless(%merged)
	{
		my $add = read_lines_raw("$portdir/add.sh");
		my $del = read_lines_raw("$portdir/del.sh");
		$merged{install} = $add if defined $add;
		$merged{remove}  = $del if defined $del;
		$legacy = 1;
	}
 
	for my $k (qw(pkg_deps pkg_tags pkg_conflicts pkg_use pkg_slot pkg_bdepend pkg_rdepend
	    pkg_keywords pkg_fetch pkg_deps_soft pkg_license))
	{
		$meta->{$k} = '' unless defined $meta->{$k};
	}
	$meta->{pkg_pref} = 50 unless defined $meta->{pkg_pref} && $meta->{pkg_pref} ne '';
	$meta->{_legacy} = $legacy;
 
	# a caller pinning to a specific version (a "=X" dep/CLI constraint, or
	# HOLD_VERSION) overrides the port's own declared pkg_ver, both for what
	# gets fetched below and what mp records as installed.
	$meta->{pkg_ver} = $verover if defined $verover && $verover ne '';
 
	# a declarative pkg_fetch synthesizes a default fetch phase (git clone,
	# or tar fetch+extract, landing in a dir named after the port) unless
	# the port or one of its classes already wrote an explicit one.
	if(!exists $merged{fetch} && $meta->{pkg_fetch} ne '')
	{
		my $name = $meta->{pkg_name};
		if($meta->{pkg_fetch} =~ /^git:([^@]+)(?:@(.+))?$/)
		{
			my ($url, $reftmpl) = ($1, $2);
			$merged{fetch} = "git clone $url $name\n";
			if(defined $reftmpl)
			{
				(my $ref = $reftmpl) =~ s/<VER_>/$meta->{pkg_ver}/g;
				$merged{fetch} .= "cd $name\ngit checkout $ref\ncd ..\n";
			}
		}
		elsif($meta->{pkg_fetch} =~ /^tar:([^,]+),(.+)$/)
		{
			my ($url, $extractdir) = ($1, $2);
			my ($archive) = $url =~ m{([^/]+)$};
			$merged{fetch} = "curl -LO $url\ntar xf $archive\nmv $extractdir $name\nrm -f $archive\n";
		}
	}
	# a patches/ dir next to pkg.conf synthesizes a default patch phase
	# (patch -p1 < each patches/*.patch, sorted) unless the port or one of
	# its classes already wrote an explicit one. new-format ports only:
	# every other phase gets an automatic "cd $srcname" (see
	# write_phase_scripts) that legacy ports deliberately opt out of since
	# their one add.sh/del.sh script already does its own complete cd, so
	# a synthesized patch phase would run in the wrong directory there.
	if(!$legacy && !exists $merged{patch} && -d "$portdir/patches")
	{
		# mpx stage copies the whole portdir (patches/ included) into the
		# stage dir, a sibling of the fetched source dir every other
		# phase auto-cds into, hence the "../patches/" relative path.
		my @patches = sort map { s{.*/}{}; $_ } glob("$portdir/patches/*.patch");
		if(@patches)
		{
			$merged{patch} = join('', map { "patch -p1 < ../patches/$_\n" } @patches);
			# the raw ordered list (not just the flattened shell text) so
			# a later optional patches.conf (see mplib::resolve::
			# apply_patch_manifest) can filter/reorder by relative patch
			# path and regenerate the phase from the result.
			$meta->{_patchlist} = [ @patches ];
		}
	}
	$meta->{_phases} = \%merged;
	$meta->{_portdir} = $portdir;
	return $meta;
}
 
# use-flag-conditional patches, checked in addition to (and applied after)
# the unconditional patches/*.patch handled above: patches/use-<flag>/*.patch
# applies only when <flag> is enabled for $canon, patches/nouse-<flag>/*.patch
# only when it's disabled (including never declared). same "../patches/..."
# relative path as the unconditional case (mpx stage copies the whole
# portdir, patches/ included, into a sibling of the fetched source dir).
# new-format ports only, same as the unconditional case -- and $canon must
# be known (it's derived from $pc's own pkg_name/pkg_slot, so this can only
# run after resolve_port returns, not from inside it).
sub apply_use_patches {
	my ($pc, $canon) = @_;
	return if $pc->{_legacy};
	my $portdir = $pc->{_portdir};
	return unless defined $portdir;
 
	my $enabled = enabled_use($canon, parse_pkg_use($pc->{pkg_use}));
	my @extra;
	for my $dir (sort glob("$portdir/patches/use-*"))
	{
		next unless -d $dir;
		my ($flag) = $dir =~ m{/use-([^/]+)$};
		next unless defined $flag && $enabled->{$flag};
		push @extra, sort map { s{.*/}{}; "use-$flag/$_" } glob("$dir/*.patch");
	}
	for my $dir (sort glob("$portdir/patches/nouse-*"))
	{
		next unless -d $dir;
		my ($flag) = $dir =~ m{/nouse-([^/]+)$};
		next unless defined $flag && !$enabled->{$flag};
		push @extra, sort map { s{.*/}{}; "nouse-$flag/$_" } glob("$dir/*.patch");
	}
	return unless @extra;
	$pc->{_phases}{patch} = join('', ($pc->{_phases}{patch} || ''),
	    map { "patch -p1 < ../patches/$_\n" } @extra);
	push @{$pc->{_patchlist} ||= []}, @extra;
	return;
}
 
# write each named phase's resolved body to $dir/<phase>.sh (set -e
# prefixed, matching the existing add.sh/del.sh convention) for every
# phase that has non-empty content; returns the list of phase names
# actually written, in the given order. each phase is its own process
# (mpx runsh chdirs to $dir fresh every time), so every phase but fetch
# gets an automatic "cd $srcname" so it lands back in the tree fetch
# checked out, matching the legacy single-script add.sh/del.sh behaviour.
sub write_phase_scripts {
	my ($dir, $phases, $srcname, @order) = @_;
	my @written;
 
	for my $p (@order)
	{
		my $body = $phases->{$p};
		next unless defined $body && $body =~ /\S/;
		my $fh;
		open($fh, '>', "$dir/$p.sh") or fail("cant write $dir/$p.sh: $!");
		my $cdline = ($p ne 'fetch' && $srcname) ? "cd $srcname 2>/dev/null || true\n" : '';
		print $fh "set -e\n\n$cdline$body";
		close($fh);
		push @written, $p;
	}
	return @written;
}
 
# parse a pkg_use string like "ssl:%openssl x11:libxcb,libx11 oss" into a
# map flag => {build=>0|1, default=>0|1, deps=>[...]}; a flag with no deps
# is just a boolean feature bit. "flag:b:dep1,dep2" marks the deps
# build-only. a leading "+" on the flag name itself ("+flag", same
# convention Portage's own IUSE uses) marks it enabled by default when
# nothing (no per-package or global USE=) says otherwise -- see
# enabled_use's own comment for exactly where that fallback applies.
sub parse_pkg_use {
	my ($s) = @_;
	my %use;
 
	for my $tok (split ' ', $s || '')
	{
		my ($f, $d) = split /:/, $tok, 2;
		next unless defined $f && length $f;
		my $default = $f =~ s/^\+//;
		my $build = defined $d && $d =~ s/^b://;
		$use{$f} = { build => ($build ? 1 : 0), default => ($default ? 1 : 0),
		    deps => [ grep { /\S/ } map { split /,/ } (defined $d ? $d : '') ] };
	}
	return \%use;
}
 
# which USE flags are enabled for a package: per-pkg section USE=, else
# the global USE=, else (only when NEITHER is set at all -- a per-package
# or global USE= always wins outright, even an empty one) whatever this
# port's own pkg_use declares "+flag"-default-on. flags the port does not
# declare are simply ignored. $declared, if passed (parse_pkg_use's own
# return value -- most callers already have $pc handy and can pass
# $pc->{pkg_use} through parse_pkg_use, or just skip it: every call site
# that predates default-on flags keeps working identically, since a
# missing $declared just means no defaults get applied, same as before
# this existed).
sub enabled_use {
	my ($cur, $declared) = @_;
	# pconf_lookup (mplib::util): a slot-qualified canon (e.g.
	# "curl:nossl") with no USE= of its own falls back to its bare name's
	# section before the global default -- the bare name is the only key
	# knowable before a pkg_slot_use-composed slot exists (see
	# resolve_slot below), so a single "curl: USE=nossl" section drives
	# both slot selection and everything else (deps/patches/exports) for
	# the resulting slot. a no-op for every unslotted port (base eq cur
	# already).
	my $defaults = $declared
	    ? join(' ', grep { $declared->{$_}{default} } keys %$declared)
	    : '';
	my $perpkg = $cur ? pconf_lookup($cur, 'USE') : undef;
	my $sel;
	if(defined $perpkg)
	{
		# a per-package override is deliberate and SPECIFIC to this one
		# package. a plain bare-name list is the traditional, complete/
		# authoritative form -- exactly this set, nothing else (same as
		# before default-on flags existed at all). but a raw USE= line
		# can ALSO be written the same way "mp use pkg +flag -flag"
		# takes it on the command line -- mp use is just a convenience
		# wrapper that computes and persists this same result, it isn't
		# the only way to express it, so hand-editing mp.conf with +/-
		# syntax is equally valid, applied atop this package's own
		# declared defaults exactly like a first toggle would be.
		$sel = $perpkg eq USE_NONE ? $perpkg : delta_or_literal($perpkg, $defaults, "USE= for '$cur'");
	}
	else
	{
		# global USE= was never written with THIS package's own defaults
		# in mind -- it's one flat, system-wide list meant to flip on a
		# same-named flag on WHATEVER port happens to declare it (the
		# original, pre-existing design), not a statement about every
		# other unrelated flag on every other port. a bare list ADDS to
		# declared defaults rather than replacing them outright, or a
		# global USE= set for one thing (say "ssl", for curl) would
		# silently turn off EVERY "+flag" default on EVERY OTHER package
		# too -- reproduced for real on an install with nothing globally
		# configured except one unrelated USE= line. a +/- token in a
		# global value is a delta over declared defaults the same as a
		# per-package one -- "USE=-ssl" globally turns ssl off even where
		# it's on by default, without needing a per-package override.
		my $global = $CFG->{conf}{USE};
		$sel = !defined $global ? $defaults
		    : (grep { /^[+-]/ } grep { /\S/ } split ' ', $global) ? delta_or_literal($global, $defaults, "global USE=")
		    : join(' ', $defaults, $global);
	}
	$sel = '' if $sel eq USE_NONE;
	my %enabled = map { $_ => 1 } grep { /\S/ } split ' ', $sel;
	return \%enabled;
}
 
# a port's effective SLOT: its static pkg_slot plus, for each flag listed in
# pkg_slot_use (declared order) that's enabled for its bare name (the only
# key knowable before the slot itself exists), a "-flag" suffix. lets two
# installs of the same port differing only in USE flags coexist instead of
# colliding on one slot -- disabled flags (including the entire feature, if
# pkg_slot_use is unset) contribute nothing, so this is a no-op for every
# port that doesn't opt in.
sub resolve_slot {
	my ($pc, $basename) = @_;
	my $slot = $pc->{pkg_slot} || '';
	return $slot unless $pc->{pkg_slot_use};
	my $en = enabled_use($basename, parse_pkg_use($pc->{pkg_use}));
	my @suffix = grep { $en->{$_} } split ' ', $pc->{pkg_slot_use};
	return join('-', grep { $_ ne '' } ($slot, @suffix));
}
 
1;