Merge branch 'parsechangelog' into controllib-removal

Conflicts:

	ChangeLog
	debian/changelog
	debian/dpkg-dev.install
	scripts/Dpkg/ErrorHandling.pm
	scripts/Makefile.am

ChangeLog

@@ -1,3 +1,11 @@
+2008-01-01  Frank Lichtenheld  <djpig@debian.org>
+
+	* scripts/dpkg-parsechangelog.pl: Make the
+	-L option actually work (it's only been eleven
+	years...)
+
+	* scripts/Dpkg/ErrorHandling.pm (report): export.
+
 2008-01-01  Samuel Thibault  <samuel.thibault@ens-lyon.org>
 
 	* utils/start-stop-daemon.c (do_stop): Do not print 'failed to kill'

debian/changelog

@@ -26,6 +26,17 @@ dpkg (1.14.15) UNRELEASED; urgency=low
     the pid. Closes: #157305, #352554
     Thanks to Samuel Thibault.
 
+  [ Frank Lichtenheld ]
+  * Make the -L option of dpkg-parsechangelog actually work (it's
+    only been eleven years...)
+  * Import the code from my external Parse::DebianChangelog as
+    Dpkg::Changelog and Dpkg::Changelog::Debian. Using this
+    from parsechangelog/debian adds the following requested
+    features:
+     - Option to use a non-lossy format. Closes: #95579
+     - Various options to better control how many entries
+       should be displayed. Closes: #226932
+
   [ Updated dpkg translations ]
   * Norwegian Bokmål (Hans Fredrik Nordhaug). Closes: #457918
 

debian/dpkg-dev.install

