* dselect/baselist.cc (baselist::startdisplay): Set helpscreen_attr
on monochrome terminals.
+2007-12-28 Raphael Hertzog <hertzog@debian.org>
+
+ * scripts/Dpkg/Cdata.pm, scripts/Dpkg/Control.pm: Add two new
+ module to parse and manipulate files like debian/control.
+
2007-12-28 Raphael Hertzog <hertzog@debian.org>
* scripts/Dpkg/ErrorHandling.pm (syntaxerr): New function to
--- /dev/null
+# Copyright 2007 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, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Cdata;
+
+use strict;
+use warnings;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(syntaxerr);
+use Dpkg::Fields;
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw(parsecdata);
+
+=head1 NAME
+
+Dpkg::Cdata - parse and manipulate a block of RFC822-like fields
+
+=head1 DESCRIPTION
+
+The Dpkg::Cdata module exports one function 'parsecdata' that reads a
+block of data (usually a block following the debian/control format)
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item $obj = Dpkg::Cdata::parsecdata($input, $file, %options)
+
+$input is a filehandle, $file is the name of the file corresponding to
+$input. %options can contain two parameters: allow_pgp=>1 allows the parser
+to extrac the block of a data in a PGP-signed message (defaults to 0),
+and allow_duplicate=>1 ask the parser to not fail when it detects
+duplicate fields.
+
+The return value is a reference to a tied hash (Dpkg::Fields::Object) that
+can be used to access the various fields.
+
+=cut
+sub parsecdata {
+ my ($input, $file, %options) = @_;
+
+ $options{allow_pgp} = 0 unless exists $options{allow_pgp};
+ $options{allow_duplicate} = 0 unless exists $options{allow_duplicate};
+
+ my $paraborder = 1;
+ my $fields = undef;
+ my $cf = ''; # Current field
+ my $expect_pgp_sig = 0;
+ while (<$input>) {
+ s/\s*\n$//;
+ next if (m/^$/ and $paraborder);
+ next if (m/^#/);
+ $paraborder = 0;
+ if (m/^(\S+?)\s*:\s*(.*)$/) {
+ unless (defined $fields) {
+ my %f;
+ tie %f, "Dpkg::Fields::Object";
+ $fields = \%f;
+ }
+ if (exists $fields->{$1}) {
+ unless ($options{allow_duplicate}) {
+ syntaxerr($file, sprintf(_g("duplicate field %s found"), capit($1)));
+ }
+ }
+ $fields->{$1} = $2;
+ $cf = $1;
+ } elsif (m/^\s+\S/) {
+ length($cf) || syntaxerr($file, _g("continued value line not in field"));
+ $fields->{$cf} .= "\n$_";
+ } elsif (m/^-----BEGIN PGP SIGNED MESSAGE/) {
+ $expect_pgp_sig = 1;
+ if ($options{allow_pgp}) {
+ # Skip PGP headers
+ while (<$input>) {
+ last if m/^$/;
+ }
+ } else {
+ syntaxerr($file, _g("PGP signature not allowed here"));
+ }
+ } elsif (m/^$/) {
+ if ($expect_pgp_sig) {
+ # Skip empty lines
+ $_ = <$input> while defined($_) && $_ =~ /^\s*$/;
+ length($_) ||
+ syntaxerr($file, _g("expected PGP signature, found EOF after blank line"));
+ s/\n$//;
+ m/^-----BEGIN PGP SIGNATURE/ ||
+ syntaxerr($file,
+ sprintf(_g("expected PGP signature, found something else \`%s'"), $_));
+ # Skip PGP signature
+ while (<$input>) {
+ last if m/^-----END PGP SIGNATURE/;
+ }
+ length($_) ||
+ syntaxerr($file, _g("unfinished PGP signature"));
+ }
+ last; # Finished parsing one block
+ } else {
+ syntaxerr($file, _g("line with unknown format (not field-colon-value)"));
+ }
+ }
+ return $fields;
+}
+
+=back
+
+=cut
+1;
--- /dev/null
+# Copyright 2007 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, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Control;
+
+use strict;
+use warnings;
+
+use Dpkg::Cdata;
+use Dpkg::ErrorHandling qw(syserr syntaxerr);
+use Dpkg::Gettext;
+
+=head1 NAME
+
+Dpkg::Control - parse files like debian/control
+
+=head1 DESCRIPTION
+
+It provides an object to access data of files that follow the same
+syntax than debian/control.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item $c = Dpkg::Control->new($file)
+
+Create a new Dpkg::Control object for $file. If $file is omitted, it parses
+debian/control.
+
+=cut
+sub new {
+ my ($this, $arg) = @_;
+ my $class = ref($this) || $this;
+ my $self = {
+ 'source' => undef,
+ 'packages' => [],
+ };
+ bless $self, $class;
+ if ($arg) {
+ $self->parse($arg);
+ } else {
+ $self->parse("debian/control");
+ }
+ return $self;
+}
+
+=item $c->reset()
+
+Resets what got read.
+
+=cut
+sub reset {
+ my $self = shift;
+ $self->{source} = undef;
+ $self->{packages} = [];
+}
+
+=item $c->parse($file)
+
+Parse the content of $file. Exits in case of errors.
+
+=cut
+sub parse {
+ my ($self, $file) = @_;
+ $self->reset();
+ # Parse
+ open(CDATA, "<", $file) || syserr(_g("cannot read %s"), $file);
+ my $cdata = parsecdata(\*CDATA, $file);
+ return if not defined $cdata;
+ $self->{source} = $cdata;
+ unless (exists $cdata->{Source}) {
+ syntaxerr($file, _g("first block lacks a source field"));
+ }
+ while (1) {
+ $cdata = parsecdata(\*CDATA, $file);
+ last if not defined $cdata;
+ push @{$self->{packages}}, $cdata;
+ unless (exists $cdata->{Package}) {
+ syntaxerr($file, _g("block lacks a package field"));
+ }
+ }
+ close(CDATA);
+}
+
+=item $c->get_source()
+
+Returns a reference to a hash containing the fields concerning the
+source package. The hash is tied to Dpkg::Cdata::Object.
+
+=cut
+sub get_source {
+ my $self = shift;
+ return $self->{source};
+}
+
+=item $c->get_pkg_by_idx($idx)
+
+Returns a reference to a hash containing the fields concerning the binary
+package numbered $idx (starting at 1). The hash is tied to
+Dpkg::Cdata::Object.
+
+=cut
+sub get_pkg_by_idx {
+ my ($self, $idx) = @_;
+ return $self->{packages}[--$idx];
+}
+
+=item $c->get_pkg_by_name($name)
+
+Returns a reference to a hash containing the fields concerning the binary
+package named $name. The hash is tied to Dpkg::Cdata::Object.
+
+=cut
+sub get_pkg_by_name {
+ my ($self, $name) = @_;
+ foreach my $pkg (@{$self->{packages}}) {
+ return $pkg if ($pkg->{Package} eq $name);
+ }
+ return undef;
+}
+
+
+=item $c->get_packages()
+
+Returns a list containing the hashes for all binary packages.
+
+=cut
+sub get_packages {
+ my $self = shift;
+ return @{$self->{packages}};
+}
+
+=item $c->dump($filehandle)
+
+Dump the content into a filehandle.
+
+=cut
+sub dump {
+ my ($self, $fh) = @_;
+ tied(%{$self->{source}})->dump($fh);
+ foreach my $pkg (@{$self->{packages}}) {
+ print $fh "\n";
+ tied(%{$pkg})->dump($fh);
+ }
+}
+
+=back
+
+=head1 AUTHOR
+
+Raphael Hertzog <hertzog@debian.org>.
+
+=cut
+
+1;
}
}
+package Dpkg::Fields::Object;
+
+=head1 OTHER OBJECTS
+
+=head2 Dpkg::Fields::Object
+
+This object is used to tie a hash. It implements hash-like functions by
+normalizing the name of fields received in keys (using
+Dpkg::Fields::capit). It also stores the order in which fields have been
+added in order to be able to dump them in the same order.
+
+You can also dump the content of the hash with tied(%hash)->dump($fh).
+
+=cut
+use Tie::Hash;
+our @ISA = qw(Tie::ExtraHash Tie::Hash);
+
+use Dpkg::ErrorHandling qw(internerr syserr);
+
+# Import capit
+Dpkg::Fields->import('capit', 'sort_field_by_importance');
+
+# $self->[0] is the real hash
+# $self->[1] is an array containing the ordered list of keys
+
+=head2 Dpkg::Fields::Object->new()
+
+Return a reference to a tied hash implementing storage of simple
+"field: value" mapping as used in many Debian-specific files.
+
+=cut
+sub new {
+ my $hash = {};
+ tie %{$hash}, 'Dpkg::Fields::Object';
+ return $hash;
+}
+
+sub TIEHASH {
+ my $class = shift;
+ return bless [{}, []], $class;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ $key = capit($key);
+ return $self->[0]->{$key} if exists $self->[0]->{$key};
+ return undef;
+}
+
+sub STORE {
+ my ($self, $key, $value) = @_;
+ $key = capit($key);
+ if (not exists $self->[0]->{$key}) {
+ push @{$self->[1]}, $key;
+ }
+ $self->[0]->{$key} = $value;
+}
+
+sub EXISTS {
+ my ($self, $key) = @_;
+ $key = capit($key);
+ return exists $self->[0]->{$key};
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+ $key = capit($key);
+ if (exists $self->[0]->{$key}) {
+ delete $self->[0]->{$key};
+ @{$self->[1]} = grep { $_ ne $key } @{$self->[1]};
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ foreach (@{$self->[1]}) {
+ return $_ if exists $self->[0]->{$_};
+ }
+}
+
+sub NEXTKEY {
+ my ($self, $last) = @_;
+ my $found = 0;
+ foreach (@{$self->[1]}) {
+ if ($found) {
+ return $_ if exists $self->[0]->{$_};
+ } else {
+ $found = 1 if $_ eq $last;
+ }
+ }
+ return undef;
+}
+
+sub dump {
+ my ($self, $fh) = @_;
+ foreach (@{$self->[1]}) {
+ if (exists $self->[0]->{$_}) {
+ print $fh "$_: " . $self->[0]->{$_} . "\n";
+ }
+ }
+}
+
+sub output {
+ my ($self, $fh, $substvars) = @_;
+
+ # Add substvars to refer to other fields
+ if (defined($substvars)) {
+ foreach my $f (keys %{$self->[0]}) {
+ $substvars->set("F:$f", $self->[0]->{$f});
+ }
+ }
+
+ for my $f (sort sort_field_by_importance keys %{$self->[0]}) {
+ my $v = $self->[0]->{$f};
+ if (defined($substvars)) {
+ $v = $substvars->substvars($v);
+ }
+ $v =~ m/\S/ || next; # delete whitespace-only fields
+ $v =~ m/\n\S/ &&
+ internerr(_g("field %s has newline then non whitespace >%s<"),
+ $f, $v);
+ $v =~ m/\n[ \t]*\n/ &&
+ internerr(_g("field %s has blank lines >%s<"), $f, $v);
+ $v =~ m/\n$/ &&
+ internerr(_g("field %s has trailing newline >%s<"), $f, $v);
+ if (defined($substvars)) {
+ $v =~ s/,[\s,]*,/,/g;
+ $v =~ s/^\s*,\s*//;
+ $v =~ s/\s*,\s*$//;
+ }
+ $v =~ s/\$\{\}/\$/g;
+ print $fh "$f: $v\n" || syserr(_g("write error on control data"));
+ }
+}
+
1;
projects / dpkg / commitdiff