File Coverage

File:Dpkg/Substvars.pm
Coverage:91.9%

linestmtbrancondsubpodtimecode
1# Copyright © 2006-2009, 2012-2020, 2022 Guillem Jover <guillem@debian.org>
2# Copyright © 2007-2010 Raphaël Hertzog <hertzog@debian.org>
3#
4# This program is free software; you can redistribute it and/or modify
5# it under the terms of the GNU General Public License as published by
6# the Free Software Foundation; either version 2 of the License, or
7# (at your option) any later version.
8#
9# This program is distributed in the hope that it will be useful,
10# but WITHOUT ANY WARRANTY; without even the implied warranty of
11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12# GNU General Public License for more details.
13#
14# You should have received a copy of the GNU General Public License
15# along with this program.  If not, see <https://www.gnu.org/licenses/>.
16
17package Dpkg::Substvars;
18
19
12
12
12
24
7
133
use strict;
20
12
12
12
18
7
236
use warnings;
21
22our $VERSION = '2.01';
23
24
12
12
12
18
12
84
use Dpkg ();
25
12
12
12
1357
11
372
use Dpkg::Arch qw(get_host_arch);
26
12
12
12
1572
11
293
use Dpkg::Vendor qw(get_current_vendor);
27
12
12
12
1656
11
438
use Dpkg::Version;
28
12
12
12
25
12
282
use Dpkg::ErrorHandling;
29
12
12
12
24
0
240
use Dpkg::Gettext;
30
31
12
12
12
13
12
17
use parent qw(Dpkg::Interface::Storable);
32
33my $maxsubsts = 50;
34
35=encoding utf8
36
37 - 45
=head1 NAME

Dpkg::Substvars - handle variable substitution in strings

=head1 DESCRIPTION

It provides a class which is able to substitute variables in strings.

=cut
46
47use constant {
48
12
9398
    SUBSTVAR_ATTR_USED => 1,
49    SUBSTVAR_ATTR_AUTO => 2,
50    SUBSTVAR_ATTR_AGED => 4,
51    SUBSTVAR_ATTR_OPT  => 8,
52
12
12
368
6
};
53
54 - 70
=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
71
72sub new {
73
24
1
42
    my ($this, $arg) = @_;
74
24
138
    my $class = ref($this) || $this;
75
24
245
    my $self = {
76        vars => {
77            'Newline' => "\n",
78            'Space' => ' ',
79            'Tab' => "\t",
80            'dpkg:Version' => $Dpkg::PROGVERSION,
81            'dpkg:Upstream-Version' => $Dpkg::PROGVERSION,
82            },
83        attr => {},
84        msg_prefix => '',
85    };
86
24
60
    $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//;
87
24
35
    bless $self, $class;
88
89
24
31
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
90
24
24
23
266
    $self->{attr}{$_} = $attr foreach keys %{$self->{vars}};
91
24
24
    if ($arg) {
92
3
15
        $self->load($arg) if -e $arg;
93    }
94
24
49
    return $self;
95}
96
97 - 101
=item $s->set($key, $value)

Add/replace a substitution.

=cut
102
103sub set {
104
312
1
222
    my ($self, $key, $value, $attr) = @_;
105
106
312
224
    $attr //= 0;
107
108
312
223
    $self->{vars}{$key} = $value;
109
312
279
    $self->{attr}{$key} = $attr;
110}
111
112 - 117
=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
118
119sub set_as_used {
120
1
1
1
    my ($self, $key, $value) = @_;
121
122
1
1
    $self->set($key, $value, SUBSTVAR_ATTR_USED);
123}
124
125 - 130
=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
131
132sub set_as_auto {
133
267
1
179
    my ($self, $key, $value) = @_;
134
135
267
186
    $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO);
136}
137
138 - 142
=item $s->get($key)

Get the value of a given substitution.

=cut
143
144sub get {
145
80
1
646
    my ($self, $key) = @_;
146
80
122
    return $self->{vars}{$key};
147}
148
149 - 153
=item $s->delete($key)

Remove a given substitution.

=cut
154
155sub delete {
156
23
1
13
    my ($self, $key) = @_;
157
23
13
    delete $self->{attr}{$key};
158
23
17
    return delete $self->{vars}{$key};
159}
160
161 - 166
=item $s->mark_as_used($key)

