Dpkg::Changelog: New naming scheme

Rename DebianChangelog to Dpkg::Changelog::Debian.
Rename DebianChangelog::Entry to Dpkg::Changelog::Entry.
Move code from DebianChangelog::Util to Dpkg::Changelog.
Move code not specific to the Debian format from
DebianChangelog to Dpkg::Changelog.

Adapt all the code to Dpkg utility modules.

Remove all code for the HTML and XML output. This should
remain outside of dpkg-dev.

This passes the test suite.

scripts/Dpkg/Changelog.pm

@@ -0,0 +1,803 @@
+#
+# Dpkg::Changelog
+#
+# 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
+
+=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;
+
+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 .= warning(_g("%s(l%s): %s\nLINE: %s"), @$e );
+	    } else {
+		$res .= warning(_g("%s(l%s): %s"), @$e );
+	    }
+	}
+	return $res;
+    }
+}
+
+sub _do_fatal_error {
+    my ($self, @msg) = @_;
+
+    $self->{errors}{fatal} = "@msg";
+    warning(_g("FATAL: %s"), "@msg")."\n" 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 Parse::DebianChangelog::Entry objects which each
+represent one entry of the changelog.
+
+This is currently merely a placeholder to enable users to get to the
+raw data, expect changes to this API in the near future.
+
+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'" ));
+	$$from = '';
+    }
+    if ($$to && $$until) {
+	warning(_g( "you can only specify one of 'to' and 'until'" ));
+	$$to = '';
+    }
+    if ($$since && ($data->[0]{Version} eq $$since)) {
+	warning(_g( "'since' option specifies most recent version" ));
+	$$since = '';
+    }
+    if ($$until && ($data->[$#{$data}]{Version} eq $$until)) {
+	warning(_g( "'until' option specifies oldest version" ));
+	$$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;
+}
+
+=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 which should look
+exactly like the output of L<dpkg-parsechangelog(1)>. The fields are
+ordered like in the list above.
+
+Both methods only 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 hash which looks
+similar to the output of dpkg-parsechangelog but instead of one
+stanza the output contains one stanza for each entry.
+
+Both methods only 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.
+
+(works exactly like the C<-v> option of dpkg-parsechangelog).
+
+=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. While the XML and HTML formats
+default to all == true, this does of course not overwrite other
+options unless it is set explicitly with the call.
+
+=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.
+
+=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 Parse::DebianChangelog::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 (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/Changelog/Debian.pm

@@ -0,0 +1,363 @@
+#
+# 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::ErrorHandling;
+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;
+	};
+	flock $fh, LOCK_SH or do {
+	    $self->_do_fatal_error( _g("can't lock 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,
+				  _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();
+	    }
+	    {
+		$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,
+					   _g( "bad key-value after \`;': \`%s'", $kv ));
+		my $k = ucfirst $1;
+		my $v = $2;
+		$kvdone{$k}++ && $self->_do_parse_error($file, $NR,
+						       _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,
+					   _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,
+				       _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,
+					    _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,
+					   _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,
+					    _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,
+					  _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,
+				_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/DebianChangelog/Entry.pm

@@ -1,175 +0,0 @@
-#
-# Parse::DebianChangelog::Entry
-#
-# 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
-
-Parse::DebianChangelog::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. Due to limitations
-in Parse::DebianChangelog 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 Parse::DebianChangelog::get_parse_errors.
-
-=back
-
-=cut
-
-package Parse::DebianChangelog::Entry;
-
-use strict;
-use warnings;
-
-use base qw( Class::Accessor );
-use Parse::DebianChangelog::Util qw( :all );
-
-Parse::DebianChangelog::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 SEE ALSO
-
-Parse::DebianChangelog
-
-=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/DebianChangelog/Util.pm

@@ -1,184 +0,0 @@
-#
-# Parse::DebianChangelog::Util
-#
-# 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
-
-Parse::DebianChangelog::Util - utility functions for parsing Debian changelogs
-
-=head1 DESCRIPTION
-
-This is currently only used internally by Parse::DebianChangelog.
-There may be still API changes until this module is finalized.
-
-=head2 Functions
-
-=cut
-
-package Parse::DebianChangelog::Util;
-
-use strict;
-use warnings;
-
-require Exporter;
-
-our @ISA = qw(Exporter);
-
-our %EXPORT_TAGS = ( 'all' => [ qw(
-		 find_closes
-		 data2rfc822
-		 data2rfc822_mult
-		 get_dpkg_changes
-) ] );
-
-our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
-
-our @EXPORT = qw(
-);
-
-=pod
-
-=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
-	    && warn(__g("field %s has newline then non whitespace >%s<",
-			$f, $v ));
-	$v =~ m/\n[ \t]*\n/o && warn(__g("field %s has blank lines >%s<",
-					 $f, $v ));
-	$v =~ m/\n$/o && warn(__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 Parse::DebianChangelog::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;
-}
-
-1;
-__END__
-
-=head1 SEE ALSO
-
-Parse::DebianChangelog, Parse::DebianChangelog::Entry
-
-=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