src/mplib/version.pm

use v5.16;
package mplib::version;
use strict;
use warnings FATAL => 'all';
use Exporter 'import';
 
our @EXPORT_OK = qw(vercmp ver_satisfies parse_dep_token);
 
# "git" sorts newest-always (an unpinned HEAD-tracking port); otherwise
# MAJOR[.MINOR[.PATCH[.EXTRA]]][{a|b|pre|rc|p}N][-rN], compared
# componentwise: numeric parts numerically, then stage ordinal
# (a/b/pre/rc < release < p) then the -rN revision as a final tiebreak.
# pkgsrc/FreeBSD-pkg style, not semver, and deliberately not PMS's own
# underscore-prefixed spelling either (_alpha/_beta/_pre/_rc/_p) --
# every stage marker here stays bare, consistent with the a/b/pre/rc
# this scheme already had, rather than mixing underscore and non-
# underscore forms in one grammar. "p" (post-release patch level, e.g.
# a distro-applied patch atop an already-tagged release, sorting AFTER
# the plain release rather than before it) is the one PMS stage concept
# this scheme had no way to express at all until now -- unlike
# alpha/beta/pre/rc (all pre-release, ordered before a plain release),
# closing this gap needed a genuinely new ordinal, not just a spelling
# change, hence appending it (5) rather than inserting it among the
# existing four. "pre" must stay ordered before "p" in the alternation
# below (backtracking would still get this right either way, since
# neither is a strict prefix-match trap for the OTHER's remaining
# input, but ordering the longer alternative first avoids relying on
# that at all).
my %STAGEORD = (a => 0, b => 1, pre => 2, rc => 3, '' => 4, p => 5);
 
sub ver_parts {
	my ($v) = @_;
	my ($base, $stage, $stagenum, $rev) = ('', '', 0, 0);
 
	return undef unless defined $v && $v ne '';
	if($v =~ /^([0-9][0-9.]*)(?:(pre|rc|a|b|p)([0-9]+)?)?(?:-r([0-9]+))?$/)
	{
		($base, $stage, $stagenum, $rev) = ($1, $2 || '', $3 || 0, $4 || 0);
	}
	else
	{
		return undef;
	}
	my @nums = split /\./, $base;
	return [ \@nums, $STAGEORD{$stage}, $stagenum, $rev ];
}
 
# -1/0/1, like <=>. "git" (or anything unparsable) is always newest, so an
# unpinned HEAD-tracking port always satisfies a ">="/"<" constraint the way
# you'd expect ("give me at least this old") without needing a real version.
sub vercmp {
	my ($a, $b) = @_;
	my $pa = ver_parts($a);
	my $pb = ver_parts($b);
 
	return 0 if $a eq $b;
	return 1  unless defined $pa;
	return -1 unless defined $pb;
	my $na = $pa->[0];
	my $nb = $pb->[0];
	for(my $i = 0; $i < @$na || $i < @$nb; $i++)
	{
		my $x = $i < @$na ? $na->[$i] : 0;
		my $y = $i < @$nb ? $nb->[$i] : 0;
		return $x <=> $y if $x != $y;
	}
	return $pa->[1] <=> $pb->[1] if $pa->[1] != $pb->[1];
	return $pa->[2] <=> $pb->[2] if $pa->[2] != $pb->[2];
	return $pa->[3] <=> $pb->[3];
}
 
