| Index: third_party/dpkg-dev/scripts/Dpkg/Substvars.pm
|
| diff --git a/third_party/dpkg-dev/scripts/Dpkg/Substvars.pm b/third_party/dpkg-dev/scripts/Dpkg/Substvars.pm
|
| new file mode 100644
|
| index 0000000000000000000000000000000000000000..e287dc9f8ccdba56f1e525df532d735bc6190ab8
|
| --- /dev/null
|
| +++ b/third_party/dpkg-dev/scripts/Dpkg/Substvars.pm
|
| @@ -0,0 +1,337 @@
|
| +# Copyright © 2006-2009,2012 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/>.
|
| +
|
| +package Dpkg::Substvars;
|
| +
|
| +use strict;
|
| +use warnings;
|
| +
|
| +our $VERSION = '1.02';
|
| +
|
| +use Dpkg ();
|
| +use Dpkg::Arch qw(get_host_arch);
|
| +use Dpkg::ErrorHandling;
|
| +use Dpkg::Gettext;
|
| +
|
| +use Carp;
|
| +use POSIX qw(:errno_h);
|
| +
|
| +use parent qw(Dpkg::Interface::Storable);
|
| +
|
| +my $maxsubsts = 50;
|
| +
|
| +=encoding utf8
|
| +
|
| +=head1 NAME
|
| +
|
| +Dpkg::Substvars - handle variable substitution in strings
|
| +
|
| +=head1 DESCRIPTION
|
| +
|
| +It provides some an object which is able to substitute variables in
|
| +strings.
|
| +
|
| +=head1 METHODS
|
| +
|
| +=over 8
|
| +
|
| +=item my $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,
|
| + },
|
| + used => {},
|
| + msg_prefix => '',
|
| + };
|
| + $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//;
|
| + bless $self, $class;
|
| + $self->mark_as_used($_) 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) = @_;
|
| + $self->{vars}{$key} = $value;
|
| +}
|
| +
|
| +=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);
|
| + $self->mark_as_used($key);
|
| +}
|
| +
|
| +=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->{used}{$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->{used}{$key}++;
|
| +}
|
| +
|
| +=item $s->no_warn($key)
|
| +
|
| +Obsolete function, use mark_as_used() instead.
|
| +
|
| +=cut
|
| +
|
| +sub no_warn {
|
| + my ($self, $key) = @_;
|
| + carp 'obsolete no_warn() function, use mark_as_used() instead';
|
| + $self->mark_as_used($key);
|
| +}
|
| +
|
| +=item $s->load($file)
|
| +
|
| +Add new substitutions read from $file.
|
| +
|
| +=item $s->parse($fh, $desc)
|
| +
|
| +Add new substitutions read from the filehandle. $desc is used to identify
|
| +the filehandle in error messages.
|
| +
|
| +=cut
|
| +
|
| +sub parse {
|
| + my ($self, $fh, $varlistfile) = @_;
|
| + binmode($fh);
|
| + while (<$fh>) {
|
| + 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, $.);
|
| + }
|
| + $self->{vars}{$1} = $2;
|
| + }
|
| +}
|
| +
|
| +=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]+$//;
|
| +
|
| + $self->{vars}{'binary:Version'} = $binaryversion;
|
| + $self->{vars}{'source:Version'} = $sourceversion;
|
| + $self->{vars}{'source:Upstream-Version'} = $sourceversion;
|
| + $self->{vars}{'source:Upstream-Version'} =~ s/-[^-]*$//;
|
| +
|
| + # XXX: Source-Version is now deprecated, remove in the future.
|
| + $self->{vars}{'Source-Version'} = $binaryversion;
|
| +
|
| + $self->mark_as_used($_) foreach qw/binary:Version source:Version source:Upstream-Version Source-Version/;
|
| +}
|
| +
|
| +=item $s->set_arch_substvars()
|
| +
|
| +Defines architecture variables: ${Arch}.
|
| +
|
| +This will never be warned about when unused.
|
| +
|
| +=cut
|
| +
|
| +sub set_arch_substvars {
|
| + my ($self) = @_;
|
| +
|
| + $self->set_as_used('Arch', get_host_arch());
|
| +}
|
| +
|
| +=item $newstring = $s->substvars($string)
|
| +
|
| +Substitutes variables in $string and return the result in $newstring.
|
| +
|
| +=cut
|
| +
|
| +sub substvars {
|
| + my ($self, $v, %opts) = @_;
|
| + my $lhs;
|
| + my $vn;
|
| + my $rhs = '';
|
| + my $count = 0;
|
| + $opts{msg_prefix} = $self->{msg_prefix} unless exists $opts{msg_prefix};
|
| + $opts{no_warn} = 0 unless exists $opts{no_warn};
|
| +
|
| + while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) {
|
| + # If we have consumed more from the leftover data, then
|
| + # reset the recursive counter.
|
| + $count = 0 if (length($3) < length($rhs));
|
| +
|
| + if ($count >= $maxsubsts) {
|
| + error($opts{msg_prefix} .
|
| + _g("too many substitutions - recursive ? - in \`%s'"), $v);
|
| + }
|
| + $lhs = $1; $vn = $2; $rhs = $3;
|
| + if (defined($self->{vars}{$vn})) {
|
| + $v = $lhs . $self->{vars}{$vn} . $rhs;
|
| + $self->mark_as_used($vn);
|
| + $count++;
|
| + } else {
|
| + warning($opts{msg_prefix} . _g('unknown substitution variable ${%s}'),
|
| + $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} unless exists $opts{msg_prefix};
|
| +
|
| + foreach my $vn (keys %{$self->{vars}}) {
|
| + next if $self->{used}{$vn};
|
| + # 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('unused substitution variable ${%s}'),
|
| + $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->save($file)
|
| +
|
| +Store all substitutions variables except the automatic ones in the
|
| +indicated file.
|
| +
|
| +=item "$s"
|
| +
|
| +Return a string representation of all substitutions variables except the
|
| +automatic ones.
|
| +
|
| +=item $str = $s->output($fh)
|
| +
|
| +Print all substitutions variables except the automatic ones in the
|
| +filehandle and return the content written.
|
| +
|
| +=cut
|
| +
|
| +sub output {
|
| + my ($self, $fh) = @_;
|
| + my $str = '';
|
| + # Store all non-automatic substitutions only
|
| + foreach my $vn (sort keys %{$self->{vars}}) {
|
| + next if /^(?:(?:dpkg|source|binary):(?:Source-)?Version|Space|Tab|Newline|Arch|Source-Version|F:.+)$/;
|
| + my $line = "$vn=" . $self->{vars}{$vn} . "\n";
|
| + print { $fh } $line if defined $fh;
|
| + $str .= $line;
|
| + }
|
| + return $str;
|
| +}
|
| +
|
| +=back
|
| +
|
| +=head1 AUTHOR
|
| +
|
| +Raphaël Hertzog <hertzog@debian.org>.
|
| +
|
| +=cut
|
| +
|
| +1;
|
|
|