Dpkg::Cdata, Dpkg::Control, Dpkg::Fields::Object: Add new modules

* scripts/Dpkg/Cdata.pm: This module provides a function to parse a block of
fields/values like those in debian/control, in changes files or in dsc files.
* scripts/Dpkg/Fields.pm: Dpkg::Fields::Object implements a tied hash
which handles proper capitalization of fields and which can be dumped
back.
* scripts/Dpkg/Control.pm: This module parses debian/control and provide
access to the tied hash for each block (source one and binary ones).

ChangeLog

@@ -23,6 +23,11 @@
 	* 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

scripts/Dpkg/Cdata.pm

@@ -0,0 +1,124 @@
+# 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;

scripts/Dpkg/Control.pm

@@ -0,0 +1,169 @@
+# 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;

scripts/Dpkg/Fields.pm

@@ -37,4 +37,142 @@ sub sort_field_by_importance($$)
     }
 }
 
+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;