1# Copyright © 2006-2009, 2012-2015 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
19use strict;
20use warnings;
21
22our $VERSION = '1.06';
23
24use Dpkg ();
25use Dpkg::Arch qw(get_host_arch);
26use Dpkg::Version;
27use Dpkg::ErrorHandling;
28use Dpkg::Gettext;
29
30use parent qw(Dpkg::Interface::Storable);
31
32my $maxsubsts = 50;
33
34=encoding utf8
35
36=head1 NAME
37
38Dpkg::Substvars - handle variable substitution in strings
39
40=head1 DESCRIPTION
41
42It provides an object which is able to substitute variables in strings.
43
44=cut
45
46use constant {
47    SUBSTVAR_ATTR_USED => 1,
48    SUBSTVAR_ATTR_AUTO => 2,
49    SUBSTVAR_ATTR_AGED => 4,
50};
51
52=head1 METHODS
53
54=over 8
55
56=item $s = Dpkg::Substvars->new($file)
57
58Create a new object that can do substitutions. By default it contains
59generic substitutions like ${Newline}, ${Space}, ${Tab}, ${dpkg:Version}
60and ${dpkg:Upstream-Version}.
61
62Additional substitutions will be read from the $file passed as parameter.
63
64It keeps track of which substitutions were actually used (only counting
65substvars(), not get()), and warns about unused substvars when asked to. The
66substitutions that are always present are not included in these warnings.
67
68=cut
69
70sub new {
71    my ($this, $arg) = @_;
72    my $class = ref($this) || $this;
73    my $self = {
74        vars => {
75            'Newline' => "\n",
76            'Space' => ' ',
77            'Tab' => "\t",
78            'dpkg:Version' => $Dpkg::PROGVERSION,
79            'dpkg:Upstream-Version' => $Dpkg::PROGVERSION,
80            },
81        attr => {},
82	msg_prefix => '',
83    };
84    $self->{vars}{'dpkg:Upstream-Version'} =~ s/-[^-]+$//;
85    bless $self, $class;
86
87    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
88    $self->{attr}{$_} = $attr foreach keys %{$self->{vars}};
89    if ($arg) {
90        $self->load($arg) if -e $arg;
91    }
92    return $self;
93}
94
95=item $s->set($key, $value)
96
97Add/replace a substitution.
98
99=cut
100
101sub set {
102    my ($self, $key, $value, $attr) = @_;
103
104    $attr //= 0;
105
106    $self->{vars}{$key} = $value;
107    $self->{attr}{$key} = $attr;
108}
109
110=item $s->set_as_used($key, $value)
111
112Add/replace a substitution and mark it as used (no warnings will be produced
113even if unused).
114
115=cut
116
117sub set_as_used {
118    my ($self, $key, $value) = @_;
119
120    $self->set($key, $value, SUBSTVAR_ATTR_USED);
121}
122
123=item $s->set_as_auto($key, $value)
124
125Add/replace a substitution and mark it as used and automatic (no warnings
126will be produced even if unused).
127
128=cut
129
130sub set_as_auto {
131    my ($self, $key, $value) = @_;
132
133    $self->set($key, $value, SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO);
134}
135
136=item $s->get($key)
137
138Get the value of a given substitution.
139
140=cut
141
142sub get {
143    my ($self, $key) = @_;
144    return $self->{vars}{$key};
145}
146
147=item $s->delete($key)
148
149Remove a given substitution.
150
151=cut
152
153sub delete {
154    my ($self, $key) = @_;
155    delete $self->{attr}{$key};
156    return delete $self->{vars}{$key};
157}
158
159=item $s->mark_as_used($key)
160
161Prevents warnings about a unused substitution, for example if it is provided by
162default.
163
164=cut
165
166sub mark_as_used {
167    my ($self, $key) = @_;
168    $self->{attr}{$key} |= SUBSTVAR_ATTR_USED;
169}
170
171=item $s->no_warn($key)
172
173Obsolete function, use mark_as_used() instead.
174
175=cut
176
177sub no_warn {
178    my ($self, $key) = @_;
179
180    warnings::warnif('deprecated',
181                     'obsolete no_warn() function, use mark_as_used() instead');
182
183    $self->mark_as_used($key);
184}
185
186=item $s->parse($fh, $desc)
187
188Add new substitutions read from the filehandle. $desc is used to identify
189the filehandle in error messages.
190
191Returns the number of substitutions that have been parsed with success.
192
193=cut
194
195sub parse {
196    my ($self, $fh, $varlistfile) = @_;
197    my $count = 0;
198    local $_;
199
200    binmode($fh);
201    while (<$fh>) {
202	next if m/^\s*\#/ || !m/\S/;
203	s/\s*\n$//;
204	if (! m/^(\w[-:0-9A-Za-z]*)\=(.*)$/) {
205	    error(g_('bad line in substvars file %s at line %d'),
206		  $varlistfile, $.);
207	}
208	$self->set($1, $2);
209        $count++;
210    }
211
212    return $count
213}
214
215=item $s->load($file)
216
217Add new substitutions read from $file.
218
219=item $s->set_version_substvars($sourceversion, $binaryversion)
220
221Defines ${binary:Version}, ${source:Version} and
222${source:Upstream-Version} based on the given version strings.
223
224These will never be warned about when unused.
225
226=cut
227
228sub set_version_substvars {
229    my ($self, $sourceversion, $binaryversion) = @_;
230
231    # Handle old function signature taking only one argument.
232    $binaryversion //= $sourceversion;
233
234    # For backwards compatibility on binNMUs that do not use the Binary-Only
235    # field on the changelog, always fix up the source version.
236    $sourceversion =~ s/\+b[0-9]+$//;
237
238    my $vs = Dpkg::Version->new($sourceversion, check => 1);
239    if (not defined $vs) {
240        error(g_('invalid source version %s'), $sourceversion);
241    }
242    my $upstreamversion = $vs->as_string(omit_revision => 1);
243
244    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
245
246    $self->set('binary:Version', $binaryversion, $attr);
247    $self->set('source:Version', $sourceversion, $attr);
248    $self->set('source:Upstream-Version', $upstreamversion, $attr);
249
250    # XXX: Source-Version is now obsolete, remove in 1.19.x.
251    $self->set('Source-Version', $binaryversion, $attr | SUBSTVAR_ATTR_AGED);
252}
253
254=item $s->set_arch_substvars()
255
256Defines architecture variables: ${Arch}.
257
258This will never be warned about when unused.
259
260=cut
261
262sub set_arch_substvars {
263    my $self = shift;
264
265    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
266
267    $self->set('Arch', get_host_arch(), $attr);
268}
269
270=item $s->set_desc_substvars()
271
272Defines source description variables: ${source:Synopsis} and
273${source:Extended-Description}.
274
275These will never be warned about when unused.
276
277=cut
278
279sub set_desc_substvars {
280    my ($self, $desc) = @_;
281
282    my ($synopsis, $extended) = split /\n/, $desc, 2;
283
284    my $attr = SUBSTVAR_ATTR_USED | SUBSTVAR_ATTR_AUTO;
285
286    $self->set('source:Synopsis', $synopsis, $attr);
287    $self->set('source:Extended-Description', $extended, $attr);
288}
289
290=item $s->set_field_substvars($ctrl, $prefix)
291
292Defines field variables from a Dpkg::Control object, with each variable
293having the form "${$prefix:$field}".
294
295They will never be warned about when unused.
296
297=cut
298
299sub set_field_substvars {
300    my ($self, $ctrl, $prefix) = @_;
301
302    foreach my $field (keys %{$ctrl}) {
303        $self->set_as_auto("$prefix:$field", $ctrl->{$field});
304    }
305}
306
307=item $newstring = $s->substvars($string)
308
309Substitutes variables in $string and return the result in $newstring.
310
311=cut
312
313sub substvars {
314    my ($self, $v, %opts) = @_;
315    my $lhs;
316    my $vn;
317    my $rhs = '';
318    my $count = 0;
319    $opts{msg_prefix} //= $self->{msg_prefix};
320    $opts{no_warn} //= 0;
321
322    while ($v =~ m/^(.*?)\$\{([-:0-9a-z]+)\}(.*)$/si) {
323        # If we have consumed more from the leftover data, then
324        # reset the recursive counter.
325        $count = 0 if (length($3) < length($rhs));
326
327        if ($count >= $maxsubsts) {
328            error($opts{msg_prefix} .
329                  g_("too many substitutions - recursive ? - in '%s'"), $v);
330        }
331        $lhs = $1;
332        $vn = $2;
333        $rhs = $3;
334        if (defined($self->{vars}{$vn})) {
335            $v = $lhs . $self->{vars}{$vn} . $rhs;
336            $self->mark_as_used($vn);
337            $count++;
338
339            if ($self->{attr}{$vn} & SUBSTVAR_ATTR_AGED) {
340                error($opts{msg_prefix} .
341                      g_('obsolete substitution variable ${%s}'), $vn);
342            }
343        } else {
344            warning($opts{msg_prefix} .
345                    g_('substitution variable ${%s} used, but is not defined'),
346	            $vn) unless $opts{no_warn};
347            $v = $lhs . $rhs;
348        }
349    }
350    return $v;
351}
352
353=item $s->warn_about_unused()
354
355Issues warning about any variables that were set, but not used.
356
357=cut
358
359sub warn_about_unused {
360    my ($self, %opts) = @_;
361    $opts{msg_prefix} //= $self->{msg_prefix};
362
363    foreach my $vn (sort keys %{$self->{vars}}) {
364        next if $self->{attr}{$vn} & SUBSTVAR_ATTR_USED;
365        # Empty substitutions variables are ignored on the basis
366        # that they are not required in the current situation
367        # (example: debhelper's misc:Depends in many cases)
368        next if $self->{vars}{$vn} eq '';
369        warning($opts{msg_prefix} .
370                g_('substitution variable ${%s} unused, but is defined'),
371                $vn);
372    }
373}
374
375=item $s->set_msg_prefix($prefix)
376
377Define a prefix displayed before all warnings/error messages output
378by the module.
379
380=cut
381
382sub set_msg_prefix {
383    my ($self, $prefix) = @_;
384    $self->{msg_prefix} = $prefix;
385}
386
387=item $s->filter(remove => $rmfunc)
388
389=item $s->filter(keep => $keepfun)
390
391Filter the substitution variables, either removing or keeping all those
392that return true when $rmfunc->($key) or $keepfunc->($key) is called.
393
394=cut
395
396sub filter {
397    my ($self, %opts) = @_;
398
399    my $remove = $opts{remove} // sub { 0 };
400    my $keep = $opts{keep} // sub { 1 };
401
402    foreach my $vn (keys %{$self->{vars}}) {
403        $self->delete($vn) if $remove->($vn) or not $keep->($vn);
404    }
405}
406
407=item "$s"
408
409Return a string representation of all substitutions variables except the
410automatic ones.
411
412=item $str = $s->output([$fh])
413
414Return all substitutions variables except the automatic ones. If $fh
415is passed print them into the filehandle.
416
417=cut
418
419sub output {
420    my ($self, $fh) = @_;
421    my $str = '';
422    # Store all non-automatic substitutions only
423    foreach my $vn (sort keys %{$self->{vars}}) {
424	next if $self->{attr}{$vn} & SUBSTVAR_ATTR_AUTO;
425	my $line = "$vn=" . $self->{vars}{$vn} . "\n";
426	print { $fh } $line if defined $fh;
427	$str .= $line;
428    }
429    return $str;
430}
431
432=item $s->save($file)
433
434Store all substitutions variables except the automatic ones in the
435indicated file.
436
437=back
438
439=head1 CHANGES
440
441=head2 Version 1.06 (dpkg 1.19.0)
442
443New method: $s->set_desc_substvars().
444
445=head2 Version 1.05 (dpkg 1.18.11)
446
447Obsolete substvar: Emit an error on Source-Version substvar usage.
448
449New return: $s->parse() now returns the number of parsed substvars.
450
451New method: $s->set_field_substvars().
452
453=head2 Version 1.04 (dpkg 1.18.0)
454
455New method: $s->filter().
456
457=head2 Version 1.03 (dpkg 1.17.11)
458
459New method: $s->set_as_auto().
460
461=head2 Version 1.02 (dpkg 1.16.5)
462
463New argument: Accept a $binaryversion in $s->set_version_substvars(),
464passing a single argument is still supported.
465
466New method: $s->mark_as_used().
467
468Deprecated method: $s->no_warn(), use $s->mark_as_used() instead.
469
470=head2 Version 1.01 (dpkg 1.16.4)
471
472New method: $s->set_as_used().
473
474=head2 Version 1.00 (dpkg 1.15.6)
475
476Mark the module as public.
477
478=cut
479
4801;
481