sub ver_satisfies {
	my ($ver, $op, $val) = @_;
 
	return 1 unless defined $op && $op ne '';
	return vercmp($ver, $val) >= 0 if $op eq '>=';
	return vercmp($ver, $val) <= 0 if $op eq '<=';
	return vercmp($ver, $val) >  0 if $op eq '>';
	return vercmp($ver, $val) <  0 if $op eq '<';
	return vercmp($ver, $val) == 0 if $op eq '=';
	if($op eq '~')
	{
		my $pv = ver_parts($val);
		return 0 unless $pv;
		my $pver = ver_parts($ver);
		return 0 unless $pver;
		for my $i (0 .. $#{$pv->[0]})
		{
			my $x = $i < @{$pver->[0]} ? $pver->[0][$i] : 0;
			return 0 if $x != $pv->[0][$i];
		}
		return 1;
	}
	return 1;
}
 
# parse one dep/CLI token:
#   [%]name[:slot][{>=|<=|>|<|=|~}version][[flag,-flag,...]][::repo]
sub parse_dep_token {
	my ($tok) = @_;
	my ($tag, $name, $slot, $op, $val, $useraw, $repo) = ('', '', undef, undef, undef, undef, undef);
 
	# the slot portion allows '-' (unlike the version-constraint value just
	# after it): a compound slot -- pkg_slot_use joining several enabled
	# flags with '-', or a static compound slot like "12-glibc-znver3-O3"
	# -- is a documented convention (mplib::util::split_slot_key accepts
	# the same), so a dep token referencing one (e.g. "curl:ssl-lto")
	# must parse correctly instead of falling through to "unparsed bare
	# name" below.
	# the version-constraint value must accept a hyphen too (ver_parts
	# above documents and supports a "-rN" revision suffix, e.g.
	# "1.2.3-r1"), or a dep like "somelib>=2.0-r1" fails this whole regex
	# and silently falls through to "unparsed bare name" below, treating
	# ">=2.0-r1" as part of a literal package name instead of a version
	# constraint.
	# "[flag,-flag,...]" (PMS's own atom-suffix ordering: slot, then USE
	# deps, then repo, always in that order) between the version group
	# and "::repo": a bracketed, comma-separated list of USE flags this
	# DEPENDENCY must itself be built with -- "ssl" requires it enabled,
	# "-ssl" requires it disabled. deliberately NOT PMS's fuller "[flag=]"/
	# "[flag?]" forms (match/conditional-on the CONSUMER's own flag state)
	# -- those need the consuming port's own enabled_use() state threaded
	# through parsing itself, which this pure string-parsing function has
	# no access to at all; a plain require-enabled/require-disabled pair
	# covers the common case cleanly without that. neither name/slot's own
	# char class permits '[' or ',', so this can't be confused with either.
	#
	# "::repo" last: unambiguous against everything before it since none
	# of their char classes permit ':'. this DOES change one pre-existing
	# case: "x::y" used to fall through to "unparsed bare name" (name=
	# "x::y", the old deptok_double_colon test's own expectation, since a
	# single ':' followed by another ':' never matched the old slot-only
	# grammar) -- it now correctly parses as name="x", repo="y", which is
	# the whole point of adding this. "a:b:c" (single colons, never a
	# literal "::" anywhere) still falls through unparsed, unaffected.
	if($tok =~ /^(%?)([A-Za-z0-9_.+-]+?)(?::([A-Za-z0-9_.-]+))?(?:(>=|<=|>|<|=|~)([A-Za-z0-9_.-]+))?(?:\[([A-Za-z0-9_,-]+)\])?(?:::([A-Za-z0-9_.-]+))?$/)
	{
		($tag, $name, $slot, $op, $val, $useraw, $repo) = ($1, $2, $3, $4, $5, $6, $7);
	}
	else
	{
		$name = $tok;
	}
	# {flag=>1} for a plain "flag" (require enabled), {flag=>0} for
	# "-flag" (require disabled) -- a bare hash rather than an arrayref
	# of {flag,want} pairs since every caller only ever needs "does this
	# atom require a specific state for THIS flag", never the original
	# order (unlike, say, effective_deps' own ordered dep lists).
	my $use;
	if(defined $useraw && $useraw ne '')
	{
		$use = {};
		for my $tok2 (split /,/, $useraw)
		{
			if($tok2 =~ /^-(.+)$/) { $use->{$1} = 0; }
			else                   { $use->{$tok2} = 1; }
		}
	}
	return { istag => ($tag eq '%'), name => $name, slot => $slot, op => $op, val => $val, use => $use, repo => $repo };
}
 
1;