File Coverage

File:Dpkg/Substvars.pm
Coverage:93.3%

linestmtbrancondsubpodtimecode
1# Copyright © 2006-2024 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
17=encoding utf8
18
19 - 27
=head1 NAME

Dpkg::Substvars - handle variable substitution in strings

=head1 DESCRIPTION

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

=cut
28
29package Dpkg::Substvars 2.02;
30
31
36
36
36
81
28
471
use strict;
32
36
36
36
58
16
627
use warnings;
33
34
36
36
36
54
19
368
use Dpkg ();
35
36
36
36
4190
29
1479
use Dpkg::Arch qw(get_host_arch);
36
36
36
36
5772
49
1235
use Dpkg::Vendor qw(get_current_vendor);
37
36
36
36
5993
36
1579
use Dpkg::Version;
38
36
36
36
91
28
1087
use Dpkg::ErrorHandling;
39
36
36
36
66
34
826
use Dpkg::Gettext;
40
41
36
36
36
53
31
79
use parent qw(Dpkg::Interface::Storable);
42
43my $maxsubsts = 50;
44
45use constant {
46
36
34267
    SUBSTVAR_ATTR_USED => 1,
47    SUBSTVAR_ATTR_AUTO => 2,
48    SUBSTVAR_ATTR_AGED => 4,
49    SUBSTVAR_ATTR_OPT  => 8,
50    SUBSTVAR_ATTR_DEEP => 16,
51    SUBSTVAR_ATTR_REQ  => 32,
52
36
36
1282
28
};
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
75
1
103
    my ($this, $arg) = @_;
74
75
330
    my $class = ref($this) || $this;
75
75
596
    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
75
176
    $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//;
87
75
78
    bless $self, $class;
88
89
75
75
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
90
75
75
58
928
    $self->{attr}{$_} = $attr foreach keys %{$self->{vars}};
91
75
132
    if ($arg) {
92
12
91
        $self->load($arg) if -e $arg;
93    }
94
75
152
    return $self;
95}
96
97 - 101
=item $s->set($key, $value)

Add/replace a substitution.

=cut
102
103sub set {
104
993
1
822
    my ($self, $key, $value, $attr) = @_;
105
106
993
781
    $attr //= 0;
107
993
1608
    $attr |= SUBSTVAR_ATTR_DEEP if length $value && $value =~ m{\$};
108
109
993
912
    $self->{vars}{$key} = $value;
110
993
984
    $self->{attr}{$key} = $attr;
111}
112
113 - 118
=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
119
120sub set_as_used {
121
3
1
4
    my ($self, $key, $value) = @_;
122
123
3
6
    $self->set($key, $value, SUBSTVAR_ATTR_USED);
124}
125
126 - 131
=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
132
133sub set_as_auto {
134
801
1
546
    my ($self, $key, $value) = @_;
135
136
801
514
    $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO);
137}
138
139 - 143
=item $s->get($key)

Get the value of a given substitution.

=cut
144
145sub get {
146
240
1
2365
    my ($self, $key) = @_;
147
240
392
    return $self->{vars}{$key};
148}
149
150 - 154
=item $s->delete($key)

Remove a given substitution.

=cut
155
156sub delete {
157
69
1
50
    my ($self, $key) = @_;
158
69
46
    delete $self->{attr}{$key};
159
69
64
    return delete $self->{vars}{$key};
160}
161
162 - 167
=item $s->mark_as_used($key)

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

