382 lines
10 KiB
Perl
382 lines
10 KiB
Perl
# $OpenBSD: ReverseSubst.pm,v 1.23 2023/05/29 19:05:33 espie Exp $
|
|
# Copyright (c) 2018 Marc Espie <espie@openbsd.org>
|
|
#
|
|
# Permission to use, copy, modify, and distribute this software for any
|
|
# purpose with or without fee is hereby granted, provided that the above
|
|
# copyright notice and this permission notice appear in all copies.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
|
|
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
|
|
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
|
|
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
|
|
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
|
|
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
|
|
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
|
|
|
|
use v5.36;
|
|
|
|
# prefix and suffix have a default meaning, and then a special meaning
|
|
# for some element classes
|
|
package OpenBSD::PackingElement;
|
|
sub unsubst_prefix($self, $string, $v, $k2)
|
|
{
|
|
|
|
# if we start with a keyword, substitute after it
|
|
if ($string =~ m/^\@/) {
|
|
$string =~ s/^(\@\S+\s+)\Q$v\E/$1\$\{$k2\}/;
|
|
} else {
|
|
$string =~ s/^\Q$v\E/\$\{$k2\}/;
|
|
}
|
|
return $string;
|
|
}
|
|
|
|
sub unsubst_suffix($self, $string, $v, $k2)
|
|
{
|
|
$string =~ s/\Q$v\E$/\$\{$k2\}/;
|
|
return $string;
|
|
}
|
|
|
|
sub unsubst_version($self, $string, $v, $k2)
|
|
{
|
|
# we have to loop over the string because negative assertions are
|
|
# hard for non constant width strings
|
|
my $done = '';
|
|
# so remove each $v
|
|
while ($string =~ s/(.*?)\Q$v\E//) {
|
|
$done .= $1;
|
|
# if it's in the middle of a larger version string, nope
|
|
if ($done =~ m/\d$/ || $string =~ m/^\d/ ||
|
|
# also do dewey numbers if $v is also one
|
|
($v =~ m/\./ &&
|
|
($done =~ m/\d\.$/ || $string =~ m/^\.\d/))) {
|
|
$done .= $v;
|
|
} else {
|
|
# otherwise it's okay
|
|
$done .= "\${$k2}";
|
|
}
|
|
}
|
|
return $done.$string;
|
|
}
|
|
|
|
sub assert_valid_prefix($self, $subst, $string, $unsubst)
|
|
{
|
|
return if !defined $unsubst;
|
|
my $s2 = $subst->do($unsubst);
|
|
$s2 =~ s,/+$,/,;
|
|
die "Not a valid unsubst '$unsubst' vs '$string' vs '$s2'"
|
|
if $string !~ m/^\Q$s2\E/;
|
|
}
|
|
|
|
# $self->adjust($rstring): modify the pointed string after subst if needed
|
|
sub adjust($, $)
|
|
{
|
|
}
|
|
|
|
package OpenBSD::PackingElement::Action;
|
|
sub unsubst_prefix($self, $string, $v, $k2)
|
|
{
|
|
|
|
$string =~ s/([\s:=])\Q$v\E/$1\$\{$k2\}/g;
|
|
return $self->SUPER::unsubst_prefix($string, $v, $k2);
|
|
}
|
|
|
|
sub unsubst_suffix($self, $string, $v, $k2)
|
|
{
|
|
$string =~ s/\Q$v\E([\s:=])/\$\{$k2\}$1/g;
|
|
return $self->SUPER::unsubst_suffix($string, $v, $k2);
|
|
}
|
|
|
|
|
|
package OpenBSD::PackingElement::Manpage;
|
|
sub unsubst_suffix($self, $string, $v, $k2)
|
|
{
|
|
$string =~ s/\Q$v\E(\.[^\.]+(\.gz|\.Z)?)$/\$\{$k2\}$1/;
|
|
return $self->SUPER::unsubst_suffix($string, $v, $k2);
|
|
}
|
|
|
|
# allow version unsubst not affecting the manpage part
|
|
sub unsubst_version($self, $string, $v, $k2)
|
|
{
|
|
if ($string =~ m/(.*)(\.[^\.]+(\.gz|\.Z)?)$/) {
|
|
return $self->SUPER::unsubst_version($1, $v, $k2).$2;
|
|
} else {
|
|
return $self->SUPER::unsubst_version($string, $v, $k2);
|
|
}
|
|
}
|
|
|
|
package OpenBSD::PackingElement::Lib;
|
|
sub assert_valid_prefix($self, $subst, $string, $unsubst)
|
|
{
|
|
# libraries are already partially subst'd at this stage
|
|
$self->SUPER::assert_valid_prefix($subst, $subst->do($string), $unsubst);
|
|
}
|
|
|
|
package OpenBSD::PackingElement::DirBase;
|
|
|
|
# make sure dirobjects show an explicit / at end, even added after the subst
|
|
sub adjust($self, $rstring)
|
|
{
|
|
$$rstring =~ s,([^/])$,$1/,;
|
|
}
|
|
|
|
package Forwarder;
|
|
# perfect forwarding
|
|
sub AUTOLOAD
|
|
{
|
|
our $AUTOLOAD;
|
|
my $fullsub = $AUTOLOAD;
|
|
(my $sub = $fullsub) =~ s/.*:://o;
|
|
return if $sub eq 'DESTROY'; # special case
|
|
no strict "refs";
|
|
*$fullsub = sub {
|
|
my $self = shift;
|
|
$self->{delegate}->$sub(@_);
|
|
};
|
|
goto &$fullsub;
|
|
}
|
|
|
|
# this is the code that does all the heavy lifting finding variables
|
|
# to put into plists
|
|
|
|
package OpenBSD::ReverseSubst;
|
|
our @ISA = qw(Forwarder);
|
|
|
|
# this hijacks the "normal" subst code, but it does gather some useful
|
|
# statistics
|
|
sub new($class, $state)
|
|
{
|
|
my $o = bless {delegate => OpenBSD::Subst->new,
|
|
# count the number of times we see each value. More than once,
|
|
# hard to figure out WHICH one to backsubst
|
|
count => {},
|
|
# record that a variable is actually used. Then if we see the
|
|
# string and no backsubst, it's probably intentional
|
|
used => {},
|
|
# special variables we won't add in substitutions
|
|
dont_backsubst => {},
|
|
# list of actual variables we care about, e.g., ignored stuff
|
|
# and whatnot
|
|
l => [],
|
|
# variables that expand to nothing have specific handling
|
|
lempty => [],
|
|
# variables that expand to something that looks like a version
|
|
# number won't substitute in the middle of numbers by default
|
|
isversion => {},
|
|
# under some cases, some variables are a priority
|
|
disregard_count => {},
|
|
# to be able to inject @comment conditionally on some other
|
|
# variables
|
|
maybe_comment => $state->{maybe_comment},
|
|
}, $class;
|
|
for my $k (qw(dont_backsubst start_only suffix_only no_version
|
|
maybe_ignored)) {
|
|
if (defined $state->{$k}) {
|
|
for my $v (@{$state->{$k}}) {
|
|
$o->{$k}{$v} = 1;
|
|
}
|
|
}
|
|
}
|
|
return $o;
|
|
}
|
|
|
|
sub remove_ignored_vars($self, $s)
|
|
{
|
|
for my $v (keys %{$self->{maybe_ignored}}) {
|
|
while ($s =~ s/\$\{\Q$v\E\}//) {}
|
|
}
|
|
$s =~ s,//,/,g;
|
|
return $s;
|
|
}
|
|
|
|
# those are actually just passed thru to pkg_create for special
|
|
# purposes, we don't need to consider them at all
|
|
my $ignore = {
|
|
COMMENT => 1,
|
|
MAINTAINER => 1,
|
|
PERMIT_PACKAGE_CDROM => 1,
|
|
PERMIT_PACKAGE_FTP => 1,
|
|
HOMEPAGE => 1,
|
|
};
|
|
|
|
sub add($self, $k, $v)
|
|
{
|
|
my $k2 = $k;
|
|
$k2 =~ s/\^//;
|
|
|
|
# XXX whatever is before FLAVORS is internal pkg_create options
|
|
# such as flavor conditionals, so ignore them
|
|
if ($k eq 'FLAVORS') {
|
|
$self->{l} = [];
|
|
$self->{count} = {};
|
|
$self->{lempty} = [];
|
|
}
|
|
if ($ignore->{$k2} || $k2 =~ m/^LIB\S+_VERSION$/) {
|
|
} else {
|
|
# any variable that expands to @comment should never get
|
|
# added where it wasn't already
|
|
if ($v =~ m/^\@comment\s*$/) {
|
|
$self->{dont_backsubst}{$k2} = 1;
|
|
}
|
|
if ($v eq '') {
|
|
unshift(@{$self->{lempty}}, $k);
|
|
} else {
|
|
if ($v =~ m/^[\d\.]+$/ && !$self->{no_version}{$k2}) {
|
|
$self->{isversion}{$k2} = 1;
|
|
}
|
|
unshift(@{$self->{l}}, $k);
|
|
}
|
|
# if two variables expand to the same thing, but one is
|
|
# marked "don't backsubst", then we should backsubst the other
|
|
$self->{count}{$v} //= 0;
|
|
if (!$self->{dont_backsubst}{$k2}) {
|
|
$self->{count}{$v}++;
|
|
}
|
|
}
|
|
$self->{delegate}->add($k, $v);
|
|
}
|
|
|
|
sub value($self, $k)
|
|
{
|
|
$k =~ s/\^//;
|
|
return $self->{delegate}->value($k);
|
|
}
|
|
|
|
# heuristics to figure out which substitutions we should never add:
|
|
# some are "hard-coded", others are just ambiguous
|
|
sub never_add($self, $k)
|
|
{
|
|
if (!$self->{disregard_count}{$k} &&
|
|
$self->{count}{$self->value($k)} > 1) {
|
|
return 1;
|
|
} else {
|
|
return $self->{dont_backsubst}{$k};
|
|
}
|
|
}
|
|
|
|
# this can't use the "magic delegation" if reversesubt is to work properly
|
|
sub parse_option # forwarder
|
|
{
|
|
&OpenBSD::Subst::parse_option;
|
|
}
|
|
|
|
|
|
# after we got all variables, but before performing backsubst
|
|
sub finalize($subst)
|
|
{
|
|
# sort non empty variables by reverse length
|
|
$subst->{vars} = [sort
|
|
{length($subst->value($b)) <=> length($subst->value($a))}
|
|
@{$subst->{l}}];
|
|
# remove the ambiguity of PREFIX vs LOCALBASE
|
|
my $v = $subst->value('PREFIX');
|
|
if ($v eq $subst->value('LOCALBASE') &&
|
|
$subst->{count}{$v} == 2) {
|
|
$subst->{disregard_count}{PREFIX} = 1;
|
|
}
|
|
}
|
|
|
|
# some unsubst variables have special cases
|
|
sub special_case($subst, $k, $v, $string)
|
|
{
|
|
if ($k eq 'FULLPKGNAME' && $string =~ m,^share/doc/pkg-readmes/,) {
|
|
return 1;
|
|
}
|
|
if ($k eq 'PKGSTEM' && $string =~ m,^share/doc/pkg-readmes/,) {
|
|
return 1;
|
|
}
|
|
if ($k eq 'MACHINE_ARCH' && $string =~ m/\Q$v\E-openbsd/) {
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
sub unsubst_non_empty_var($subst, $string, $k, $unsubst, $context)
|
|
{
|
|
my $k2 = $k;
|
|
$k2 =~ s/^\^//;
|
|
my $v = $subst->value($k2);
|
|
# don't add subst on THOSE variables
|
|
# TODO ARCH, MACHINE_ARCH could happen, but only with word
|
|
# boundary contexts
|
|
if ($subst->never_add($k2)) {
|
|
unless (defined $unsubst &&
|
|
$unsubst =~ m/\$\{\Q$k2\E\}/) {
|
|
return $string
|
|
unless $subst->special_case($k2, $v, $string);
|
|
}
|
|
} else {
|
|
# Heuristics: if the variable is already known AND was
|
|
# not used already, AND the value was in unsubst
|
|
# then we don't add a new substitution
|
|
return $string if defined $unsubst &&
|
|
$subst->{used}{$k2} &&
|
|
$unsubst !~ m/\$\{$k2\}/ &&
|
|
$unsubst =~ m/\Q$v\E/;
|
|
}
|
|
|
|
if ($k =~ m/^\^(.*)$/ || $subst->{start_only}{$k}) {
|
|
$string = $context->unsubst_prefix($string, $v, $k2);
|
|
} elsif ($subst->{suffix_only}{$k}) {
|
|
$string = $context->unsubst_suffix($string, $v, $k2);
|
|
} else {
|
|
if ($subst->{isversion}{$k2}) {
|
|
$string = $context->unsubst_version($string, $v, $k2);
|
|
} else {
|
|
$string =~ s/\Q$v\E/\$\{$k2\}/g;
|
|
}
|
|
}
|
|
return $string;
|
|
}
|
|
|
|
sub do_empty_backsubst($subst, $string, $unsubst)
|
|
{
|
|
# this part will be done repeatedly
|
|
my $old;
|
|
do {
|
|
$old = $string;
|
|
for my $k (@{$subst->{lempty}}) {
|
|
my $k2 = $k;
|
|
$k2 =~ s/^\^//;
|
|
if ($unsubst =~ m/^(.*)\$\{$k2\}/) {
|
|
my $prefix = $1;
|
|
# XXX avoid infinite loop
|
|
next if $string =~ m/\Q$prefix\E\$\{\Q$k2\E\}/;
|
|
$string =~ s/^\Q$prefix\E/$prefix\$\{$k2\}/;
|
|
}
|
|
# TODO we could also try based on suffixes ?
|
|
}
|
|
} while ($old ne $string);
|
|
return $string;
|
|
}
|
|
|
|
# create actual reverse substitution. $unsubst is the string already stored
|
|
# in an existing plist, to figure out ambiguous cases and empty substs
|
|
sub do_backsubst($subst, $string, $unsubst = undef,
|
|
$context = 'OpenBSD::PackingElement')
|
|
{
|
|
|
|
# note that unsubst doesn't necessarily match the whole of subst
|
|
# (in new elements, it can be stolen from approximate matches)
|
|
# but it should always be a legitimate prefix of subst
|
|
#$context->assert_valid_prefix($subst, $string, $unsubst);
|
|
|
|
if (!defined $subst->{vars}) {
|
|
$subst->finalize;
|
|
}
|
|
for my $k (@{$subst->{vars}}) {
|
|
$string = $subst->unsubst_non_empty_var($string, $k, $unsubst,
|
|
$context);
|
|
}
|
|
|
|
# we can't do empty subst without an unsubst;
|
|
# (stuff like @mode/@owner doesn't have an unsubst!)
|
|
if (defined $unsubst) {
|
|
$string = $subst->do_empty_backsubst($string, $unsubst);
|
|
}
|
|
$context->adjust(\$string);
|
|
|
|
return $string;
|
|
}
|
|
|
|
1;
|