Prevents warnings about a unused substitution, for example if it is provided by
default.

=cut
167
168sub mark_as_used {
169
223
1
146
    my ($self, $key) = @_;
170
223
170
    $self->{attr}{$key} |= SUBSTVAR_ATTR_USED;
171}
172
173 - 180
=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
181
182sub parse {
183
4
1
4
    my ($self, $fh, $varlistfile) = @_;
184
4
1
    my $count = 0;
185
4
3
    local $_;
186
187
4
4
    binmode($fh);
188
4
16
    while (<$fh>) {
189
31
16
        my $attr;
190
191
31
56
        next if m/^\s*\#/ || !m/\S/;
192
25
39
        s/\s*\n$//;
193
25
34
        if (! m/^(\w[-:0-9A-Za-z]*)(\?)?\=(.*)$/) {
194
0
0
            error(g_('bad line in substvars file %s at line %d'),
195                  $varlistfile, $.);
196        }
197
25
18
        if (defined $2) {
198
1
1
            $attr = (SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_OPT) if $2 eq '?';
199        }
200
25
21
        $self->set($1, $3, $attr);
201
25
20
        $count++;
202    }
203
204
4
4
    return $count
205}
206
207 - 218
=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
219
220sub set_version_substvars {
221
3
1
4
    my ($self, $sourceversion, $binaryversion) = @_;
222
223    # Handle old function signature taking only one argument.
224
3
5
    $binaryversion //= $sourceversion;
225
226    # For backwards compatibility on binNMUs that do not use the Binary-Only
227    # field on the changelog, always fix up the source version.
228
3
5
    $sourceversion =~ s/\+b[0-9]+$//;
229
230
3
5
    my $vs = Dpkg::Version->new($sourceversion, check => 1);
231
3
4
    if (not defined $vs) {
232
0
0
        error(g_('invalid source version %s'), $sourceversion);
233    }
234
3
4
    my $upstreamversion = $vs->as_string(omit_revision => 1);
235
236
3
1
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
237
238
3
3
    $self->set('binary:Version', $binaryversion, $attr);
239
3
3
    $self->set('source:Version', $sourceversion, $attr);
240
3
2
    $self->set('source:Upstream-Version', $upstreamversion, $attr);
241
242    # XXX: Source-Version is now obsolete, remove in 1.19.x.
243
3
2
    $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED);
244}
245
246 - 252
=item $s->set_arch_substvars()

Defines architecture variables: ${Arch}.

This will never be warned about when unused.

=cut
253
254sub set_arch_substvars {
255
1
1
1
    my $self = shift;
256
257
1
0
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
258
259
1
2
    $self->set('Arch', get_host_arch(), $attr);
260}
261
262 - 268
=item $s->set_vendor_substvars()

Defines vendor variables: ${vendor:Name} and ${vendor:Id}.

These will never be warned about when unused.

=cut
269
270sub set_vendor_substvars {
271
1
1
1
    my ($self, $desc) = @_;
272
273
1
1
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
274
275
1
1
    my $vendor = get_current_vendor();
276
1
1
    $self->set('vendor:Name', $vendor, $attr);
277
1
1
    $self->set('vendor:Id', lc $vendor, $attr);
278}
279
280 - 287
=item $s->set_desc_substvars()

Defines source description variables: ${source:Synopsis} and
${source:Extended-Description}.

These will never be warned about when unused.

=cut
288
289sub set_desc_substvars {
290
1
1
1
    my ($self, $desc) = @_;
291
292
1
2
    my ($synopsis, $extended) = split /\n/, $desc, 2;
293
294
1
1
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
295
296
1
1
    $self->set('source:Synopsis', $synopsis, $attr);
297
1
1
    $self->set('source:Extended-Description', $extended, $attr);
298}
299
300 - 307
=item $s->set_field_substvars($ctrl, $prefix)

Defines field variables from a Dpkg::Control object, with each variable
having the form "${$prefix:$field}".

They will never be warned about when unused.

