| Index: third_party/dpkg-dev/scripts/Dpkg/Control/HashCore.pm
|
| diff --git a/third_party/dpkg-dev/scripts/Dpkg/Control/HashCore.pm b/third_party/dpkg-dev/scripts/Dpkg/Control/HashCore.pm
|
| new file mode 100644
|
| index 0000000000000000000000000000000000000000..e2ceb66d5c66b1e839f4eddcdafdcb0741351ce7
|
| --- /dev/null
|
| +++ b/third_party/dpkg-dev/scripts/Dpkg/Control/HashCore.pm
|
| @@ -0,0 +1,540 @@
|
| +# Copyright © 2007-2009 Raphaël Hertzog <hertzog@debian.org>
|
| +#
|
| +# This program is free software; you can redistribute it and/or modify
|
| +# it under the terms of the GNU General Public License as published by
|
| +# the Free Software Foundation; either version 2 of the License, or
|
| +# (at your option) any later version.
|
| +#
|
| +# This program is distributed in the hope that it will be useful,
|
| +# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
| +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
| +# GNU General Public License for more details.
|
| +#
|
| +# You should have received a copy of the GNU General Public License
|
| +# along with this program. If not, see <https://www.gnu.org/licenses/>.
|
| +
|
| +package Dpkg::Control::HashCore;
|
| +
|
| +use strict;
|
| +use warnings;
|
| +
|
| +our $VERSION = '1.01';
|
| +
|
| +use Dpkg::Gettext;
|
| +use Dpkg::ErrorHandling;
|
| +use Dpkg::Control::FieldsCore;
|
| +
|
| +# This module cannot use Dpkg::Control::Fields, because that one makes use
|
| +# of Dpkg::Vendor which at the same time uses this module, which would turn
|
| +# into a compilation error. We can use Dpkg::Control::FieldsCore instead.
|
| +
|
| +use parent qw(Dpkg::Interface::Storable);
|
| +
|
| +use overload
|
| + '%{}' => sub { ${$_[0]}->{fields} },
|
| + 'eq' => sub { "$_[0]" eq "$_[1]" };
|
| +
|
| +=encoding utf8
|
| +
|
| +=head1 NAME
|
| +
|
| +Dpkg::Control::HashCore - parse and manipulate a block of RFC822-like fields
|
| +
|
| +=head1 DESCRIPTION
|
| +
|
| +The Dpkg::Control::Hash object is a hash-like representation of a set of
|
| +RFC822-like fields. The fields names are case insensitive and are always
|
| +capitalized the same when output (see field_capitalize function in
|
| +Dpkg::Control::Fields).
|
| +The order in which fields have been set is remembered and is used
|
| +to be able to dump back the same content. The output order can also be
|
| +overridden if needed.
|
| +
|
| +You can store arbitrary values in the hash, they will always be properly
|
| +escaped in the output to conform to the syntax of control files. This is
|
| +relevant mainly for multilines values: while the first line is always output
|
| +unchanged directly after the field name, supplementary lines are
|
| +modified. Empty lines and lines containing only dots are prefixed with
|
| +" ." (space + dot) while other lines are prefixed with a single space.
|
| +
|
| +During parsing, trailing spaces are stripped on all lines while leading
|
| +spaces are stripped only on the first line of each field.
|
| +
|
| +=head1 FUNCTIONS
|
| +
|
| +=over 4
|
| +
|
| +=item my $c = Dpkg::Control::Hash->new(%opts)
|
| +
|
| +Creates a new object with the indicated options. Supported options
|
| +are:
|
| +
|
| +=over 8
|
| +
|
| +=item allow_pgp
|
| +
|
| +Configures the parser to accept PGP signatures around the control
|
| +information. Value can be 0 (default) or 1.
|
| +
|
| +=item allow_duplicate
|
| +
|
| +Configures the parser to allow duplicate fields in the control
|
| +information. Value can be 0 (default) or 1.
|
| +
|
| +=item drop_empty
|
| +
|
| +Defines if empty fields are dropped during the output. Value can be 0
|
| +(default) or 1.
|
| +
|
| +=item name
|
| +
|
| +The user friendly name of the information stored in the object. It might
|
| +be used in some error messages or warnings. A default name might be set
|
| +depending on the type.
|
| +
|
| +=back
|
| +
|
| +=cut
|
| +
|
| +sub new {
|
| + my ($this, %opts) = @_;
|
| + my $class = ref($this) || $this;
|
| +
|
| + # Object is a scalar reference and not a hash ref to avoid
|
| + # infinite recursion due to overloading hash-derefencing
|
| + my $self = \{
|
| + in_order => [],
|
| + out_order => [],
|
| + is_pgp_signed => 0,
|
| + allow_pgp => 0,
|
| + allow_duplicate => 0,
|
| + drop_empty => 0,
|
| + };
|
| + bless $self, $class;
|
| +
|
| + $$self->{fields} = Dpkg::Control::HashCore::Tie->new($self);
|
| +
|
| + # Options set by the user override default values
|
| + $$self->{$_} = $opts{$_} foreach keys %opts;
|
| +
|
| + return $self;
|
| +}
|
| +
|
| +# There is naturally a circular reference between the tied hash and its
|
| +# containing object. Happily, the extra layer of scalar reference can
|
| +# be used to detect the destruction of the object and break the loop so
|
| +# that everything gets garbage-collected.
|
| +
|
| +sub DESTROY {
|
| + my ($self) = @_;
|
| + delete $$self->{fields};
|
| +}
|
| +
|
| +=item $c->set_options($option, %opts)
|
| +
|
| +Changes the value of one or more options.
|
| +
|
| +=cut
|
| +
|
| +sub set_options {
|
| + my ($self, %opts) = @_;
|
| + $$self->{$_} = $opts{$_} foreach keys %opts;
|
| +}
|
| +
|
| +=item my $value = $c->get_option($option)
|
| +
|
| +Returns the value of the corresponding option.
|
| +
|
| +=cut
|
| +
|
| +sub get_option {
|
| + my ($self, $k) = @_;
|
| + return $$self->{$k};
|
| +}
|
| +
|
| +=item $c->load($file)
|
| +
|
| +Parse the content of $file. Exits in case of errors. Returns true if some
|
| +fields have been parsed.
|
| +
|
| +=item $c->parse_error($file, $fmt, ...)
|
| +
|
| +Prints an error message and dies on syntax parse errors.
|
| +
|
| +=cut
|
| +
|
| +sub parse_error {
|
| + my ($self, $file, $msg) = (shift, shift, shift);
|
| +
|
| + $msg = sprintf($msg, @_) if (@_);
|
| + error(_g('syntax error in %s at line %d: %s'), $file, $., $msg);
|
| +}
|
| +
|
| +=item $c->parse($fh, $description)
|
| +
|
| +Parse a control file from the given filehandle. Exits in case of errors.
|
| +$description is used to describe the filehandle, ideally it's a filename
|
| +or a description of where the data comes from. It's used in error
|
| +messages. Returns true if some fields have been parsed.
|
| +
|
| +=cut
|
| +
|
| +sub parse {
|
| + my ($self, $fh, $desc) = @_;
|
| +
|
| + my $paraborder = 1;
|
| + my $parabody = 0;
|
| + my $cf; # Current field
|
| + my $expect_pgp_sig = 0;
|
| +
|
| + while (<$fh>) {
|
| + chomp;
|
| + next if m/^\s*$/ and $paraborder;
|
| + next if (m/^#/);
|
| + $paraborder = 0;
|
| + if (m/^(\S+?)\s*:\s*(.*)$/) {
|
| + $parabody = 1;
|
| + if ($1 =~ m/^-/) {
|
| + $self->parse_error($desc, _g('field cannot start with a hyphen'));
|
| + }
|
| + my ($name, $value) = ($1, $2);
|
| + if (exists $self->{$name}) {
|
| + unless ($$self->{allow_duplicate}) {
|
| + $self->parse_error($desc, _g('duplicate field %s found'), $name);
|
| + }
|
| + }
|
| + $value =~ s/\s*$//;
|
| + $self->{$name} = $value;
|
| + $cf = $name;
|
| + } elsif (m/^\s(\s*\S.*)$/) {
|
| + my $line = $1;
|
| + unless (defined($cf)) {
|
| + $self->parse_error($desc, _g('continued value line not in field'));
|
| + }
|
| + if ($line =~ /^\.+$/) {
|
| + $line = substr $line, 1;
|
| + }
|
| + $line =~ s/\s*$//;
|
| + $self->{$cf} .= "\n$line";
|
| + } elsif (m/^-----BEGIN PGP SIGNED MESSAGE-----[\r\t ]*$/) {
|
| + $expect_pgp_sig = 1;
|
| + if ($$self->{allow_pgp} and not $parabody) {
|
| + # Skip PGP headers
|
| + while (<$fh>) {
|
| + last if m/^\s*$/;
|
| + }
|
| + } else {
|
| + $self->parse_error($desc, _g('PGP signature not allowed here'));
|
| + }
|
| + } elsif (m/^\s*$/ ||
|
| + ($expect_pgp_sig && m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/)) {
|
| + if ($expect_pgp_sig) {
|
| + # Skip empty lines
|
| + $_ = <$fh> while defined($_) && $_ =~ /^\s*$/;
|
| + unless (length $_) {
|
| + $self->parse_error($desc, _g('expected PGP signature, ' .
|
| + 'found EOF after blank line'));
|
| + }
|
| + chomp;
|
| + unless (m/^-----BEGIN PGP SIGNATURE-----[\r\t ]*$/) {
|
| + $self->parse_error($desc, _g('expected PGP signature, ' .
|
| + "found something else \`%s'"), $_);
|
| + }
|
| + # Skip PGP signature
|
| + while (<$fh>) {
|
| + chomp;
|
| + last if m/^-----END PGP SIGNATURE-----[\r\t ]*$/;
|
| + }
|
| + unless (defined($_)) {
|
| + $self->parse_error($desc, _g('unfinished PGP signature'));
|
| + }
|
| + # This does not mean the signature is correct, that needs to
|
| + # be verified by gnupg.
|
| + $$self->{is_pgp_signed} = 1;
|
| + }
|
| + last; # Finished parsing one block
|
| + } else {
|
| + $self->parse_error($desc,
|
| + _g('line with unknown format (not field-colon-value)'));
|
| + }
|
| + }
|
| +
|
| + if ($expect_pgp_sig and not $$self->{is_pgp_signed}) {
|
| + $self->parse_error($desc, _g('unfinished PGP signature'));
|
| + }
|
| +
|
| + return defined($cf);
|
| +}
|
| +
|
| +=item $c->find_custom_field($name)
|
| +
|
| +Scan the fields and look for a user specific field whose name matches the
|
| +following regex: /X[SBC]*-$name/i. Return the name of the field found or
|
| +undef if nothing has been found.
|
| +
|
| +=cut
|
| +
|
| +sub find_custom_field {
|
| + my ($self, $name) = @_;
|
| + foreach my $key (keys %$self) {
|
| + return $key if $key =~ /^X[SBC]*-\Q$name\E$/i;
|
| + }
|
| + return;
|
| +}
|
| +
|
| +=item $c->get_custom_field($name)
|
| +
|
| +Identify a user field and retrieve its value.
|
| +
|
| +=cut
|
| +
|
| +sub get_custom_field {
|
| + my ($self, $name) = @_;
|
| + my $key = $self->find_custom_field($name);
|
| + return $self->{$key} if defined $key;
|
| + return;
|
| +}
|
| +
|
| +=item $c->save($filename)
|
| +
|
| +Write the string representation of the control information to a
|
| +file.
|
| +
|
| +=item my $str = $c->output()
|
| +
|
| +=item "$c"
|
| +
|
| +Get a string representation of the control information. The fields
|
| +are sorted in the order in which they have been read or set except
|
| +if the order has been overridden with set_output_order().
|
| +
|
| +=item $c->output($fh)
|
| +
|
| +Print the string representation of the control information to a
|
| +filehandle.
|
| +
|
| +=cut
|
| +
|
| +sub output {
|
| + my ($self, $fh) = @_;
|
| + my $str = '';
|
| + my @keys;
|
| + if (@{$$self->{out_order}}) {
|
| + my $i = 1;
|
| + my $imp = {};
|
| + $imp->{$_} = $i++ foreach @{$$self->{out_order}};
|
| + @keys = sort {
|
| + if (defined $imp->{$a} && defined $imp->{$b}) {
|
| + $imp->{$a} <=> $imp->{$b};
|
| + } elsif (defined($imp->{$a})) {
|
| + -1;
|
| + } elsif (defined($imp->{$b})) {
|
| + 1;
|
| + } else {
|
| + $a cmp $b;
|
| + }
|
| + } keys %$self;
|
| + } else {
|
| + @keys = @{$$self->{in_order}};
|
| + }
|
| +
|
| + foreach my $key (@keys) {
|
| + if (exists $self->{$key}) {
|
| + my $value = $self->{$key};
|
| + # Skip whitespace-only fields
|
| + next if $$self->{drop_empty} and $value !~ m/\S/;
|
| + # Escape data to follow control file syntax
|
| + my @lines = split(/\n/, $value);
|
| + $value = (scalar @lines) ? shift @lines : '';
|
| + foreach (@lines) {
|
| + s/\s+$//;
|
| + if (/^$/ or /^\.+$/) {
|
| + $value .= "\n .$_";
|
| + } else {
|
| + $value .= "\n $_";
|
| + }
|
| + }
|
| + # Print it out
|
| + if ($fh) {
|
| + print { $fh } "$key: $value\n"
|
| + or syserr(_g('write error on control data'));
|
| + }
|
| + $str .= "$key: $value\n" if defined wantarray;
|
| + }
|
| + }
|
| + return $str;
|
| +}
|
| +
|
| +=item $c->set_output_order(@fields)
|
| +
|
| +Define the order in which fields will be displayed in the output() method.
|
| +
|
| +=cut
|
| +
|
| +sub set_output_order {
|
| + my ($self, @fields) = @_;
|
| +
|
| + $$self->{out_order} = [@fields];
|
| +}
|
| +
|
| +=item $c->apply_substvars($substvars)
|
| +
|
| +Update all fields by replacing the variables references with
|
| +the corresponding value stored in the Dpkg::Substvars object.
|
| +
|
| +=cut
|
| +
|
| +sub apply_substvars {
|
| + my ($self, $substvars, %opts) = @_;
|
| +
|
| + # Add substvars to refer to other fields
|
| + foreach my $f (keys %$self) {
|
| + $substvars->set_as_used("F:$f", $self->{$f});
|
| + }
|
| +
|
| + foreach my $f (keys %$self) {
|
| + my $v = $substvars->substvars($self->{$f}, %opts);
|
| + if ($v ne $self->{$f}) {
|
| + my $sep;
|
| +
|
| + $sep = field_get_sep_type($f);
|
| +
|
| + # If we replaced stuff, ensure we're not breaking
|
| + # a dependency field by introducing empty lines, or multiple
|
| + # commas
|
| +
|
| + if ($sep & (FIELD_SEP_COMMA | FIELD_SEP_LINE)) {
|
| + # Drop empty/whitespace-only lines
|
| + $v =~ s/\n[ \t]*(\n|$)/$1/;
|
| + }
|
| +
|
| + if ($sep & FIELD_SEP_COMMA) {
|
| + $v =~ s/,[\s,]*,/,/g;
|
| + $v =~ s/^\s*,\s*//;
|
| + $v =~ s/\s*,\s*$//;
|
| + }
|
| + }
|
| + $v =~ s/\$\{\}/\$/g; # XXX: what for?
|
| +
|
| + $self->{$f} = $v;
|
| + }
|
| +}
|
| +
|
| +package Dpkg::Control::HashCore::Tie;
|
| +
|
| +# This object is used to tie a hash. It implements hash-like functions by
|
| +# normalizing the name of fields received in keys (using
|
| +# Dpkg::Control::Fields::field_capitalize). It also stores the order in
|
| +# which fields have been added in order to be able to dump them in the
|
| +# same order. But the order information is stored in a parent object of
|
| +# type Dpkg::Control.
|
| +
|
| +use Dpkg::Checksums;
|
| +use Dpkg::Control::FieldsCore;
|
| +
|
| +use Carp;
|
| +use Tie::Hash;
|
| +use parent -norequire, qw(Tie::ExtraHash);
|
| +
|
| +# $self->[0] is the real hash
|
| +# $self->[1] is a reference to the hash contained by the parent object.
|
| +# This reference bypasses the top-level scalar reference of a
|
| +# Dpkg::Control::Hash, hence ensuring that that reference gets DESTROYed
|
| +# properly.
|
| +
|
| +# Dpkg::Control::Hash->new($parent)
|
| +#
|
| +# Return a reference to a tied hash implementing storage of simple
|
| +# "field: value" mapping as used in many Debian-specific files.
|
| +
|
| +sub new {
|
| + my $class = shift;
|
| + my $hash = {};
|
| + tie %{$hash}, $class, @_;
|
| + return $hash;
|
| +}
|
| +
|
| +sub TIEHASH {
|
| + my ($class, $parent) = @_;
|
| + croak 'parent object must be Dpkg::Control::Hash'
|
| + if not $parent->isa('Dpkg::Control::HashCore') and
|
| + not $parent->isa('Dpkg::Control::Hash');
|
| + return bless [ {}, $$parent ], $class;
|
| +}
|
| +
|
| +sub FETCH {
|
| + my ($self, $key) = @_;
|
| + $key = lc($key);
|
| + return $self->[0]->{$key} if exists $self->[0]->{$key};
|
| + return;
|
| +}
|
| +
|
| +sub STORE {
|
| + my ($self, $key, $value) = @_;
|
| + my $parent = $self->[1];
|
| + $key = lc($key);
|
| + if (not exists $self->[0]->{$key}) {
|
| + push @{$parent->{in_order}}, field_capitalize($key);
|
| + }
|
| + $self->[0]->{$key} = $value;
|
| +}
|
| +
|
| +sub EXISTS {
|
| + my ($self, $key) = @_;
|
| + $key = lc($key);
|
| + return exists $self->[0]->{$key};
|
| +}
|
| +
|
| +sub DELETE {
|
| + my ($self, $key) = @_;
|
| + my $parent = $self->[1];
|
| + my $in_order = $parent->{in_order};
|
| + $key = lc($key);
|
| + if (exists $self->[0]->{$key}) {
|
| + delete $self->[0]->{$key};
|
| + @$in_order = grep { lc($_) ne $key } @$in_order;
|
| + return 1;
|
| + } else {
|
| + return 0;
|
| + }
|
| +}
|
| +
|
| +sub FIRSTKEY {
|
| + my $self = shift;
|
| + my $parent = $self->[1];
|
| + foreach (@{$parent->{in_order}}) {
|
| + return $_ if exists $self->[0]->{lc($_)};
|
| + }
|
| +}
|
| +
|
| +sub NEXTKEY {
|
| + my ($self, $last) = @_;
|
| + my $parent = $self->[1];
|
| + my $found = 0;
|
| + foreach (@{$parent->{in_order}}) {
|
| + if ($found) {
|
| + return $_ if exists $self->[0]->{lc($_)};
|
| + } else {
|
| + $found = 1 if $_ eq $last;
|
| + }
|
| + }
|
| + return;
|
| +}
|
| +
|
| +1;
|
| +
|
| +=back
|
| +
|
| +=head1 CHANGES
|
| +
|
| +=head2 Version 1.01
|
| +
|
| +New method: parse_error().
|
| +
|
| +=head1 AUTHOR
|
| +
|
| +Raphaël Hertzog <hertzog@debian.org>.
|
| +
|
| +=cut
|
| +
|
| +1;
|
|
|