From 73c0afdba488997dfd34c8363533707aaedbd98e Mon Sep 17 00:00:00 2001 From: Raphael Hertzog Date: Sat, 29 Dec 2007 19:04:07 +0100 Subject: [PATCH] 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 | 5 ++ scripts/Dpkg/Cdata.pm | 124 +++++++++++++++++++++++++++++ scripts/Dpkg/Control.pm | 169 ++++++++++++++++++++++++++++++++++++++++ scripts/Dpkg/Fields.pm | 138 ++++++++++++++++++++++++++++++++ 4 files changed, 436 insertions(+) create mode 100644 scripts/Dpkg/Cdata.pm create mode 100644 scripts/Dpkg/Control.pm diff --git a/ChangeLog b/ChangeLog index f810fc13..f27de5cf 100644 --- a/ChangeLog +++ b/ChangeLog @@ -23,6 +23,11 @@ * dselect/baselist.cc (baselist::startdisplay): Set helpscreen_attr on monochrome terminals. +2007-12-28 Raphael Hertzog + + * 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 * scripts/Dpkg/ErrorHandling.pm (syntaxerr): New function to diff --git a/scripts/Dpkg/Cdata.pm b/scripts/Dpkg/Cdata.pm new file mode 100644 index 00000000..6c2790ab --- /dev/null +++ b/scripts/Dpkg/Cdata.pm @@ -0,0 +1,124 @@ +# Copyright 2007 Raphaël Hertzog + +# 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; diff --git a/scripts/Dpkg/Control.pm b/scripts/Dpkg/Control.pm new file mode 100644 index 00000000..b8450d8b --- /dev/null +++ b/scripts/Dpkg/Control.pm @@ -0,0 +1,169 @@ +# Copyright 2007 Raphaël Hertzog + +# 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 . + +=cut + +1; diff --git a/scripts/Dpkg/Fields.pm b/scripts/Dpkg/Fields.pm index 2896acb3..97d6c465 100644 --- a/scripts/Dpkg/Fields.pm +++ b/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; -- 2.39.5