=cut
308
309sub set_field_substvars {
310
1
1
1
    my ($self, $ctrl, $prefix) = @_;
311
312
1
1
0
2
    foreach my $field (keys %{$ctrl}) {
313
3
2
        $self->set_as_auto("$prefix:$field", $ctrl->{$field});
314    }
315}
316
317 - 321
=item $newstring = $s->substvars($string)

Substitutes variables in $string and return the result in $newstring.

=cut
322
323sub substvars {
324
82
1
70
    my ($self, $v, %opts) = @_;
325
82
58
    my $lhs;
326    my $vn;
327
82
66
    my $rhs = '';
328
82
49
    my $count = 0;
329
82
274
    $opts{msg_prefix} //= $self->{msg_prefix};
330
82
184
    $opts{no_warn} //= 0;
331
332
82
167
    while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) {
333        # If we have consumed more from the leftover data, then
334        # reset the recursive counter.
335
223
259
        $count = 0 if (length($3) < length($rhs));
336
337
223
183
        if ($count >= $maxsubsts) {
338            error($opts{msg_prefix} .
339
0
0
                  g_("too many substitutions - recursive ? - in '%s'"), $v);
340        }
341
223
153
        $lhs = $1;
342
223
153
        $vn = $2;
343
223
167
        $rhs = $3;
344
223
161
        if (defined($self->{vars}{$vn})) {
345
222
239
            $v = $lhs . $self->{vars}{$vn} . $rhs;
346
222
205
            $self->mark_as_used($vn);
347
222
118
            $count++;
348
349
222
347
            if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) {
350                error($opts{msg_prefix} .
351
0
0
                      g_('obsolete substitution variable ${%s}'), $vn);
352            }
353        } else {
354            warning($opts{msg_prefix} .
355                    g_('substitution variable ${%s} used, but is not defined'),
356
1
2
                    $vn) unless $opts{no_warn};
357
1
16
            $v = $lhs . $rhs;
358        }
359    }
360
82
170
    return $v;
361}
362
363 - 367
=item $s->warn_about_unused()

Issues warning about any variables that were set, but not used.

=cut
368
369sub warn_about_unused {
370
2
1
1
    my ($self, %opts) = @_;
371
2
7
    $opts{msg_prefix} //= $self->{msg_prefix};
372
373
2
2
1
10
    foreach my $vn (sort keys %{$self->{vars}}) {
374
45
31
        next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED;
375        # Empty substitutions variables are ignored on the basis
376        # that they are not required in the current situation
377        # (example: debhelper's misc:Depends in many cases)
378
1
2
        next if $self->{vars}{$vn} eq '';
379        warning($opts{msg_prefix} .
380
1
1
                g_('substitution variable ${%s} unused, but is defined'),
381                $vn);
382    }
383}
384
385 - 390
=item $s->set_msg_prefix($prefix)

Define a prefix displayed before all warnings/error messages output
by the module.

=cut
391
392sub set_msg_prefix {
393
1
1
1
    my ($self, $prefix) = @_;
394
1
1
    $self->{msg_prefix} = $prefix;
395}
396
397 - 404
=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
405
406sub filter {
407
3
1
3
    my ($self, %opts) = @_;
408
409
3
12
6
8
    my $remove = $opts{remove} // sub { 0 };
410
3
10
5
12
    my $keep = $opts{keep} // sub { 1 };
411
412
3
3
2
7
    foreach my $vn (keys %{$self->{vars}}) {
413
36
21
        $self->delete($vn) if $remove->($vn) or not $keep->($vn);
414    }
415}
416
417 - 427
=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
428
429sub output {
430
4
1
2
    my ($self, $fh) = @_;
431
4
4
    my $str = '';
432    # Store all non-automatic substitutions only
433
4
4
0
11
    foreach my $vn (sort keys %{$self->{vars}}) {
434
25
15
        next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO;
435
14
14
        my $op = $self->{attr}{$vn} & SUBSTVAR_ATTR_OPT ? '?=' : '=';
436
14
8
        my $line = "$vn$op" . $self->{vars}{$vn} . "\n";
437
14
0
8
0
        print { $fh } $line if defined $fh;
438
14
13
        $str .= $line;
439    }
440
4
5
    return $str;
441}
442
443 - 499
=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
500
5011;