=cut
168
169sub mark_as_used {
170
2964
1
1994
    my ($self, $key) = @_;
171
2964
2011
    $self->{attr}{$key} |= SUBSTVAR_ATTR_USED;
172}
173
174 - 181
=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
182
183sub parse {
184
15
1
25
    my ($self, $fh, $varlistfile) = @_;
185
15
13
    my $count = 0;
186
15
11
    local $_;
187
188
15
26
    binmode($fh);
189
15
71
    while (<$fh>) {
190
96
48
        my $attr;
191
192
96
208
        next if m/^\s*\#/ || !m/\S/;
193
78
142
        s/\s*\n$//;
194
78
129
        if (! m/^(\w[-:0-9A-Za-z]*)([?!])?\=(.*)$/) {
195
0
0
            error(g_('bad line in substvars file %s at line %d'),
196                  $varlistfile, $.);
197        }
198        ## no critic (RegularExpressions::ProhibitCaptureWithoutTest)
199
78
65
        if (defined $2) {
200
6
6
            $attr = (SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_OPT) if $2 eq '?';
201
6
10
            $attr = (SUBSTVAR_ATTR_REQ) if $2 eq '!';
202        }
203
78
78
        $self->set($1, $3, $attr);
204
78
74
        $count++;
205    }
206
207
15
21
    return $count
208}
209
210 - 221
=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
222
223sub set_version_substvars {
224
9
1
17
    my ($self, $sourceversion, $binaryversion) = @_;
225
226    # Handle old function signature taking only one argument.
227
9
20
    $binaryversion //= $sourceversion;
228
229    # For backwards compatibility on binNMUs that do not use the Binary-Only
230    # field on the changelog, always fix up the source version.
231
9
21
    $sourceversion =~ s/\+b[0-9]+$//;
232
233
9
24
    my $vs = Dpkg::Version->new($sourceversion, check => 1);
234
9
14
    if (not defined $vs) {
235
0
0
        error(g_('invalid source version %s'), $sourceversion);
236    }
237
9
18
    my $upstreamversion = $vs->as_string(omit_revision => 1);
238
239
9
8
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
240
241
9
14
    $self->set('binary:Version', $binaryversion, $attr);
242
9
15
    $self->set('source:Version', $sourceversion, $attr);
243
9
12
    $self->set('source:Upstream-Version', $upstreamversion, $attr);
244
245    # XXX: Source-Version is now obsolete, remove in 1.19.x.
246
9
13
    $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED);
247}
248
249 - 255
=item $s->set_arch_substvars()

Defines architecture variables: ${Arch}.

This will never be warned about when unused.

=cut
256
257sub set_arch_substvars {
258
3
1
4
    my $self = shift;
259
260
3
4
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
261
262
3
8
    $self->set('Arch', get_host_arch(), $attr);
263}
264
265 - 271
=item $s->set_vendor_substvars()

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

These will never be warned about when unused.

=cut
272
273sub set_vendor_substvars {
274
3
1
3
    my ($self, $desc) = @_;
275
276
3
3
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
277
278
3
7
    my $vendor = get_current_vendor();
279
3
6
    $self->set('vendor:Name', $vendor, $attr);
280
3
3
    $self->set('vendor:Id', lc $vendor, $attr);
281}
282
283 - 290
=item $s->set_desc_substvars()

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

These will never be warned about when unused.

=cut
291
292sub set_desc_substvars {
293
3
1
4
    my ($self, $desc) = @_;
294
295
3
5
    my ($synopsis, $extended) = split /\n/, $desc, 2;
296
297
3
4
    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
298
299
3
6
    $self->set('source:Synopsis', $synopsis, $attr);
300
3
5
    $self->set('source:Extended-Description', $extended, $attr);
301}
302
303 - 310
=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
311
312sub set_field_substvars {
313
3
1
5
    my ($self, $ctrl, $prefix) = @_;
314
315
3
3
5
7
    foreach my $field (keys %{$ctrl}) {
316
9
18
        $self->set_as_auto("$prefix:$field", $ctrl->{$field});
317    }
318}
319
320 - 324
=item $newstring = $s->substvars($string)

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

