Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | # Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org> |
2 | # Copyright © 2009, 2012-2015 Guillem Jover <guillem@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::Control::HashCore; | |
18 | ||
19 | use strict; | |
20 | use warnings; | |
21 | ||
22 | our $VERSION = '1.01'; | |
23 | ||
24 | use Dpkg::Gettext; | |
25 | use Dpkg::ErrorHandling; | |
26 | use Dpkg::Control::FieldsCore; | |
27 | ||
28 | # This module cannot use Dpkg::Control::Fields, because that one makes use | |
29 | # of Dpkg::Vendor which at the same time uses this module, which would turn | |
30 | # into a compilation error. We can use Dpkg::Control::FieldsCore instead. | |
31 | ||
32 | use parent qw(Dpkg::Interface::Storable); | |
33 | ||
34 | use overload | |
35 | '%{}' => sub { ${$_[0]}->{fields} }, | |
36 | 'eq' => sub { "$_[0]" eq "$_[1]" }; | |
37 | ||
38 | =encoding utf8 | |
39 | ||
40 | =head1 NAME | |
41 | ||
42 | Dpkg::Control::HashCore - parse and manipulate a block of RFC822-like fields | |
43 | ||
44 | =head1 DESCRIPTION | |
45 | ||
46 | The Dpkg::Control::Hash object is a hash-like representation of a set of | |
47 | RFC822-like fields. The fields names are case insensitive and are always | |
48 | capitalized the same when output (see field_capitalize function in | |
49 | Dpkg::Control::Fields). | |
50 | The order in which fields have been set is remembered and is used | |
51 | to be able to dump back the same content. The output order can also be | |
52 | overridden if needed. | |
53 | ||
54 | You can store arbitrary values in the hash, they will always be properly | |
55 | escaped in the output to conform to the syntax of control files. This is | |
56 | relevant mainly for multilines values: while the first line is always output | |
57 | unchanged directly after the field name, supplementary lines are | |
58 | modified. Empty lines and lines containing only dots are prefixed with | |
59 | " ." (space + dot) while other lines are prefixed with a single space. | |
60 | ||
61 | During parsing, trailing spaces are stripped on all lines while leading | |
62 | spaces are stripped only on the first line of each field. | |
63 | ||
64 | =head1 METHODS | |
65 | ||
66 | =over 4 | |
67 | ||
68 | =item $c = Dpkg::Control::Hash->new(%opts) | |
69 | ||
70 | Creates a new object with the indicated options. Supported options | |
71 | are: | |
72 | ||
73 | =over 8 | |
74 | ||
75 | =item allow_pgp | |
76 | ||
77 | Configures the parser to accept OpenPGP signatures around the control | |
78 | information. Value can be 0 (default) or 1. | |
79 | ||
80 | =item allow_duplicate | |
81 | ||
82 | Configures the parser to allow duplicate fields in the control | |
83 | information. Value can be 0 (default) or 1. | |
84 | ||
85 | =item drop_empty | |
86 | ||
87 | Defines if empty fields are dropped during the output. Value can be 0 | |
88 | (default) or 1. | |
89 | ||
90 | =item name | |
91 | ||
92 | The user friendly name of the information stored in the object. It might | |
93 | be used in some error messages or warnings. A default name might be set | |
94 | depending on the type. | |
95 | ||
96 | =item is_pgp_signed | |
97 | ||
98 | Set by the parser (starting in dpkg 1.17.0) if it finds an OpenPGP | |
99 | signature around the control information. Value can be 0 (default) | |
100 | or 1, and undef when the option is not supported by the code (in | |
101 | versions older than dpkg 1.17.0). | |
102 | ||
103 | =back | |
104 | ||
105 | =cut | |
106 | ||
107 | sub new { | |
108 | my ($this, %opts) = @_; | |
109 | my $class = ref($this) || $this; | |
110 | ||
111 | # Object is a scalar reference and not a hash ref to avoid | |
112 | # infinite recursion due to overloading hash-dereferencing | |
113 | my $self = \{ | |
114 | in_order => [], | |
115 | out_order => [], | |
116 | is_pgp_signed => 0, | |
117 | allow_pgp => 0, | |
118 | allow_duplicate => 0, | |
119 | drop_empty => 0, | |
120 | }; | |
121 | bless $self, $class; | |
122 | ||
123 | $$self->{fields} = Dpkg::Control::HashCore::Tie->new($self); | |
124 | ||
125 | # Options set by the user override default values | |
126 | $$self->{$_} = $opts{$_} foreach keys %opts; | |
127 | ||
128 | return $self; | |
129 | } | |
130 | ||
131 | # There is naturally a circular reference between the tied hash and its | |
132 | # containing object. Happily, the extra layer of scalar reference can | |
133 | # be used to detect the destruction of the object and break the loop so | |
134 | # that everything gets garbage-collected. | |
135 | ||
136 | sub DESTROY { | |
137 | my $self = shift; | |
138 | delete $$self->{fields}; | |
139 | } | |
140 | ||
141 | =item $c->set_options($option, %opts) | |
142 | ||
143 | Changes the value of one or more options. | |
144 | ||
145 | =cut | |
146 | ||
147 | sub set_options { | |
148 | my ($self, %opts) = @_; | |
149 | $$self->{$_} = $opts{$_} foreach keys %opts; | |
150 | } | |
151 | ||
152 | =item $value = $c->get_option($option) | |
153 | ||
154 | Returns the value of the corresponding option. | |
155 | ||
156 | =cut | |
157 | ||
158 | sub get_option { | |
159 | my ($self, $k) = @_; | |
160 | return $$self->{$k}; | |
161 | } | |
162 | ||
163 | =item $c->load($file) | |
164 | ||
165 | Parse the content of $file. Exits in case of errors. Returns true if some | |
166 | fields have been parsed. | |
167 | ||
168 | =item $c->parse_error($file, $fmt, ...) | |
169 | ||
170 | Prints an error message and dies on syntax parse errors. | |
171 | ||
172 | =cut | |
173 | ||
174 | sub parse_error { | |
175 | my ($self, $file, $msg) = (shift, shift, shift); | |
176 | ||
177 | $msg = sprintf($msg, @_) if (@_); | |
178 | error(g_('syntax error in %s at line %d: %s'), $file, $., $msg); | |
179 | } | |
180 | ||
181 | =item $c->parse($fh, $description) | |
182 | ||
183 | Parse a control file from the given filehandle. Exits in case of errors. | |
184 | $description is used to describe the filehandle, ideally it's a filename | |
185 | or a description of where the data comes from. It's used in error | |
186 | messages. When called multiple times, the parsed fields are accumulated. | |
187 | ||
188 | Returns true if some fields have been parsed. | |
189 | ||
190 | =cut | |
191 | ||
192 | sub parse { | |
193 | my ($self, $fh, $desc) = @_; | |
194 | ||
195 | my $paraborder = 1; | |
196 | my $parabody = 0; | |
197 | my $cf; # Current field | |
198 | my $expect_pgp_sig = 0; | |
199 | local $_; | |
200 | ||
201 | while (<$fh>) { | |
202 | chomp; | |
203 | next if m/^\s*$/ and $paraborder; | |
204 | next if (m/^#/); | |
205 | $paraborder = 0; | |
206 | if (m/^(\S+?)\s*:\s*(.*)$/) { | |
207 | $parabody = 1; | |
208 | my ($name, $value) = ($1, $2); | |
209 | if ($name =~ m/^-/) { | |
210 | $self->parse_error($desc, g_('field cannot start with a hyphen')); | |
211 | } | |
212 | if (exists $self->{$name}) { | |
213 | unless ($$self->{allow_duplicate}) { | |
214 | $self->parse_error($desc, g_('duplicate field %s found'), $name); | |
215 | } | |
216 | } | |
217 | $value =~ s/\s*$//; | |
218 | $self->{$name} = $value; | |
219 | $cf = $name; | |
220 | } elsif (m/^\s(\s*\S.*)$/) { | |
221 | my $line = $1; | |
222 | unless (defined($cf)) { | |
223 | $self->parse_error($desc, g_('continued value line not in field')); | |
224 | } | |
225 | $line =~ s/\s*$//; | |
226 | if ($line =~ /^\.+$/) { | |
227 | $line = substr $line, 1; | |
228 | } | |
229 | $self->{$cf} .= "\n$line"; | |
230 | } elsif (m/^-----BEGIN PGP SIGNED MESSAGE-----[\r\t ]*$/) { | |
231 | $expect_pgp_sig = 1; | |
232 | if ($$self->{allow_pgp} and not $parabody) { | |
233 | # Skip OpenPGP headers | |
234 | while (<$fh>) { | |
235 | last if m/^\s*$/; | |
236 | } | |
237 | } else { | |
238 | $self->parse_error($desc, g_('OpenPGP signature not allowed here')); | |
239 | } | |
240 | } elsif (m/^\s*$/ || | |
241 | ($expect_pgp_sig && m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/)) { | |
242 | if ($expect_pgp_sig) { | |
243 | # Skip empty lines | |
244 | $_ = <$fh> while defined && m/^\s*$/; | |
245 | unless (length) { | |
246 | $self->parse_error($desc, g_('expected OpenPGP signature, ' . | |
247 | 'found end of file after blank line')); | |
248 | } | |
249 | chomp; | |
250 | unless (m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/) { | |
251 | $self->parse_error($desc, g_('expected OpenPGP signature, ' . | |
252 | "found something else '%s'"), $_); | |
253 | } | |
254 | # Skip OpenPGP signature | |
255 | while (<$fh>) { | |
256 | chomp; | |
257 | last if m/^-----END PGP SIGNATURE-----[\r\t ]*$/; | |
258 | } | |
259 | unless (defined) { | |
260 | $self->parse_error($desc, g_('unfinished OpenPGP signature')); | |
261 | } | |
262 | # This does not mean the signature is correct, that needs to | |
263 | # be verified by gnupg. | |
264 | $$self->{is_pgp_signed} = 1; | |
265 | } | |
266 | last; # Finished parsing one block | |
267 | } else { | |
268 | $self->parse_error($desc, | |
269 | g_('line with unknown format (not field-colon-value)')); | |
270 | } | |
271 | } | |
272 | ||
273 | if ($expect_pgp_sig and not $$self->{is_pgp_signed}) { | |
274 | $self->parse_error($desc, g_('unfinished OpenPGP signature')); | |
275 | } | |
276 | ||
277 | return defined($cf); | |
278 | } | |
279 | ||
280 | =item $c->find_custom_field($name) | |
281 | ||
282 | Scan the fields and look for a user specific field whose name matches the | |
283 | following regex: /X[SBC]*-$name/i. Return the name of the field found or | |
284 | undef if nothing has been found. | |
285 | ||
286 | =cut | |
287 | ||
288 | sub find_custom_field { | |
289 | my ($self, $name) = @_; | |
290 | foreach my $key (keys %$self) { | |
291 | return $key if $key =~ /^X[SBC]*-\Q$name\E$/i; | |
292 | } | |
293 | return; | |
294 | } | |
295 | ||
296 | =item $c->get_custom_field($name) | |
297 | ||
298 | Identify a user field and retrieve its value. | |
299 | ||
300 | =cut | |
301 | ||
302 | sub get_custom_field { | |
303 | my ($self, $name) = @_; | |
304 | my $key = $self->find_custom_field($name); | |
305 | return $self->{$key} if defined $key; | |
306 | return; | |
307 | } | |
308 | ||
309 | =item $c->save($filename) | |
310 | ||
311 | Write the string representation of the control information to a | |
312 | file. | |
313 | ||
314 | =item $str = $c->output() | |
315 | ||
316 | =item "$c" | |
317 | ||
318 | Get a string representation of the control information. The fields | |
319 | are sorted in the order in which they have been read or set except | |
320 | if the order has been overridden with set_output_order(). | |
321 | ||
322 | =item $c->output($fh) | |
323 | ||
324 | Print the string representation of the control information to a | |
325 | filehandle. | |
326 | ||
327 | =cut | |
328 | ||
329 | sub output { | |
330 | my ($self, $fh) = @_; | |
331 | my $str = ''; | |
332 | my @keys; | |
333 | if (@{$$self->{out_order}}) { | |
334 | my $i = 1; | |
335 | my $imp = {}; | |
336 | $imp->{$_} = $i++ foreach @{$$self->{out_order}}; | |
337 | @keys = sort { | |
338 | if (defined $imp->{$a} && defined $imp->{$b}) { | |
339 | $imp->{$a} <=> $imp->{$b}; | |
340 | } elsif (defined($imp->{$a})) { | |
341 | -1; | |
342 | } elsif (defined($imp->{$b})) { | |
343 | 1; | |
344 | } else { | |
345 | $a cmp $b; | |
346 | } | |
347 | } keys %$self; | |
348 | } else { | |
349 | @keys = @{$$self->{in_order}}; | |
350 | } | |
351 | ||
352 | foreach my $key (@keys) { | |
353 | if (exists $self->{$key}) { | |
354 | my $value = $self->{$key}; | |
355 | # Skip whitespace-only fields | |
356 | next if $$self->{drop_empty} and $value !~ m/\S/; | |
357 | # Escape data to follow control file syntax | |
358 | my ($first_line, @lines) = split /\n/, $value; | |
359 | ||
360 | my $kv = "$key:"; | |
361 | $kv .= ' ' . $first_line if length $first_line; | |
362 | $kv .= "\n"; | |
363 | foreach (@lines) { | |
364 | s/\s+$//; | |
365 | if (length == 0 or /^\.+$/) { | |
366 | $kv .= " .$_\n"; | |
367 | } else { | |
368 | $kv .= " $_\n"; | |
369 | } | |
370 | } | |
371 | # Print it out | |
372 | if ($fh) { | |
373 | print { $fh } $kv | |
374 | or syserr(g_('write error on control data')); | |
375 | } | |
376 | $str .= $kv if defined wantarray; | |
377 | } | |
378 | } | |
379 | return $str; | |
380 | } | |
381 | ||
382 | =item $c->set_output_order(@fields) | |
383 | ||
384 | Define the order in which fields will be displayed in the output() method. | |
385 | ||
386 | =cut | |
387 | ||
388 | sub set_output_order { | |
389 | my ($self, @fields) = @_; | |
390 | ||
391 | $$self->{out_order} = [@fields]; | |
392 | } | |
393 | ||
394 | =item $c->apply_substvars($substvars) | |
395 | ||
396 | Update all fields by replacing the variables references with | |
397 | the corresponding value stored in the Dpkg::Substvars object. | |
398 | ||
399 | =cut | |
400 | ||
401 | sub apply_substvars { | |
402 | my ($self, $substvars, %opts) = @_; | |
403 | ||
404 | # Add substvars to refer to other fields | |
405 | $substvars->set_field_substvars($self, 'F'); | |
406 | ||
407 | foreach my $f (keys %$self) { | |
408 | my $v = $substvars->substvars($self->{$f}, %opts); | |
409 | if ($v ne $self->{$f}) { | |
410 | my $sep; | |
411 | ||
412 | $sep = field_get_sep_type($f); | |
413 | ||
414 | # If we replaced stuff, ensure we're not breaking | |
415 | # a dependency field by introducing empty lines, or multiple | |
416 | # commas | |
417 | ||
418 | if ($sep & (FIELD_SEP_COMMA | FIELD_SEP_LINE)) { | |
419 | # Drop empty/whitespace-only lines | |
420 | $v =~ s/\n[ \t]*(\n|$)/$1/; | |
421 | } | |
422 | ||
423 | if ($sep & FIELD_SEP_COMMA) { | |
424 | $v =~ s/,[\s,]*,/,/g; | |
425 | $v =~ s/^\s*,\s*//; | |
426 | $v =~ s/\s*,\s*$//; | |
427 | } | |
428 | } | |
429 | $v =~ s/\$\{\}/\$/g; # XXX: what for? | |
430 | ||
431 | $self->{$f} = $v; | |
432 | } | |
433 | } | |
434 | ||
435 | package Dpkg::Control::HashCore::Tie; | |
436 | ||
437 | # This object is used to tie a hash. It implements hash-like functions by | |
438 | # normalizing the name of fields received in keys (using | |
439 | # Dpkg::Control::Fields::field_capitalize). It also stores the order in | |
440 | # which fields have been added in order to be able to dump them in the | |
441 | # same order. But the order information is stored in a parent object of | |
442 | # type Dpkg::Control. | |
443 | ||
444 | use strict; | |
445 | use warnings; | |
446 | ||
447 | use Dpkg::Control::FieldsCore; | |
448 | ||
449 | use Carp; | |
450 | use Tie::Hash; | |
451 | use parent -norequire, qw(Tie::ExtraHash); | |
452 | ||
453 | # $self->[0] is the real hash | |
454 | # $self->[1] is a reference to the hash contained by the parent object. | |
455 | # This reference bypasses the top-level scalar reference of a | |
456 | # Dpkg::Control::Hash, hence ensuring that reference gets DESTROYed | |
457 | # properly. | |
458 | ||
459 | # Dpkg::Control::Hash->new($parent) | |
460 | # | |
461 | # Return a reference to a tied hash implementing storage of simple | |
462 | # "field: value" mapping as used in many Debian-specific files. | |
463 | ||
464 | sub new { | |
465 | my $class = shift; | |
466 | my $hash = {}; | |
467 | tie %{$hash}, $class, @_; | |
468 | return $hash; | |
469 | } | |
470 | ||
471 | sub TIEHASH { | |
472 | my ($class, $parent) = @_; | |
473 | croak 'parent object must be Dpkg::Control::Hash' | |
474 | if not $parent->isa('Dpkg::Control::HashCore') and | |
475 | not $parent->isa('Dpkg::Control::Hash'); | |
476 | return bless [ {}, $$parent ], $class; | |
477 | } | |
478 | ||
479 | sub FETCH { | |
480 | my ($self, $key) = @_; | |
481 | $key = lc($key); | |
482 | return $self->[0]->{$key} if exists $self->[0]->{$key}; | |
483 | return; | |
484 | } | |
485 | ||
486 | sub STORE { | |
487 | my ($self, $key, $value) = @_; | |
488 | my $parent = $self->[1]; | |
489 | $key = lc($key); | |
490 | if (not exists $self->[0]->{$key}) { | |
491 | push @{$parent->{in_order}}, field_capitalize($key); | |
492 | } | |
493 | $self->[0]->{$key} = $value; | |
494 | } | |
495 | ||
496 | sub EXISTS { | |
497 | my ($self, $key) = @_; | |
498 | $key = lc($key); | |
499 | return exists $self->[0]->{$key}; | |
500 | } | |
501 | ||
502 | sub DELETE { | |
503 | my ($self, $key) = @_; | |
504 | my $parent = $self->[1]; | |
505 | my $in_order = $parent->{in_order}; | |
506 | $key = lc($key); | |
507 | if (exists $self->[0]->{$key}) { | |
508 | delete $self->[0]->{$key}; | |
509 | @{$in_order} = grep { lc ne $key } @{$in_order}; | |
510 | return 1; | |
511 | } else { | |
512 | return 0; | |
513 | } | |
514 | } | |
515 | ||
516 | sub FIRSTKEY { | |
517 | my $self = shift; | |
518 | my $parent = $self->[1]; | |
519 | foreach my $key (@{$parent->{in_order}}) { | |
520 | return $key if exists $self->[0]->{lc $key}; | |
521 | } | |
522 | } | |
523 | ||
524 | sub NEXTKEY { | |
525 | my ($self, $last) = @_; | |
526 | my $parent = $self->[1]; | |
527 | my $found = 0; | |
528 | foreach my $key (@{$parent->{in_order}}) { | |
529 | if ($found) { | |
530 | return $key if exists $self->[0]->{lc $key}; | |
531 | } else { | |
532 | $found = 1 if $key eq $last; | |
533 | } | |
534 | } | |
535 | return; | |
536 | } | |
537 | ||
538 | 1; | |
539 | ||
540 | =back | |
541 | ||
542 | =head1 CHANGES | |
543 | ||
544 | =head2 Version 1.01 (dpkg 1.17.2) | |
545 | ||
546 | New method: $c->parse_error(). | |
547 | ||
548 | =head2 Version 1.00 (dpkg 1.17.0) | |
549 | ||
550 | Mark the module as public. | |
551 | ||
552 | =cut | |
553 | ||
554 | 1; |