@@ -65,6 +65,8 @@ usr/share/man/*/dpkg-source.1
 usr/share/perl5/Dpkg/Arch.pm
 usr/share/perl5/Dpkg/BuildOptions.pm
 usr/share/perl5/Dpkg/Compression.pm
+usr/share/perl5/Dpkg/Changelog.pm
+usr/share/perl5/Dpkg/Changelog/Debian.pm
 usr/share/perl5/Dpkg/ErrorHandling.pm
 usr/share/perl5/Dpkg/Deps.pm
 usr/share/perl5/Dpkg/Fields.pm

scripts/Dpkg/Changelog.pm

@@ -0,0 +1,841 @@
+#
+# Dpkg::Changelog
+#
+# Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de>
+#
+#    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 St, Fifth Floor, Boston, MA  02110-1301 USA
+#
+
+=head1 NAME
+
+Dpkg::Changelog
+
+=head1 DESCRIPTION
+
+to be written
+
+=head2 Functions
+
+=cut
+
+package Dpkg::Changelog;
+
+use strict;
+use warnings;
+
+use English;
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling qw(warning report);
+
+use base qw(Exporter);
+
+our %EXPORT_TAGS = ( 'util' => [ qw(
+                find_closes
+                data2rfc822
+                data2rfc822_mult
+                get_dpkg_changes
+) ] );
+our @EXPORT_OK = @{$EXPORT_TAGS{util}};
+
+=pod
+
+=head3 init
+
+Creates a new object instance. Takes a reference to a hash as
+optional argument, which is interpreted as configuration options.
+There are currently no supported general configuration options, but
+see the other methods for more specific configuration options which
+can also specified to C<init>.
+
+If C<infile> or C<instring> are specified (see L<parse>), C<parse()>
+is called from C<init>. If a fatal error is encountered during parsing
+(e.g. the file can't be opened), C<init> will not return a
+valid object but C<undef>!
+
+=cut
+
+sub init {
+    my $classname = shift;
+    my $config = shift || {};
+    my $self = {};
+    bless( $self, $classname );
+
+    $config->{verbose} = 1 if $config->{debug};
+    $self->{config} = $config;
+
+    $self->reset_parse_errors;
+
+    if ($self->{config}{infile} || $self->{config}{instring}) {
+	defined($self->parse) or return undef;
+    }
+
+    return $self;
+}
+
+=pod
+
+=head3 reset_parse_errors
+
+Can be used to delete all information about errors ocurred during
+previous L<parse> runs. Note that C<parse()> also calls this method.
+
+=cut
+
+sub reset_parse_errors {
+    my ($self) = @_;
+
+    $self->{errors}{parser} = [];
+}
+
+sub _do_parse_error {
+    my ($self, $file, $line_nr, $error, $line) = @_;
+    shift;
+
+    push @{$self->{errors}{parser}}, [ @_ ];
+
+    unless ($self->{config}{quiet}) {
+	if ($line) {
+	    warning("%20s(l$NR): $error\nLINE: $line", $file);
+	} else {
+	    warning("%20s(l$NR): $error", $file);
+	}
+    }
+}
+
+=pod
+
+=head3 get_parse_errors
+
+Returns all error messages from the last L<parse> run.
+If called in scalar context returns a human readable
+string representation. If called in list context returns
+an array of arrays. Each of these arrays contains
+
+=over 4
+
+=item 1.
+
+the filename of the parsed file or C<String> if a string was
+parsed directly
+
+=item 2.
+
+the line number where the error occurred
+
+=item 3.
+
+an error description
+
+=item 4.
+
+the original line
+
+=back
+
+NOTE: This format isn't stable yet and may change in later versions
+of this module.
+
+=cut
+
+sub get_parse_errors {
+    my ($self) = @_;
+
+    if (wantarray) {
+	return @{$self->{errors}{parser}};
+    } else {
+	my $res = "";
+	foreach my $e (@{$self->{errors}{parser}}) {
+	    if ($e->[3]) {
+		$res .= report(_g('warning'),_g("%s(l%s): %s\nLINE: %s"), @$e );
+	    } else {
+		$res .= report(_g('warning'),_g("%s(l%s): %s"), @$e );
+	    }
+	}
+	return $res;
+    }
+}
+
+sub _do_fatal_error {
+    my ($self, $msg, @msg) = @_;
+
+    $self->{errors}{fatal} = report(_g('fatal error'), $msg, @msg);
+    warning($msg, @msg) unless $self->{config}{quiet};
+}
+
+=pod
+
+=head3 get_error
+
+Get the last non-parser error (e.g. the file to parse couldn't be opened).
+
+=cut
+
+sub get_error {
+    my ($self) = @_;
+
+    return $self->{errors}{fatal};
+}
+
+=pod
+
+=head3 data
+
+C<data> returns an array (if called in list context) or a reference
+to an array of Dpkg::Changelog::Entry objects which each
+represent one entry of the changelog.
+
+This method supports the common output options described in
+section L<"COMMON OUTPUT OPTIONS">.
+
+=cut
+
+sub data {
+    my ($self, $config) = @_;
+
+    my $data = $self->{data};
+    if ($config) {
+	$self->{config}{DATA} = $config if $config;
+	$data = $self->_data_range( $config ) or return undef;
+    }
+    return @$data if wantarray;
+    return $data;
+}
+
+sub __sanity_check_range {
+    my ( $data, $from, $to, $since, $until, $start, $end ) = @_;
+
+    if (($$start || $$end) && ($$from || $$since || $$to || $$until)) {
+	warning(_g( "you can't combine 'count' or 'offset' with any other range option" ));
+	$$from = $$since = $$to = $$until = '';
+    }
+    if ($$from && $$since) {
+	warning(_g( "you can only specify one of 'from' and 'since', using 'since'" ));
+	$$from = '';
+    }
+    if ($$to && $$until) {
+	warning(_g( "you can only specify one of 'to' and 'until', using 'until'" ));
+	$$to = '';
+    }
+    if ($$since && ($data->[0]{Version} eq $$since)) {
+	warning(_g( "'since' option specifies most recent version, ignoring" ));
+	$$since = '';
+    }
+    if ($$until && ($data->[$#{$data}]{Version} eq $$until)) {
+	warning(_g( "'until' option specifies oldest version, ignoring" ));
+	$$until = '';
+    }
+    $$start = 0 if $$start < 0;
+    return if $$start > $#$data;
+    $$end = $#$data if $$end > $#$data;
+    return if $$end < 0;
+    $$end = $$start if $$end < $$start;
+    #TODO: compare versions
+    return 1;
+}
+
+sub _data_range {
+    my ($self, $config) = @_;
+
+    my $data = $self->data or return undef;
+
+    return [ @$data ] if $config->{all};
+
+    my $since = $config->{since} || '';
+    my $until = $config->{until} || '';
+    my $from = $config->{from} || '';
+    my $to = $config->{to} || '';
+    my $count = $config->{count} || 0;
+    my $offset = $config->{offset} || 0;
+
+    return if $offset and not $count;
+    if ($offset > 0) {
+	$offset -= ($count < 0);
+    } elsif ($offset < 0) {
+	$offset = $#$data + ($count > 0) + $offset;
+    } else {
+	$offset = $#$data if $count < 0;
+    }
+    my $start = my $end = $offset;
+    $start += $count+1 if $count < 0;
+    $end += $count-1 if $count > 0;
+
+    return unless __sanity_check_range( $data, \$from, \$to,
+					\$since, \$until,
+					\$start, \$end );
+
+
+    unless ($from or $to or $since or $until or $start or $end) {
+	return [ @$data ] if $config->{default_all} and not $count;
+	return [ $data->[0] ];
+    }
+
+    return [ @{$data}[$start .. $end] ] if $start or $end;
+
+    my @result;
+
+    my $include = 1;
+    $include = 0 if $to or $until;
+    foreach (@$data) {
+	my $v = $_->{Version};
+	$include = 1 if $v eq $to;
+	last if $v eq $since;
+
+	push @result, $_ if $include;
+
+	$include = 1 if $v eq $until;
+	last if $v eq $from;
+    }
+
+    return \@result;
+}
+
+sub _abort_early {
+    my ($self) = @_;
+
+    my $data = $self->data or return;
+    my $config = $self->{config} or return;
+
+#    use Data::Dumper;
+#    warn "Abort early? (\$# = $#$data)\n".Dumper($config);
+
+    return if $config->{all};
+
+    my $since = $config->{since} || '';
+    my $until = $config->{until} || '';
+    my $from = $config->{from} || '';
+    my $to = $config->{to} || '';
+    my $count = $config->{count} || 0;
+    my $offset = $config->{offset} || 0;
+
+    return if $offset and not $count;
+    return if $offset < 0 or $count < 0;
+    if ($offset > 0) {
+	$offset -= ($count < 0);
+    }
+    my $start = my $end = $offset;
+    $end += $count-1 if $count > 0;
+
+    unless ($from or $to or $since or $until or $start or $end) {
+	return if not $count;
+	return 1 if @$data;
+    }
+
+    return 1 if ($start or $end)
+	and $start < @$data and $end < @$data;
+
+    return unless $since or $from;
+    foreach (@$data) {
+	my $v = $_->{Version};
+
+	return 1 if $v eq $since;
+	return 1 if $v eq $from;
+    }
+
+    return;
+}
+
+=pod
+
+=head3 dpkg
+
+(and B<dpkg_str>)
+
+C<dpkg> returns a hash (in list context) or a hash reference
+(in scalar context) where the keys are field names and the values are
+field values. The following fields are given:
+
+=over 4
+
+=item Source
+
+package name (in the first entry)
+
+=item Version
+
+packages' version (from first entry)
+
+=item Distribution
+
+target distribution (from first entry)
+
+=item Urgency
+
+urgency (highest of all printed entries)
+
+=item Maintainer
+
+person that created the (first) entry
+
+=item Date
+
+date of the (first) entry
+
+=item Closes
+
+bugs closed by the entry/entries, sorted by bug number
+
+=item Changes
+
+content of the the entry/entries
+
+=back
+
+C<dpkg_str> returns a stringified version of this hash. The fields are
+ordered like in the list above.
+
+Both methods support the common output options described in
+section L<"COMMON OUTPUT OPTIONS">.
+
+=head3 dpkg_str
+
+See L<dpkg>.
+
+=cut
+
+our ( %FIELDIMPS, %URGENCIES );
+BEGIN {
+    my $i=100;
+    grep($FIELDIMPS{$_}=$i--,
+	 qw(Source Version Distribution Urgency Maintainer Date Closes
+	    Changes));
+    $i=1;
+    grep($URGENCIES{$_}=$i++,
+	 qw(low medium high critical emergency));
+}
+
+sub dpkg {
+    my ($self, $config) = @_;
+
+    $self->{config}{DPKG} = $config if $config;
+
+    $config = $self->{config}{DPKG} || {};
+    my $data = $self->_data_range( $config ) or return undef;
+
+    my %f;
+    foreach my $field (qw( Urgency Source Version
+			   Distribution Maintainer Date )) {
+	$f{$field} = $data->[0]{$field};
+    }
+
+    $f{Changes} = get_dpkg_changes( $data->[0] );
+    $f{Closes} = [ @{$data->[0]{Closes}} ];
+
+    my $first = 1; my $urg_comment = '';
+    foreach my $entry (@$data) {
+	$first = 0, next if $first;
+
+	my $oldurg = $f{Urgency} || '';
+	my $oldurgn = $URGENCIES{$f{Urgency}} || -1;
+	my $newurg = $entry->{Urgency_LC} || '';
+	my $newurgn = $URGENCIES{$entry->{Urgency_LC}} || -1;
+	$f{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg;
+	$urg_comment .= $entry->{Urgency_Comment};
+
+	$f{Changes} .= "\n .".get_dpkg_changes( $entry );
+	push @{$f{Closes}}, @{$entry->{Closes}};
+    }
+
+    $f{Closes} = join " ", sort { $a <=> $b } @{$f{Closes}};
+    $f{Urgency} .= $urg_comment;
+
+    return %f if wantarray;
+    return \%f;
+}
+
+sub dpkg_str {
+    return data2rfc822( scalar dpkg(@_), \%FIELDIMPS );
+}
+
+=pod
+
+=head3 rfc822
+
+(and B<rfc822_str>)
+
+C<rfc822> returns an array of hashes (in list context) or a reference
+to this array (in scalar context) where each hash represents one entry
+in the changelog. For the format of such a hash see the description
+of the L<"dpkg"> method (while ignoring the remarks about which
+values are taken from the first entry).
+
+C<rfc822_str> returns a stringified version of this array.
+
+Both methods support the common output options described in
+section L<"COMMON OUTPUT OPTIONS">.
+
+=head3 rfc822_str
+
+See L<rfc822>.
+
+=cut
+
+sub rfc822 {
+    my ($self, $config) = @_;
+
+    $self->{config}{RFC822} = $config if $config;
+
+    $config = $self->{config}{RFC822} || {};
+    my $data = $self->_data_range( $config ) or return undef;
+    my @out_data;
+
+    foreach my $entry (@$data) {
+	my %f;
+	foreach my $field (qw( Urgency Source Version
+			   Distribution Maintainer Date )) {
+	    $f{$field} = $entry->{$field};
+	}
+
+	$f{Urgency} .= $entry->{Urgency_Comment};
+	$f{Changes} = get_dpkg_changes( $entry );
+	$f{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}};
+	push @out_data, \%f;
+    }
+
+    return @out_data if wantarray;
+    return \@out_data;
+}
+
+sub rfc822_str {
+    return data2rfc822_mult( scalar rfc822(@_), \%FIELDIMPS );
+}
+
+=pod
+
+=head1 COMMON OUTPUT OPTIONS
+
+The following options are supported by all output methods,
+all take a version number as value:
+
+=over 4
+
+=item since
+
+Causes changelog information from all versions strictly
+later than B<version> to be used.
+
+=item until
+
+Causes changelog information from all versions strictly
+earlier than B<version> to be used.
+
+=item from
+
+Similar to C<since> but also includes the information for the
+specified B<version> itself.
+
+=item to
+
+Similar to C<until> but also includes the information for the
+specified B<version> itself.
+
+=back
+
+The following options also supported by all output methods but
+don't take version numbers as values:
+
+=over 4
+
+=item all
+
+If set to a true value, all entries of the changelog are returned,
+this overrides all other options.
+
+=item count
+
+Expects a signed integer as value. Returns C<value> entries from the
+top of the changelog if set to a positive integer, and C<abs(value)>
+entries from the tail if set to a negative integer.
+
+=item offset
+
+Expects a signed integer as value. Changes the starting point for
+C<count>, either counted from the top (positive integer) or from
+the tail (negative integer). C<offset> has no effect if C<count>
+wasn't given as well.
+
+=back
+
+Some examples for the above options. Imagine an example changelog with
+entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1.
+
+            Call                               Included entries
+ C<E<lt>formatE<gt>({ since =E<gt> '2.0' })>  3.1, 3.0, 2.2
+ C<E<lt>formatE<gt>({ until =E<gt> '2.0' })>  1.3, 1.2
+ C<E<lt>formatE<gt>({ from =E<gt> '2.0' })>   3.1, 3.0, 2.2, 2.1, 2.0
+ C<E<lt>formatE<gt>({ to =E<gt> '2.0' })>     2.0, 1.3, 1.2
+ C<E<lt>formatE<gt>({ count =E<gt> 2 }>>      3.1, 3.0
+ C<E<lt>formatE<gt>({ count =E<gt> -2 }>>     1.3, 1.2
+ C<E<lt>formatE<gt>({ count =E<gt> 3,
+		      offset=E<gt> 2 }>>      2.2, 2.1, 2.0
+ C<E<lt>formatE<gt>({ count =E<gt> 2,
+		      offset=E<gt> -3 }>>     2.0, 1.3
+ C<E<lt>formatE<gt>({ count =E<gt> -2,
+		      offset=E<gt> 3 }>>      3.0, 2.2
+ C<E<lt>formatE<gt>({ count =E<gt> -2,
+		      offset=E<gt> -3 }>>     2.2, 2.1
+
+Any combination of one option of C<since> and C<from> and one of
+C<until> and C<to> returns the intersection of the two results
+with only one of the options specified.
+
+=head1 UTILITY FUNCTIONS
+
+=head3 find_closes
+
+Takes one string as argument and finds "Closes: #123456, #654321" statements
+as supported by the Debian Archive software in it. Returns all closed bug
+numbers in an array reference.
+
+=cut
+
+sub find_closes {
+    my $changes = shift;
+    my @closes = ();
+
+    while ($changes &&
+	   ($changes =~ /closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*/ig)) {
+	push(@closes, $& =~ /\#?\s?(\d+)/g);
+    }
+
+    @closes = sort { $a <=> $b } @closes;
+    return \@closes;
+}
+
+=pod
+
+=head3 data2rfc822
+
+Takes two hash references as arguments. The first should contain the
+data to output in RFC822 format. The second can contain a sorting order
+for the fields. The higher the numerical value of the hash value, the
+earlier the field is printed if it exists.
+
+Return the data in RFC822 format as string.
+
+=cut
+
+sub data2rfc822 {
+    my ($data, $fieldimps) = @_;
+    my $rfc822_str = '';
+
+# based on /usr/lib/dpkg/controllib.pl
+    for my $f (sort { $fieldimps->{$b} <=> $fieldimps->{$a} } keys %$data) {
+	my $v= $data->{$f} or next;
+	$v =~ m/\S/o || next; # delete whitespace-only fields
+	$v =~ m/\n\S/o
+	    && warning(_g("field %s has newline then non whitespace >%s<"),
+			  $f, $v);
+	$v =~ m/\n[ \t]*\n/o && warning(_g("field %s has blank lines >%s<"),
+					   $f, $v);
+	$v =~ m/\n$/o && warning(_g("field %s has trailing newline >%s<"),
+				    $f, $v);
+	$v =~ s/\$\{\}/\$/go;
+	$rfc822_str .= "$f: $v\n";
+    }
+
+    return $rfc822_str;
+}
+
+=pod
+
+=head3 data2rfc822_mult
+
+The first argument should be an array ref to an array of hash references.
+The second argument is a hash reference and has the same meaning as
+the second argument of L<data2rfc822>.
+
+Calls L<data2rfc822> for each element of the array given as first
+argument and returns the concatenated results.
+
+=cut
+
+sub data2rfc822_mult {
+    my ($data, $fieldimps) = @_;
+    my @rfc822 = ();
+
+    foreach my $entry (@$data) {
+	push @rfc822, data2rfc822($entry,$fieldimps);
+    }
+
+    return join "\n", @rfc822;
+}
+
+=pod
+
+=head3 get_dpkg_changes
+
+Takes a Dpkg::Changelog::Entry object as first argument.
+
+Returns a string that is suitable for using it in a C<Changes> field
+in the output format of C<dpkg-parsechangelog>.
+
+=cut
+
+sub get_dpkg_changes {
+    my $changes = "\n ".($_[0]->Header||'')."\n .\n".($_[0]->Changes||'');
+    chomp $changes;
+    $changes =~ s/^ $/ ./mgo;
+    return $changes;
+}
+
+=head1 NAME
+
+Dpkg::Changelog::Entry - represents one entry in a Debian changelog
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head2 Methods
+
+=head3 init
+
+Creates a new object, no options.
+
+=head3 new
+
+Alias for init.
+
+=head3 is_empty
+
+Checks if the object is actually initialized with data. This
+currently simply checks if one of the fields Source, Version,
+Maintainer, Date, or Changes is initalized.
+
+=head2 Accessors
+
+The following fields are available via accessor functions (all
+fields are string values unless otherwise noted):
+
+=over 4
+
+=item *
+
+Source
+
+=item *
+
+Version
+
+=item *
+
+Distribution
+
+=item *
+
+Urgency
+
+=item *
+
+ExtraFields (all fields except for urgency as hash)
+
+=item *
+
+Header (the whole header in verbatim form)
+
+=item *
+
+Changes (the actual content of the bug report, in verbatim form)
+
+=item *
+
+Trailer (the whole trailer in verbatim form)
+
+=item *
+
+Closes (Array of bug numbers)
+
+=item *
+
+Maintainer (name B<and> email address)
+
+=item *
+
+Date
+
+=item *
+
+Timestamp (Date expressed in seconds since the epoche)
+
+=item *
+
+ERROR (last parse error related to this entry in the format described
+at Dpkg::Changelog::get_parse_errors.
+
+=back
+
+=cut
+
+package Dpkg::Changelog::Entry;
+
+use base qw( Class::Accessor );
+
+Dpkg::Changelog::Entry->mk_accessors(qw( Closes Changes Maintainer
+					 MaintainerEmail Date
+					 Urgency Distribution
+					 Source Version ERROR
+					 ExtraFields Header
+					 Trailer Timestamp ));
+
+sub new {
+    return init(@_);
+}
+
+sub init {
+    my $classname = shift;
+    my $self = {};
+    bless( $self, $classname );
+
+    return $self;
+}
+
+sub is_empty {
+    my ($self) = @_;
+
+    return !($self->{Changes}
+	     || $self->{Source}
+	     || $self->{Version}
+	     || $self->{Maintainer}
+	     || $self->{Date});
+}
+
+1;
+__END__
+
+=head1 AUTHOR
+
+Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright E<copy> 2005, 2007 by Frank Lichtenheld
+
+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 St, Fifth Floor, Boston, MA  02110-1301 USA
+
+=cut

scripts/Dpkg/Changelog/Debian.pm

@@ -0,0 +1,358 @@
+#
+# Dpkg::Changelog::Debian
+#
+# Copyright 1996 Ian Jackson
+# Copyright 2005 Frank Lichtenheld <frank@lichtenheld.de>
+#
+#    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 St, Fifth Floor, Boston, MA  02110-1301 USA
+#
+
+=head1 NAME
+
+Dpkg::Changelog::Debian - parse Debian changelogs
+
+=head1 SYNOPSIS
+
+    use Parse::DebianChangelog;
+
+    my $chglog = Parse::DebianChangelog->init( { infile => 'debian/changelog',
+                                                 HTML => { outfile => 'changelog.html' } );
+    $chglog->html;
+
+    # the following is semantically equivalent
+    my $chglog = Parse::DebianChangelog->init();
+    $chglog->parse( { infile => 'debian/changelog' } );
+    $chglog->html( { outfile => 'changelog.html' } );
+
+    my $changes = $chglog->dpkg_str( { since => '1.0-1' } );
+    print $changes;
+
+=head1 DESCRIPTION
+
+Dpkg::Changelog::Debian parses Debian changelogs as described in the Debian
+policy (version 3.6.2.1 at the time of this writing). See section
+L<"SEE ALSO"> for locations where to find this definition.
+
+The parser tries to ignore most cruft like # or /* */ style comments,
+CVS comments, vim variables, emacs local variables and stuff from
+older changelogs with other formats at the end of the file.
+NOTE: most of these are ignored silently currently, there is no
+parser error issued for them. This should become configurable in the
+future.
+
+=head2 METHODS
+
+=cut
+
+package Dpkg::Changelog::Debian;
+
+use strict;
+use warnings;
+
+use Fcntl qw( :flock );
+use English;
+use Date::Parse;
+
+use Dpkg;
+use Dpkg::Gettext;
+use Dpkg::Changelog qw( :util );
+use base qw(Dpkg::Changelog);
+
+=pod
+
+=head3 parse
+
+Parses either the file named in configuration item C<infile> or the string
+saved in configuration item C<instring>.
+Accepts a hash ref as optional argument which can contain configuration
+items.
+
+Returns C<undef> in case of error (e.g. "file not found", B<not> parse
+errors) and the object if successful. If C<undef> was returned, you
+can get the reason for the failure by calling the L<get_error> method.
+
+=cut
+
+sub parse {
+    my ($self, $config) = @_;
+
+    foreach my $c (keys %$config) {
+	$self->{config}{$c} = $config->{$c};
+    }
+
+    my ($fh, $file);
+    if ($file = $self->{config}{infile}) {
+	open $fh, '<', $file or do {
+	    $self->_do_fatal_error( _g("can't open file %s: %s"),
+					$file, $! );
+	    return undef;
+	};
+    } elsif (my $string = $self->{config}{instring}) {
+	eval { require IO::String };
+	if ($@) {
+	    $self->_do_fatal_error( _g("can't load IO::String: %s"),
+					$@ );
+	    return undef;
+	}
+	$fh = IO::String->new( $string );
+	$file = 'String';
+    } else {
+	$self->_do_fatal_error(_g('no changelog file specified'));
+	return undef;
+    }
+
+    $self->reset_parse_errors;
+
+    $self->{data} = [];
+
+# based on /usr/lib/dpkg/parsechangelog/debian
+    my $expect='first heading';
+    my $entry = Dpkg::Changelog::Entry->init();
+    my $blanklines = 0;
+    my $unknowncounter = 1; # to make version unique, e.g. for using as id
+
+    while (<$fh>) {
+	s/\s*\n$//;
+#	printf(STDERR "%-39.39s %-39.39s\n",$expect,$_);
+	if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) {
+	    unless ($expect eq 'first heading'
+		    || $expect eq 'next heading or eof') {
+		$entry->{ERROR} = [ $file, $NR,
+				    sprintf(_g("found start of entry where expected %s"),
+					    $expect), "$_" ];
+		$self->_do_parse_error(@{$entry->{ERROR}});
+	    }
+	    unless ($entry->is_empty) {
+		$entry->{'Closes'} = find_closes( $entry->{Changes} );
+#		    print STDERR, Dumper($entry);
+		push @{$self->{data}}, $entry;
+		$entry = Dpkg::Changelog::Entry->init();
+		last if $self->_abort_early;
+	    }
+	    {
+		$entry->{'Source'} = "$1";
+		$entry->{'Version'} = "$2";
+		$entry->{'Header'} = "$_";
+		($entry->{'Distribution'} = "$3") =~ s/^\s+//;
+		$entry->{'Changes'} = $entry->{'Urgency_Comment'} = '';
+		$entry->{'Urgency'} = $entry->{'Urgency_LC'} = 'unknown';
+	    }
+	    (my $rhs = $POSTMATCH) =~ s/^\s+//;
+	    my %kvdone;
+#	    print STDERR "RHS: $rhs\n";
+	    for my $kv (split(/\s*,\s*/,$rhs)) {
+		$kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i ||
+		    $self->_do_parse_error($file, $NR,
+					   sprintf(_g("bad key-value after \`;': \`%s'"), $kv));
+		my $k = ucfirst $1;
+		my $v = $2;
+		$kvdone{$k}++ && $self->_do_parse_error($file, $NR,
+							sprintf(_g("repeated key-value %s"), $k));
+		if ($k eq 'Urgency') {
+		    $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i ||
+			$self->_do_parse_error($file, $NR,
+					      _g("badly formatted urgency value"),
+					      $v);
+		    $entry->{'Urgency'} = "$1";
+		    $entry->{'Urgency_LC'} = lc("$1");
+		    $entry->{'Urgency_Comment'} = "$2";
+		} elsif ($k =~ m/^X[BCS]+-/i) {
+		    # Extensions - XB for putting in Binary,
+		    # XC for putting in Control, XS for putting in Source
+		    $entry->{$k}= $v;
+		} else {
+		    $self->_do_parse_error($file, $NR,
+					   sprintf(_g("unknown key-value key %s - copying to XS-%s"), $k, $k));
+		    $entry->{ExtraFields}{"XS-$k"} = $v;
+		}
+	    }
+	    $expect= 'start of change data';
+	    $blanklines = 0;
+	} elsif (m/^(;;\s*)?Local variables:/io) {
+	    last; # skip Emacs variables at end of file
+	} elsif (m/^vim:/io) {
+	    last; # skip vim variables at end of file
+	} elsif (m/^\$\w+:.*\$/o) {
+	    next; # skip stuff that look like a CVS keyword
+	} elsif (m/^\# /o) {
+	    next; # skip comments, even that's not supported
+	} elsif (m,^/\*.*\*/,o) {
+	    next; # more comments
+	} elsif (m/^(\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o
+		 || m/^(\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o
+		 || m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)\;?/io
+		 || m/^([\w.+-]+)(-| )(\S+) Debian (\S+)/io
+		 || m/^Changes from version (.*) to (.*):/io
+		 || m/^Changes for [\w.+-]+-[\w.+-]+:?$/io
+		 || m/^Old Changelog:$/io
+		 || m/^(?:\d+:)?\w[\w.+~-]*:?$/o) {
+	    # save entries on old changelog format verbatim
+	    # we assume the rest of the file will be in old format once we
+	    # hit it for the first time
+	    $self->{oldformat} = "$_\n";
+	    $self->{oldformat} .= join "", <$fh>;
+	} elsif (m/^\S/) {
+	    $self->_do_parse_error($file, $NR,
+				  _g("badly formatted heading line"), "$_");
+	} elsif (m/^ \-\- (.*) <(.*)>(  ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)$/o) {
+	    $expect eq 'more change data or trailer' ||
+		$self->_do_parse_error($file, $NR,
+				       sprintf(_g("found trailer where expected %s"),
+					       $expect), "$_");
+	    if ($3 ne '  ') {
+		$self->_do_parse_error($file, $NR,
+				       _g( "badly formatted trailer line" ),
+				       "$_");
+	    }
+	    $entry->{'Trailer'} = $_;
+	    $entry->{'Maintainer'} = "$1 <$2>" unless $entry->{'Maintainer'};
+	    unless($entry->{'Date'} && defined $entry->{'Timestamp'}) {
+		$entry->{'Date'} = "$4";
+		$entry->{'Timestamp'} = str2time($4);
+		unless (defined $entry->{'Timestamp'}) {
+		    $self->_do_parse_error( $file, $NR,
+					    sprintf(_g("couldn't parse date %s"),
+						    "$4"));
+		}
+	    }
+	    $expect = 'next heading or eof';
+	} elsif (m/^ \-\-/) {
+	    $entry->{ERROR} = [ $file, $NR,
+				_g( "badly formatted trailer line" ), "$_" ];
+	    $self->_do_parse_error(@{$entry->{ERROR}});
+#	    $expect = 'next heading or eof'
+#		if $expect eq 'more change data or trailer';
+	} elsif (m/^\s{2,}(\S)/) {
+	    $expect eq 'start of change data'
+		|| $expect eq 'more change data or trailer'
+		|| do {
+		    $self->_do_parse_error($file, $NR,
+					   sprintf(_g("found change data where expected %s"),
+						   $expect), "$_");
+		    if (($expect eq 'next heading or eof')
+			&& !$entry->is_empty) {
+			# lets assume we have missed the actual header line
+			$entry->{'Closes'} = find_closes( $entry->{Changes} );
+#		    print STDERR, Dumper($entry);
+			push @{$self->{data}}, $entry;
+			$entry = Dpkg::Changelog::Entry->init();
+			$entry->{Source} =
+			    $entry->{Distribution} = $entry->{Urgency} =
+			    $entry->{Urgency_LC} = 'unknown';
+			$entry->{Version} = 'unknown'.($unknowncounter++);
+			$entry->{Urgency_Comment} = '';
+			$entry->{ERROR} = [ $file, $NR,
+					    sprintf(_g("found change data where expected %s"),
+						    $expect), "$_" ];
+		    }
+		};
+	    $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n";
+	    if (!$entry->{'Items'} || ($1 eq '*')) {
+		$entry->{'Items'} ||= [];
+		push @{$entry->{'Items'}}, "$_\n";
+	    } else {
+		$entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n";
+	    }
+	    $blanklines = 0;
+	    $expect = 'more change data or trailer';
+	} elsif (!m/\S/) {
+	    next if $expect eq 'start of change data'
+		|| $expect eq 'next heading or eof';
+	    $expect eq 'more change data or trailer'
+		|| $self->_do_parse_error($file, $NR,
+					  sprintf(_g("found blank line where expected %s"),
+						  $expect));
+	    $blanklines++;
+	} else {
+	    $self->_do_parse_error($file, $NR, _g( "unrecognised line" ),
+				   "$_");
+	    ($expect eq 'start of change data'
+		|| $expect eq 'more change data or trailer')
+		&& do {
+		    # lets assume change data if we expected it
+		    $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n";
+		    if (!$entry->{'Items'}) {
+			$entry->{'Items'} ||= [];
+			push @{$entry->{'Items'}}, "$_\n";
+		    } else {
+			$entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n";
+		    }
+		    $blanklines = 0;
+		    $expect = 'more change data or trailer';
+		    $entry->{ERROR} = [ $file, $NR, _g( "unrecognised line" ),
+					"$_" ];
+		};
+	}
+    }
+
+    $expect eq 'next heading or eof'
+	|| do {
+	    $entry->{ERROR} = [ $file, $NR,
+				sprintf(_g("found eof where expected %s"),
+					$expect) ];
+	    $self->_do_parse_error( @{$entry->{ERROR}} );
+	};
+    unless ($entry->is_empty) {
+	$entry->{'Closes'} = find_closes( $entry->{Changes} );
+	push @{$self->{data}}, $entry;
+    }
+
+    if ($self->{config}{infile}) {
+	close $fh or do {
+	    $self->_do_fatal_error( _g("can't close file %s: %s"),
+				    $file, $!);
+	    return undef;
+	};
+    }
+
+#    use Data::Dumper;
+#    print Dumper( $self );
+
+    return $self;
+}
+
+1;
+__END__
+
+=head1 SEE ALSO
+
+Dpkg::Changelog
+
+Description of the Debian changelog format in the Debian policy:
+L<http://www.debian.org/doc/debian-policy/ch-source.html#s-dpkgchangelog>.
+
+=head1 AUTHOR
+
+Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2005 by Frank Lichtenheld
+
+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 St, Fifth Floor, Boston, MA  02110-1301 USA
+
+=cut

scripts/Dpkg/ErrorHandling.pm

@@ -5,7 +5,8 @@ use Dpkg::Gettext;
 
 use base qw(Exporter);
 our @EXPORT_OK = qw(warning warnerror error failure unknown syserr internerr
-                    subprocerr usageerr syntaxerr $warnable_error $quiet_warnings);
+                    subprocerr usageerr syntaxerr report
+		    $warnable_error $quiet_warnings);
 
 our $warnable_error = 1;
 our $quiet_warnings = 0;

scripts/Makefile.am

@@ -70,6 +70,10 @@ EXTRA_DIST = \
 	t/300_Dpkg_BuildOptions.t \
 	t/400_Dpkg_Deps.t \
 	t/500_Dpkg_Path.t \
+	t/600_Dpkg_Changelog.t \
+	t/600_Dpkg_Changelog/countme \
+	t/600_Dpkg_Changelog/misplaced-tz \
+	t/600_Dpkg_Changelog/shadow \
 	t/700_Dpkg_Control.t \
 	t/700_Dpkg_Control/control-1
 
@@ -81,11 +85,13 @@ perllibdir = $(PERL_LIBDIR)
 nobase_dist_perllib_DATA = \
 	Dpkg/Arch.pm \
 	Dpkg/BuildOptions.pm \
-	Dpkg/Compression.pm \
 	Dpkg/Cdata.pm \
+	Dpkg/Changelog.pm \
+	Dpkg/Changelog/Debian.pm \
+	Dpkg/Compression.pm \
 	Dpkg/Control.pm \
-	Dpkg/ErrorHandling.pm \
 	Dpkg/Deps.pm \
+	Dpkg/ErrorHandling.pm \
 	Dpkg/Fields.pm \
 	Dpkg/Gettext.pm \
 	Dpkg/Path.pm \

scripts/changelog/debian.pl

@@ -3,35 +3,24 @@
 use strict;
 use warnings;
 
+use Getopt::Long qw(:config gnu_getopt auto_help);
+use POSIX;
+
 use Dpkg;
 use Dpkg::Gettext;
-use Dpkg::ErrorHandling qw(error internerr usageerr);
-use Dpkg::Fields qw(set_field_importance);
-
-push(@INC,$dpkglibdir);
-require 'controllib.pl';
-
-our %f;
+use Dpkg::ErrorHandling qw(usageerr failure);
+use Dpkg::Changelog::Debian;
 
 textdomain("dpkg-dev");
 
-my $controlfile = 'debian/control';
-my $changelogfile = 'debian/changelog';
-my $fileslistfile = 'debian/files';
-my $since = '';
-my %mapkv = (); # XXX: for future use
-
-my @changelog_fields = qw(Source Version Distribution Urgency Maintainer
-                          Date Closes Changes);
-
 $progname = "parsechangelog/$progname";
 
-
 sub version {
     printf _g("Debian %s version %s.\n"), $progname, $version;
 
     printf _g("
-Copyright (C) 1996 Ian Jackson.");
+Copyright (C) 1996 Ian Jackson.
+Copyright (C) 2005,2007 Frank Lichtenheld.");
     printf _g("
 This is free software; see the GNU General Public Licence version 2 or
 later for copying conditions. There is NO warranty.
@@ -40,152 +29,95 @@ later for copying conditions. There is NO warranty.
 
 sub usage {
     printf _g(
-"Usage: %s [<option>]
+"Usage: %s [<option>...] [<changelogfile>]
 
 Options:
-  -l<changelog>       use <changelog> as the file name when reporting.
-  -v<versionsince>    print changes since <versionsince>.
-  -h, --help          print this help message.
-      --version       print program version.
+    --help, -h                  print usage information
+    --version, -V               print version information
+    --file, -l <file>           changelog file to parse, defaults
+                                to 'debian/changelog'
+    --format <outputformat>     see man page for list of available
+                                output formats, defaults to 'dpkg'
+                                for compatibility with dpkg-dev
+    --since, -s, -v <version>   include all changes later than version
+    --until, -u <version>       include all changes earlier than version
+    --from, -f <version>        include all changes equal or later
+                                than version
+    --to, -t <version>          include all changes up to or equal
+                                than version
+    --count, -c, -n <number>    include <number> entries from the top
+                                (or the tail if <number> is lower than 0)
+    --offset, -o <number>       change the starting point for --count,
+                                counted from the top (or the tail if
+                                <number> is lower than 0)
+    --all                       include all changes
 "), $progname;
 }
 
-while (@ARGV) {
-    $_=shift(@ARGV);
-    if (m/^-v(.+)$/) {
-        $since= $1;
-    } elsif (m/^-l(.+)$/) {
-        $changelogfile = $1;
-    } elsif (m/^-(h|-help)$/) {
-        &usage; exit(0);
-    } elsif (m/^--version$/) {
-        &version; exit(0);
-    } else {
-        &usageerr(sprintf(_g("unknown option \`%s'"), $_));
+my ( $since, $until, $from, $to, $all, $count, $offset, $file );
+my $default_file = 'debian/changelog';
+my $format = 'dpkg';
+my %allowed_formats = (
+    dpkg => 1,
+    rfc822 => 1,
+    );
+
+sub set_format {
+    my ($opt, $val) = @_;
+
+    unless ($allowed_formats{$val}) {
+	usageerr(_g('output format %s not supported'), $val );
     }
+
+    $format = $val;
 }
 
-my %urgencies;
-my $i = 1;
-grep($urgencies{$_} = $i++, qw(low medium high critical emergency));
-
-my $expect = 'first heading';
-my $blanklines;
-
-while (<STDIN>) {
-    s/\s*\n$//;
-#    printf(STDERR "%-39.39s %-39.39s\n",$expect,$_);
-    if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-+0-9a-z.]+)+)\;/i) {
-        if ($expect eq 'first heading') {
-            $f{'Source'}= $1;
-            $f{'Version'}= $2;
-            $f{'Distribution'}= $3;
-            &error(_g("-v<since> option specifies most recent version")) if
-                $2 eq $since;
-            $f{'Distribution'} =~ s/^\s+//;
-        } elsif ($expect eq 'next heading or eof') {
-            last if $2 eq $since;
-            $f{'Changes'}.= " .\n";
-        } else {
-            &clerror(sprintf(_g("found start of entry where expected %s"), $expect));
-        }
-	my $rhs = $';
-	$rhs =~ s/^\s+//;
-	my %kvdone;
-	for my $kv (split(/\s*,\s*/, $rhs)) {
-            $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i ||
-                &clerror(sprintf(_g("bad key-value after \`;': \`%s'"), $kv));
-	    my $k = (uc substr($1, 0, 1)).(lc substr($1, 1));
-	    my $v = $2;
-            $kvdone{$k}++ && &clwarn(sprintf(_g("repeated key-value %s"), $k));
-            if ($k eq 'Urgency') {
-                $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i ||
-                    &clerror(_g("badly formatted urgency value"));
-
-		my $newurg = lc $1;
-		my $oldurg;
-		my $newurgn = $urgencies{lc $1};
-		my $oldurgn;
-		my $newcomment = $2;
-		my $oldcomment;
-
-                $newurgn ||
-                    &clwarn(sprintf(_g("unknown urgency value %s - comparing very low"), $newurg));
-                if (defined($f{'Urgency'})) {
-                    $f{'Urgency'} =~ m/^([-0-9a-z]+)((\s+.*)?)$/i ||
-                        &internerr(sprintf(_g("urgency >%s<"), $f{'Urgency'}));
-                    $oldurg= lc $1;
-                    $oldurgn= $urgencies{lc $1}; $oldcomment= $2;
-                } else {
-                    $oldurgn= -1;
-                    $oldcomment= '';
-                }
-                $f{'Urgency'}=
-                    (($newurgn > $oldurgn ? $newurg : $oldurg).
-                     $oldcomment.
-                     $newcomment);
-            } elsif (defined($mapkv{$k})) {
-                $f{$mapkv{$k}}= $v;
-            } elsif ($k =~ m/^X[BCS]+-/i) {
-                # Extensions - XB for putting in Binary,
-                # XC for putting in Control, XS for putting in Source
-                $f{$k}= $v;
-            } else {
-                &clwarn(sprintf(_g("unknown key-value key %s - copying to %s"), $k, "XS-$k"));
-                $f{"XS-$k"}= $v;
-            }
-        }
-        $expect= 'start of change data'; $blanklines=0;
-        $f{'Changes'}.= " $_\n .\n";
-    } elsif (m/^\S/) {
-        &clerror(_g("badly formatted heading line"));
-    } elsif (m/^ \-\- (.*) <(.*)>  ((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)$/) {
-        $expect eq 'more change data or trailer' ||
-            &clerror(sprintf(_g("found trailer where expected %s"), $expect));
-        $f{'Maintainer'}= "$1 <$2>" unless defined($f{'Maintainer'});
-        $f{'Date'}= $3 unless defined($f{'Date'});
-#        $f{'Changes'}.= " .\n $_\n";
-        $expect= 'next heading or eof';
-        last if $since eq '';
-    } elsif (m/^ \-\-/) {
-        &clerror(_g("badly formatted trailer line"));
-    } elsif (m/^\s{2,}\S/) {
-        $expect eq 'start of change data' || $expect eq 'more change data or trailer' ||
-            &clerror(sprintf(_g("found change data where expected %s"), $expect));
-        $f{'Changes'}.= (" .\n"x$blanklines)." $_\n"; $blanklines=0;
-        $expect= 'more change data or trailer';
-    } elsif (!m/\S/) {
-        next if $expect eq 'start of change data' || $expect eq 'next heading or eof';
-        $expect eq 'more change data or trailer' ||
-            &clerror(sprintf(_g("found blank line where expected %s"), $expect));
-        $blanklines++;
-    } else {
-        &clerror(_g("unrecognised line"));
+GetOptions( "file|l=s" => \$file,
+	    "since|v=s" => \$since,
+	    "until|u=s" => \$until,
+	    "from|f=s" => \$from,
+	    "to|t=s" => \$to,
+	    "count|c|n=i" => \$count,
+	    "offset|o=i" => \$offset,
+	    "help|h" => sub{usage();exit(0)},
+	    "version|V" => sub{version();exit(0)},
+	    "format=s" => \&set_format,
+	    "all|a" => \$all,
+	    )
+    or do { usage(); exit(2) };
+
+usageerr('too many arguments') if @ARGV > 1;
+
+if (@ARGV) {
+    if ($file && ($file ne $ARGV[0])) {
+	usageerr(_g('more than one file specified (%s and %s)'),
+		 $file, $ARGV[0] );
     }
+    $file = $ARGV[0];
 }
 
-$expect eq 'next heading or eof' || die sprintf(_g("found eof where expected %s"), $expect);
-
-$f{'Changes'} =~ s/\n$//;
-$f{'Changes'} =~ s/^/\n/;
-
-my @closes;
+my $changes = Dpkg::Changelog::Debian->init();
 
-while ($f{'Changes'} =~ /closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*/ig) {
-  push(@closes, $& =~ /\#?\s?(\d+)/g);
+$file ||= $default_file;
+unless ($since or $until or $from or $to or
+	$offset or $count or $all) {
+    $count = 1;
 }
-$f{'Closes'} = join(' ',sort { $a <=> $b} @closes);
-
-set_field_importance(@changelog_fields);
-outputclose();
-
-sub clerror
-{
-    &error(sprintf(_g("%s, at file %s line %d"), $_[0], $changelogfile, $.));
+my @all = $all ? ( all => $all ) : ();
+my $opts = { since => $since, until => $until,
+	     from => $from, to => $to,
+	     count => $count, offset => $offset,
+	     @all };
+
+if ($file eq '-') {
+    my @input = <STDIN>;
+    $changes->parse({ instring => join('', @input), %$opts })
+	or failure(_g('fatal error occured while parsing input'));
+} else {
+    $changes->parse({ infile => $file, %$opts })
+	or failure(_g('fatal error occured while parsing %s'),
+		   $file );
 }
 
-sub clwarn
-{
-    &warn(sprintf(_g("%s, at file %s line %d"), $_[0], $changelogfile, $.));
-}
 
+eval("print \$changes->${format}_str(\$opts)");

scripts/dpkg-parsechangelog.pl

@@ -3,6 +3,7 @@
 use strict;
 use warnings;
 
+use English;
 use POSIX;
 use POSIX qw(:errno_h);
 use Dpkg;
@@ -16,7 +17,7 @@ my $changelogfile = 'debian/changelog';
 my @parserpath = ("/usr/local/lib/dpkg/parsechangelog",
                   "$dpkglibdir/parsechangelog");
 
-my $libdir;	# XXX: Not used!?
+my $libdir;
 my $force;
 
 
@@ -39,11 +40,27 @@ sub usage {
 
 Options:
   -l<changelogfile>        get per-version info from this file.
-  -v<sinceversion>         include all changes later than version.
   -F<changelogformat>      force change log format.
   -L<libdir>               look for change log parsers in <libdir>.
   -h, --help               show this help message.
       --version            show the version.
+
+parser options:
+    --format <outputformat>     see man page for list of available
+                                output formats, defaults to 'dpkg'
+                                for compatibility with dpkg-dev
+    --since, -s, -v <version>   include all changes later than version
+    --until, -u <version>       include all changes earlier than version
+    --from, -f <version>        include all changes equal or later
+                                than version
+    --to, -t <version>          include all changes up to or equal
+                                than version
+    --count, -c, -n <number>    include <number> entries from the top
+                                (or the tail if <number> is lower than 0)
+    --offset, -o <number>       change the starting point for --count,
+                                counted from the top (or the tail if
+                                <number> is lower than 0)
+    --all                       include all changes
 "), $progname;
 }
 
@@ -51,24 +68,28 @@ my @ap = ();
 while (@ARGV) {
     last unless $ARGV[0] =~ m/^-/;
     $_= shift(@ARGV);
-    if (m/^-L/ && length($_)>2) { $libdir=$'; next; }
+    if (m/^-L/ && length($_)>2) { $libdir=$POSTMATCH; next; }
     if (m/^-F([0-9a-z]+)$/) { $force=1; $format=$1; next; }
     push(@ap,$_);
-    if (m/^-l/ && length($_)>2) { $changelogfile=$'; next; }
+    if (m/^-l/ && length($_)>2) { $changelogfile=$POSTMATCH; next; }
     m/^--$/ && last;
-    m/^-v/ && next;
+    m/^-[cfnostuv]/ && next;
+    m/^--all$/ && next;
+    m/^--(count|file|format|from|offset|since|to|until)(.*)$/ && do {
+	push(@ap, shift(@ARGV)) unless $2;
+	next;
+    };
     if (m/^-(h|-help)$/) { &usage; exit(0); }
     if (m/^--version$/) { &version; exit(0); }
-    &usageerr("unknown option \`$_'");
+    &usageerr(_g("unknown option \`%s'"), $_);
 }
 
 @ARGV && usageerr(_g("%s takes no non-option arguments"), $progname);
-$changelogfile= "./$changelogfile" if $changelogfile =~ m/^\s/;
 
 if (not $force and $changelogfile ne "-") {
-    open(STDIN,"< $changelogfile") ||
-        error(_g("cannot open %s to find format: %s"), $changelogfile, $!);
-    open(P,"tail -n 40 |") || die sprintf(_g("cannot fork: %s"), $!)."\n";
+    open(STDIN,"<", $changelogfile) ||
+	syserr(_g("cannot open %s to find format"), $changelogfile);
+    open(P,"-|","tail","-n",40) || syserr(_g("cannot fork"));
     while(<P>) {
         next unless m/\schangelog-format:\s+([0-9a-z]+)\W/;
         $format=$1;
@@ -79,6 +100,7 @@ if (not $force and $changelogfile ne "-") {
 
 my ($pa, $pf);
 
+unshift(@parserpath, $libdir) if $libdir;
 for my $pd (@parserpath) {
     $pa= "$pd/$format";
     if (!stat("$pa")) {
@@ -90,11 +112,12 @@ for my $pd (@parserpath) {
 	last;
     }
 }
-        
+
 defined($pf) || error(_g("format %s unknown"), $pa);
 
 if ($changelogfile ne "-") {
-    open(STDIN,"< $changelogfile") || die sprintf(_g("cannot open %s: %s"), $changelogfile, $!)."\n";
+    open(STDIN,"<", $changelogfile)
+	|| syserr(_g("cannot open %s: %s"), $changelogfile);
 }
-exec($pf,@ap); die sprintf(_g("cannot exec format parser: %s"), $!)."\n";
+exec($pf,@ap) || syserr(_g("cannot exec format parser: %s"));
 

scripts/t/600_Dpkg_Changelog.t

@@ -0,0 +1,207 @@
+# -*- perl -*-
+
+use strict;
+use warnings;
+
+use File::Basename;
+
+BEGIN {
+    my $no_examples = 2;
+    my $no_err_examples = 1;
+    my $no_tests = $no_examples * 4
+	+ $no_err_examples * 2
+	+ 48;
+
+    require Test::More;
+    import Test::More tests => $no_tests;
+}
+BEGIN {
+    use_ok('Dpkg::Changelog');
+    use_ok('Dpkg::Changelog::Debian');
+};
+
+my $srcdir = $ENV{srcdir} || '.';
+$srcdir .= '/t/600_Dpkg_Changelog';
+
+#########################
+
+my $test = Dpkg::Changelog::Debian->init( { infile => '/nonexistant',
+					    quiet => 1 } );
+ok( !defined($test), "fatal parse errors lead to init() returning undef");
+
+my $save_data;
+foreach my $file ("$srcdir/countme", "$srcdir/shadow") {
+
+    my $changes = Dpkg::Changelog::Debian->init( { infile => $file,
+						   quiet => 1 } );
+    my $errors = $changes->get_parse_errors();
+    my $basename = basename( $file );
+
+#    use Data::Dumper;
+#    diag(Dumper($changes));
+
+    ok( !$errors, "Parse example changelog $file without errors" );
+
+    my @data = $changes->data;
+
+    ok( @data, "data is not empty" );
+
+    my $str = $changes->dpkg_str();
+
+#    is( $str, `dpkg-parsechangelog -l$file`,
+#	'Output of dpkg_str equal to output of dpkg-parsechangelog' );
+
+    if ($file eq "$srcdir/countme") {
+	$save_data = $changes->rfc822_str({ all => 1 });
+
+	# test range options
+	cmp_ok( @data, '==', 7, "no options -> count" );
+	my $all_versions = join( '/', map { $_->Version } @data);
+
+	sub check_options {
+	    my ($changes, $data, $options, $count, $versions,
+		$check_name) = @_;
+
+	    my @cnt = $changes->data( $options );
+	    cmp_ok( @cnt, '==', $count, "$check_name -> count" );
+	    if ($count == @$data) {
+		is_deeply( \@cnt, $data, "$check_name -> returns all" );
+
+	    } else {
+		is( join( "/", map { $_->Version } @cnt),
+		    $versions, "$check_name -> versions" );
+	    }
+	}
+
+	check_options( $changes, \@data,
+		       { count => 3 }, 3, '2:2.0-1/1:2.0~rc2-3/1:2.0~rc2-2',
+		       'positve count' );
+	check_options( $changes, \@data,
+		       { count => -3 }, 3,
+		       '1:2.0~rc2-1sarge2/1:2.0~rc2-1sarge1/1.5-1',
+		       'negative count' );
+	check_options( $changes, \@data,
+		       { count => 1 }, 1, '2:2.0-1',
+		       'count 1' );
+	check_options( $changes, \@data,
+		       { count => 1, default_all => 1 }, 1, '2:2.0-1',
+		       'count 1 (d_a 1)' );
+	check_options( $changes, \@data,
+		       { count => -1 }, 1, '1.5-1',
+		       'count -1' );
+
+	check_options( $changes, \@data,
+		       { count => 3, offset => 2 }, 3,
+		       '1:2.0~rc2-2/1:2.0~rc2-1sarge3/1:2.0~rc2-1sarge2',
+		       'positve count + positive offset' );
+	check_options( $changes, \@data,
+		       { count => -3, offset => 4 }, 3,
+		       '1:2.0~rc2-3/1:2.0~rc2-2/1:2.0~rc2-1sarge3',
+		       'negative count + positive offset' );
+
+	check_options( $changes, \@data,
+		       { count => 4, offset => 5 }, 2,
+		       '1:2.0~rc2-1sarge1/1.5-1',
+		       'positve count + positive offset (>max)' );
+	check_options( $changes, \@data,
+		       { count => -4, offset => 2 }, 2,
+		       '2:2.0-1/1:2.0~rc2-3',
+		       'negative count + positive offset (<0)' );
+
+	check_options( $changes, \@data,
+		       { count => 3, offset => -4 }, 3,
+		       '1:2.0~rc2-1sarge3/1:2.0~rc2-1sarge2/1:2.0~rc2-1sarge1',
+		       'positve count + negative offset' );
+	check_options( $changes, \@data,
+		       { count => -3, offset => -3 }, 3,
+		       '1:2.0~rc2-3/1:2.0~rc2-2/1:2.0~rc2-1sarge3',
+		       'negative count + negative offset' );
+
+	check_options( $changes, \@data,
+		       { count => 5, offset => -2 }, 2,
+		       '1:2.0~rc2-1sarge1/1.5-1',
+		       'positve count + negative offset (>max)' );
+	check_options( $changes, \@data,
+		       { count => -5, offset => -4 }, 3,
+		       '2:2.0-1/1:2.0~rc2-3/1:2.0~rc2-2',
+		       'negative count + negative offset (<0)' );
+
+	check_options( $changes, \@data,
+		       { count => 7 }, 7, '',
+		       'count 7 (max)' );
+	check_options( $changes, \@data,
+		       { count => -7 }, 7, '',
+		       'count -7 (-max)' );
+	check_options( $changes, \@data,
+		       { count => 10 }, 7, '',
+		       'count 10 (>max)' );
+	check_options( $changes, \@data,
+		       { count => -10 }, 7, '',
+		       'count -10 (<-max)' );
+
+	check_options( $changes, \@data,
+		       { from => '1:2.0~rc2-1sarge3' }, 4,
+		       '2:2.0-1/1:2.0~rc2-3/1:2.0~rc2-2/1:2.0~rc2-1sarge3',
+		       'from => "1:2.0~rc2-1sarge3"' );
+	check_options( $changes, \@data,
+		       { since => '1:2.0~rc2-1sarge3' }, 3,
+		       '2:2.0-1/1:2.0~rc2-3/1:2.0~rc2-2',
+		       'since => "1:2.0~rc2-1sarge3"' );
+	check_options( $changes, \@data,
+		       { to => '1:2.0~rc2-1sarge2' }, 3,
+		       '1:2.0~rc2-1sarge2/1:2.0~rc2-1sarge1/1.5-1',
+		       'to => "1:2.0~rc2-1sarge2"' );
+	check_options( $changes, \@data,
+		       { until => '1:2.0~rc2-1sarge2' }, 2,
+		       '1:2.0~rc2-1sarge1/1.5-1',
+		       'until => "1:2.0~rc2-1sarge2"' );
+	#TODO: test combinations
+    }
+
+#     if ($file eq 'Changes') {
+# 	my $v = $data[0]->Version;
+# 	$v =~ s/[a-z]$//;
+# 	cmp_ok( $v, 'eq', $Parse::DebianChangelog::VERSION,
+# 		'version numbers in module and Changes match' );
+#     }
+
+    my $oldest_version = $data[-1]->Version;
+    $str = $changes->dpkg_str({ since => $oldest_version });
+
+#    is( $str, `dpkg-parsechangelog -v$oldest_version -l$file`,
+#	'Output of dpkg_str equal to output of dpkg-parsechangelog' )
+#	or diag("oldest_version=$oldest_version");
+
+    $str = $changes->rfc822_str();
+
+    ok( 1 );
+
+    $str = $changes->rfc822_str({ since => $oldest_version });
+
+    ok( 1 );
+}
+
+open CHANGES, '<', "$srcdir/countme";
+my $string = join('',<CHANGES>);
+
+my $str_changes = Dpkg::Changelog::Debian->init( { instring => $string,
+						 quiet => 1 } );
+my $errors = $str_changes->get_parse_errors();
+ok( !$errors,
+    "Parse example changelog $srcdir/countme without errors from string" );
+
+my $str_data = $str_changes->rfc822_str({ all => 1 });
+is( $str_data, $save_data,
+    "Compare result of parse from string with result of parse from file" );
+
+
+foreach my $test (( [ "$srcdir/misplaced-tz", 6 ])) {
+
+    my $file = shift @$test;
+    my $changes = Dpkg::Changelog::Debian->init( { infile => $file,
+						   quiet => 1 } );
+    my @errors = $changes->get_parse_errors();
+
+    ok( @errors, 'errors occoured' );
+    is_deeply( [ map { $_->[1] } @errors ], $test, 'check line numbers' );
+}

scripts/t/600_Dpkg_Changelog/countme

@@ -0,0 +1,41 @@
+countme (2:2.0-1) unstable; urgency=low
+
+  * Final
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Tue,  4 Oct 2005 01:49:05 +0200
+
+countme (1:2.0~rc2-3) unstable; urgency=low
+
+  * kadabra
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Tue,  4 Oct 2005 01:48:05 +0200
+
+countme (1:2.0~rc2-2) unstable; urgency=low
+
+  * Abra
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Tue,  4 Oct 2005 01:47:48 +0200
+
+countme (1:2.0~rc2-1sarge3) unstable; urgency=low
+
+  * Baz
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Tue,  4 Oct 2005 01:47:19 +0200
+
+countme (1:2.0~rc2-1sarge2) unstable; urgency=low
+
+  * Bar
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Tue,  4 Oct 2005 01:47:08 +0200
+
+countme (1:2.0~rc2-1sarge1) unstable; urgency=low
+
+  * Foo
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Tue,  4 Oct 2005 01:46:49 +0200
+
+countme (1.5-1) unstable; urgency=low
+
+  * Initial
+
+ -- Frank Lichtenheld <frank@lichtenheld.de>  Thu, 01 Jan 1970 00:00:00 +0000

scripts/t/600_Dpkg_Changelog/misplaced-tz

@@ -0,0 +1,12 @@
+error-tz (1.1-1) unstable; urgency=low
+
+  * 
+
+ -- Frank Lichtenheld <djpig@debian.org>  Mon, 16 Jul 2007 02:54:18 +0200
++0200
+
+error-tz (1.0-1) unstable; urgency=low
+
+  * 
+
+ -- Frank Lichtenheld <djpig@debian.org>  Mon, 16 Jul 2007 02:54:18 +0200