=cut
325
326sub substvars {
327
264
1
235
    my ($self, $v, %opts) = @_;
328
264
274
    my %seen;
329    my $lhs;
330
264
0
    my $vn;
331
264
153
    my $rhs = '';
332
264
873
    $opts{msg_prefix} //= $self->{msg_prefix};
333
264
542
    $opts{no_warn} //= 0;
334
335
264
687
    while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) {
336
2964
2106
        $lhs = $1;
337
2964
1799
        $vn = $2;
338
2964
1904
        $rhs = $3;
339
340
2964
2306
        if (defined($self->{vars}{$vn})) {
341
2961
2496
            $v = $lhs . $self->{vars}{$vn} . $rhs;
342
2961
2391
            $self->mark_as_used($vn);
343
344
2961
2382
            if ($self->{attr}{$vn} & SUBSTVAR_ATTR_DEEP) {
345
636
391
                $seen{$vn}++;
346            }
347
2961
2967
            if (exists $seen{$vn} && $seen{$vn} >= $maxsubsts) {
348                error($opts{msg_prefix} .
349
6
22
                      g_("too many \${%s} substitutions (recursive?) in '%s'"),
350                      $vn, $v);
351            }
352
353
2955
4940
            if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) {
354                error($opts{msg_prefix} .
355
0
0
                      g_('obsolete substitution variable ${%s}'), $vn);
356            }
357        } else {
358            warning($opts{msg_prefix} .
359                    g_('substitution variable ${%s} used, but is not defined'),
360
3
15
                    $vn) unless $opts{no_warn};
361
3
7
            $v = $lhs . $rhs;
362        }
363    }
364
258
581
    return $v;
365}
366
367 - 371
=item $s->warn_about_unused()

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

=cut
372
373sub warn_about_unused {
374
9
1
10
    my ($self, %opts) = @_;
375
9
34
    $opts{msg_prefix} //= $self->{msg_prefix};
376
377
9
9
8
74
    foreach my $vn (sort keys %{$self->{vars}}) {
378
261
203
        next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED;
379        # Empty substitutions variables are ignored on the basis
380        # that they are not required in the current situation
381        # (example: debhelper's misc:Depends in many cases)
382
6
8
        next if $self->{vars}{$vn} eq '';
383
384
6
14
        if ($self->{attr}{$vn} & SUBSTVAR_ATTR_REQ) {
385            error($opts{msg_prefix} .
386
3
9
                  g_('required substitution variable ${%s} not used'),
387                  $vn);
388        } else {
389            warning($opts{msg_prefix} .
390
3
8
                    g_('substitution variable ${%s} unused, but is defined'),
391                    $vn);
392        }
393    }
394}
395
396 - 401
=item $s->set_msg_prefix($prefix)

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

=cut
402
403sub set_msg_prefix {
404
3
1
4
    my ($self, $prefix) = @_;
405
3
4
    $self->{msg_prefix} = $prefix;
406}
407
408 - 415
=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
416
417sub filter {
418
9
1
14
    my ($self, %opts) = @_;
419
420
9
36
21
39
    my $remove = $opts{remove} // sub { 0 };
421
9
30
17
40
    my $keep = $opts{keep} // sub { 1 };
422
423
9
9
5
16
    foreach my $vn (keys %{$self->{vars}}) {
424
108
68
        $self->delete($vn) if $remove->($vn) or not $keep->($vn);
425    }
426}
427
428 - 438
=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
439
440sub output {
441
15
1
47
    my ($self, $fh) = @_;
442
15
12
    my $str = '';
443    # Store all non-automatic substitutions only
444
15
15
11
41
    foreach my $vn (sort keys %{$self->{vars}}) {
445
93
84
        next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO;
446
45
24
        my $op;
447
45
133
        if ($self->{attr}{$vn} & SUBSTVAR_ATTR_OPT) {
448
3
4
            $op = '?=';
449        } elsif ($self->{attr}{$vn} & SUBSTVAR_ATTR_REQ) {
450
3
3
            $op = '!=';
451        } else {
452
39
18
            $op = '=';
453        }
454
45
45
        my $line = "$vn$op" . $self->{vars}{$vn} . "\n";
455
45
0
31
0
        print { $fh } $line if defined $fh;
456
45
40
        $str .= $line;
457    }
458
15
34
    return $str;
459}
460
461 - 521
=item $s->save($file)

Store all substitutions variables except the automatic ones in the
indicated file.

=back

=head1 CHANGES

=head2 Version 2.02 (dpkg 1.22.7)

New feature: Add support for required substitution variables.

=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
522
5231;