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