chiark - git - mdw - dpkg/blob - scripts/Dpkg/Control/HashCore.pm

   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;