Adding upstream version 1.22.4.upstream/1.22.4

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 503 insertions, 0 deletions

diff --git a/scripts/Dpkg/Substvars.pm b/scripts/Dpkg/Substvars.pm
new file mode 100644
index 0000000..cf55194
--- /dev/null
+++ b/scripts/Dpkg/Substvars.pm
@@ -0,0 +1,503 @@
+# Copyright © 2006-2009, 2012-2020, 2022 Guillem Jover <guillem@debian.org>
+# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Substvars - handle variable substitution in strings
+
+=head1 DESCRIPTION
+
+It provides a class which is able to substitute variables in strings.
+
+=cut
+
+package Dpkg::Substvars 2.01;
+
+use strict;
+use warnings;
+
+use Dpkg ();
+use Dpkg::Arch qw(get_host_arch);
+use Dpkg::Vendor qw(get_current_vendor);
+use Dpkg::Version;
+use Dpkg::ErrorHandling;
+use Dpkg::Gettext;
+
+use parent qw(Dpkg::Interface::Storable);
+
+my $maxsubsts = 50;
+
+use constant {
+    SUBSTVAR_ATTR_USED => 1,
+    SUBSTVAR_ATTR_AUTO => 2,
+    SUBSTVAR_ATTR_AGED => 4,
+    SUBSTVAR_ATTR_OPT  => 8,
+    SUBSTVAR_ATTR_DEEP => 16,
+};
+
+=head1 METHODS
+
+=over 8
+
+=item $s = Dpkg::Substvars->new($file)
+
+Create a new object that can do substitutions. By default it contains
+generic substitutions like ${Newline}, ${Space}, ${Tab}, ${dpkg:Version}
+and ${dpkg:Upstream-Version}.
+
+Additional substitutions will be read from the $file passed as parameter.
+
+It keeps track of which substitutions were actually used (only counting
+substvars(), not get()), and warns about unused substvars when asked to. The
+substitutions that are always present are not included in these warnings.
+
+=cut
+
+sub new {
+    my ($this, $arg) = @_;
+    my $class = ref($this) || $this;
+    my $self = {
+        vars => {
+            'Newline' => "\n",
+            'Space' => ' ',
+            'Tab' => "\t",
+            'dpkg:Version' => $Dpkg::PROGVERSION,
+            'dpkg:Upstream-Version' => $Dpkg::PROGVERSION,
+            },
+        attr => {},
+	msg_prefix => '',
+    };
+    $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//;
+    bless $self, $class;
+
+    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
+    $self->{attr}{$_} = $attr foreach keys %{$self->{vars}};
+    if ($arg) {
+        $self->load($arg) if -e $arg;
+    }
+    return $self;
+}
+
+=item $s->set($key, $value)
+
+Add/replace a substitution.
+
+=cut
+
+sub set {
+    my ($self, $key, $value, $attr) = @_;
+
+    $attr //= 0;
+    $attr |= SUBSTVAR_ATTR_DEEP if length $value && $value =~ m{\$};
+
+    $self->{vars}{$key} = $value;
+    $self->{attr}{$key} = $attr;
+}
+
+=item $s->set_as_used($key, $value)
+
+Add/replace a substitution and mark it as used (no warnings will be produced
+even if unused).
+
+=cut
+
+sub set_as_used {
+    my ($self, $key, $value) = @_;
+
+    $self->set($key, $value, SUBSTVAR_ATTR_USED);
+}
+
+=item $s->set_as_auto($key, $value)
+
+Add/replace a substitution and mark it as used and automatic (no warnings
+will be produced even if unused).
+
+=cut
+
+sub set_as_auto {
+    my ($self, $key, $value) = @_;
+
+    $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO);
+}
+
+=item $s->get($key)
+
+Get the value of a given substitution.
+
+=cut
+
+sub get {
+    my ($self, $key) = @_;
+    return $self->{vars}{$key};
+}
+
+=item $s->delete($key)
+
+Remove a given substitution.
+
+=cut
+
+sub delete {
+    my ($self, $key) = @_;
+    delete $self->{attr}{$key};
+    return delete $self->{vars}{$key};
+}
+
+=item $s->mark_as_used($key)
+
+Prevents warnings about a unused substitution, for example if it is provided by
+default.
+
+=cut
+
+sub mark_as_used {
+    my ($self, $key) = @_;
+    $self->{attr}{$key} |= SUBSTVAR_ATTR_USED;
+}
+
+=item $s->parse($fh, $desc)
+
+Add new substitutions read from the filehandle. $desc is used to identify
+the filehandle in error messages.
+
+Returns the number of substitutions that have been parsed with success.
+
+=cut
+
+sub parse {
+    my ($self, $fh, $varlistfile) = @_;
+    my $count = 0;
+    local $_;
+
+    binmode($fh);
+    while (<$fh>) {
+        my $attr;
+
+	next if m/^\s*\#/ || !m/\S/;
+	s/\s*\n$//;
+	if (! m/^(\w[-:0-9A-Za-z]*)(\?)?\=(.*)$/) {
+	    error(g_('bad line in substvars file %s at line %d'),
+		  $varlistfile, $.);
+	}
+        ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
+        if (defined $2) {
+            $attr = (SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_OPT) if $2 eq '?';
+        }
+        $self->set($1, $3, $attr);
+        $count++;
+    }
+
+    return $count
+}
+
+=item $s->load($file)
+
+Add new substitutions read from $file.
+
+=item $s->set_version_substvars($sourceversion, $binaryversion)
+
+Defines ${binary:Version}, ${source:Version} and
+${source:Upstream-Version} based on the given version strings.
+
+These will never be warned about when unused.
+
+=cut
+
+sub set_version_substvars {
+    my ($self, $sourceversion, $binaryversion) = @_;
+
+    # Handle old function signature taking only one argument.
+    $binaryversion //= $sourceversion;
+
+    # For backwards compatibility on binNMUs that do not use the Binary-Only
+    # field on the changelog, always fix up the source version.
+    $sourceversion =~ s/\+b[0-9]+$//;
+
+    my $vs = Dpkg::Version->new($sourceversion, check => 1);
+    if (not defined $vs) {
+        error(g_('invalid source version %s'), $sourceversion);
+    }
+    my $upstreamversion = $vs->as_string(omit_revision => 1);
+
+    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
+
+    $self->set('binary:Version', $binaryversion, $attr);
+    $self->set('source:Version', $sourceversion, $attr);
+    $self->set('source:Upstream-Version', $upstreamversion, $attr);
+
+    # XXX: Source-Version is now obsolete, remove in 1.19.x.
+    $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED);
+}
+
+=item $s->set_arch_substvars()
+
+Defines architecture variables: ${Arch}.
+
+This will never be warned about when unused.
+
+=cut
+
+sub set_arch_substvars {
+    my $self = shift;
+
+    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
+
+    $self->set('Arch', get_host_arch(), $attr);
+}
+
+=item $s->set_vendor_substvars()
+
+Defines vendor variables: ${vendor:Name} and ${vendor:Id}.
+
+These will never be warned about when unused.
+
+=cut
+
+sub set_vendor_substvars {
+    my ($self, $desc) = @_;
+
+    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
+
+    my $vendor = get_current_vendor();
+    $self->set('vendor:Name', $vendor, $attr);
+    $self->set('vendor:Id', lc $vendor, $attr);
+}
+
+=item $s->set_desc_substvars()
+
+Defines source description variables: ${source:Synopsis} and
+${source:Extended-Description}.
+
+These will never be warned about when unused.
+
+=cut
+
+sub set_desc_substvars {
+    my ($self, $desc) = @_;
+
+    my ($synopsis, $extended) = split /\n/, $desc, 2;
+
+    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
+
+    $self->set('source:Synopsis', $synopsis, $attr);
+    $self->set('source:Extended-Description', $extended, $attr);
+}
+
+=item $s->set_field_substvars($ctrl, $prefix)
+
+Defines field variables from a L<Dpkg::Control> object, with each variable
+having the form "${$prefix:$field}".
+
+They will never be warned about when unused.
+
+=cut
+
+sub set_field_substvars {
+    my ($self, $ctrl, $prefix) = @_;
+
+    foreach my $field (keys %{$ctrl}) {
+        $self->set_as_auto("$prefix:$field", $ctrl->{$field});
+    }
+}
+
+=item $newstring = $s->substvars($string)
+
+Substitutes variables in $string and return the result in $newstring.
+
+=cut
+
+sub substvars {
+    my ($self, $v, %opts) = @_;
+    my %seen;
+    my $lhs;
+    my $vn;
+    my $rhs = '';
+    $opts{msg_prefix} //= $self->{msg_prefix};
+    $opts{no_warn} //= 0;
+
+    while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) {
+        $lhs = $1;
+        $vn = $2;
+        $rhs = $3;
+
+        if (defined($self->{vars}{$vn})) {
+            $v = $lhs . $self->{vars}{$vn} . $rhs;
+            $self->mark_as_used($vn);
+
+            if ($self->{attr}{$vn} & SUBSTVAR_ATTR_DEEP) {
+                $seen{$vn}++;
+            }
+            if (exists $seen{$vn} && $seen{$vn} >= $maxsubsts) {
+                error($opts{msg_prefix} .
+                      g_("too many \${%s} substitutions (recursive?) in '%s'"),
+                      $vn, $v);
+            }
+
+            if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) {
+                error($opts{msg_prefix} .
+                      g_('obsolete substitution variable ${%s}'), $vn);
+            }
+        } else {
+            warning($opts{msg_prefix} .
+                    g_('substitution variable ${%s} used, but is not defined'),
+	            $vn) unless $opts{no_warn};
+            $v = $lhs . $rhs;
+        }
+    }
+    return $v;
+}
+
+=item $s->warn_about_unused()
+
+Issues warning about any variables that were set, but not used.
+
+=cut
+
+sub warn_about_unused {
+    my ($self, %opts) = @_;
+    $opts{msg_prefix} //= $self->{msg_prefix};
+
+    foreach my $vn (sort keys %{$self->{vars}}) {
+        next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED;
+        # Empty substitutions variables are ignored on the basis
+        # that they are not required in the current situation
+        # (example: debhelper's misc:Depends in many cases)
+        next if $self->{vars}{$vn} eq '';
+        warning($opts{msg_prefix} .
+                g_('substitution variable ${%s} unused, but is defined'),
+                $vn);
+    }
+}
+
+=item $s->set_msg_prefix($prefix)
+
+Define a prefix displayed before all warnings/error messages output
+by the module.
+
+=cut
+
+sub set_msg_prefix {
+    my ($self, $prefix) = @_;
+    $self->{msg_prefix} = $prefix;
+}
+
+=item $s->filter(remove => $rmfunc)
+
+=item $s->filter(keep => $keepfun)
+
+Filter the substitution variables, either removing or keeping all those
+that return true when $rmfunc->($key) or $keepfunc->($key) is called.
+
+=cut
+
+sub filter {
+    my ($self, %opts) = @_;
+
+    my $remove = $opts{remove} // sub { 0 };
+    my $keep = $opts{keep} // sub { 1 };
+
+    foreach my $vn (keys %{$self->{vars}}) {
+        $self->delete($vn) if $remove->($vn) or not $keep->($vn);
+    }
+}
+
+=item "$s"
+
+Return a string representation of all substitutions variables except the
+automatic ones.
+
+=item $str = $s->output([$fh])
+
+Return all substitutions variables except the automatic ones. If $fh
+is passed print them into the filehandle.
+
+=cut
+
+sub output {
+    my ($self, $fh) = @_;
+    my $str = '';
+    # Store all non-automatic substitutions only
+    foreach my $vn (sort keys %{$self->{vars}}) {
+	next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO;
+        my $op = $self->{attr}{$vn} & SUBSTVAR_ATTR_OPT ? '?=' : '=';
+        my $line = "$vn$op" . $self->{vars}{$vn} . "\n";
+	print { $fh } $line if defined $fh;
+	$str .= $line;
+    }
+    return $str;
+}
+
+=item $s->save($file)
+
+Store all substitutions variables except the automatic ones in the
+indicated file.
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 2.01 (dpkg 1.21.8)
+
+New feature: Add support for optional substitution variables.
+
+=head2 Version 2.00 (dpkg 1.20.0)
+
+Remove method: $s->no_warn().
+
+New method: $s->set_vendor_substvars().
+
+=head2 Version 1.06 (dpkg 1.19.0)
+
+New method: $s->set_desc_substvars().
+
+=head2 Version 1.05 (dpkg 1.18.11)
+
+Obsolete substvar: Emit an error on Source-Version substvar usage.
+
+New return: $s->parse() now returns the number of parsed substvars.
+
+New method: $s->set_field_substvars().
+
+=head2 Version 1.04 (dpkg 1.18.0)
+
+New method: $s->filter().
+
+=head2 Version 1.03 (dpkg 1.17.11)
+
+New method: $s->set_as_auto().
+
+=head2 Version 1.02 (dpkg 1.16.5)
+
+New argument: Accept a $binaryversion in $s->set_version_substvars(),
+passing a single argument is still supported.
+
+New method: $s->mark_as_used().
+
+Deprecated method: $s->no_warn(), use $s->mark_as_used() instead.
+
+=head2 Version 1.01 (dpkg 1.16.4)
+
+New method: $s->set_as_used().
+
+=head2 Version 1.00 (dpkg 1.15.6)
+
+Mark the module as public.
+
+=cut
+
+1;