Dpkg::Changelog::Entry, Dpkg::Control::Changelog: new modules

Dpkg::Changelog::Entry is a somewhat generic representation of a
changelog entry. It offers an interface exporting the basic information
that we need to extract for dpkg-parsechangelog.

Dpkg::Changelog::Entry::Debian is the implementation of this
interface for the typical Debian changelog entry.

Dpkg::Control::Changelog is the object representing the
information exported by dpkg-parsechangelog. It starts empty
as a simple Dpkg::Control of type CTRL_CHANGELOG.

Those new modules are not yet used by the Dpkg::Changelog modules.

scripts/Dpkg/Changelog/Entry.pm

@@ -0,0 +1,284 @@
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Changelog::Entry;
+
+use strict;
+use warnings;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control::Changelog;
+
+use overload
+    '""' => \&output;
+
+=head1 NAME
+
+Dpkg::Changelog::Entry - represents a changelog entry
+
+=head1 DESCRIPTION
+
+This object represents a changelog entry. It is composed
+of a set of lines with specific purpose: an header line, changes lines, a
+trailer line. Blank lines can be between those kind of lines.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item my $entry = Dpkg::Changelog::Entry->new()
+
+Creates a new object. It doesn't represent a real changelog entry
+until one has been successfully parsed or built from scratch.
+
+=cut
+
+sub new {
+    my ($this) = @_;
+    my $class = ref($this) || $this;
+
+    my $self = {
+	'header' => undef,
+	'changes' => [],
+	'trailer' => undef,
+	'blank_after_header' => [],
+	'blank_after_changes' => [],
+	'blank_after_trailer' => [],
+    };
+    bless $self, $class;
+    return $self;
+}
+
+=item my $str = $entry->output()
+=item "$entry"
+
+Get a string representation of the changelog entry.
+
+=item $entry->output($fh)
+
+Print the string representation of the changelog entry to a
+filehandle.
+
+=cut
+
+sub output {
+    my ($self, $fh) = @_;
+    my $str = '';
+    sub _block {
+	my $lines = shift;
+	return join('', map { $_ . "\n" } @{$lines});
+    }
+    $str .= $self->{header} . "\n" if defined($self->{header});
+    $str .= _block($self->{blank_after_header});
+    $str .= _block($self->{changes});
+    $str .= _block($self->{blank_after_changes});
+    $str .= $self->{trailer} . "\n" if defined($self->{trailer});
+    $str .= _block($self->{blank_after_trailer});
+    print $fh $str if defined $fh;
+    return $str;
+}
+
+=item $entry->get_part($part)
+
+Return either a string (for a single line) or an array ref (for multiple
+lines) corresponding to the requested part. $part can be
+"header, "changes", "trailer", "blank_after_header",
+"blank_after_changes", "blank_after_trailer".
+
+=cut
+
+sub get_part {
+    my ($self, $part) = @_;
+    internerr("invalid part of changelog entry: %s") unless exists $self->{$part};
+    return $self->{$part};
+}
+
+=item $entry->set_part($part, $value)
+
+Set the value of the corresponding part. $value can be a string
+or an array ref.
+
+=cut
+
+sub set_part {
+    my ($self, $part, $value) = @_;
+    internerr("invalid part of changelog entry: %s") unless exists $self->{$part};
+    if (ref($self->{$part})) {
+	if (ref($value)) {
+	    $self->{$part} = $value;
+	} else {
+	    $self->{$part} = [ $value ];
+	}
+    } else {
+	$self->{$part} = $value;
+    }
+}
+
+=item $entry->extend_part($part, $value)
+
+Concatenate $value at the end of the part. If the part is already a
+multi-line value, $value is added as a new line otherwise it's
+concatenated at the end of the current line.
+
+=cut
+
+sub extend_part {
+    my ($self, $part, $value, @rest) = @_;
+    internerr("invalid part of changelog entry: %s") unless exists $self->{$part};
+    if (ref($self->{$part})) {
+	if (ref($value)) {
+	    push @{$self->{$part}}, @$value;
+	} else {
+	    push @{$self->{$part}}, $value;
+	}
+    } else {
+	if (defined($self->{$part})) {
+	    if (ref($value)) {
+		$self->{$part} = [ $self->{$part}, @$value ];
+	    } else {
+		$self->{$part} .= $value;
+	    }
+	} else {
+	    $self->{$part} = $value;
+	}
+    }
+}
+
+=item $is_empty = $entry->is_empty()
+
+Returns 1 if the changelog entry doesn't contain anything at all.
+Returns 0 as soon as it contains something in any of its non-blank
+parts.
+
+=cut
+
+sub is_empty {
+    my ($self) = @_;
+    return !(defined($self->{header}) || defined($self->{trailer}) ||
+	     scalar(@{$self->{changes}}));
+}
+
+=item $entry->normalize()
+
+Normalize the content. Strip whitespaces at end of lines, use a single
+empty line to separate each part.
+
+=cut
+
+sub normalize {
+    my ($self) = @_;
+    if (defined($self->{header})) {
+	$self->{header} =~ s/\s+$//g;
+	$self->{blank_after_header} = [''];
+    } else {
+	$self->{blank_after_header} = [];
+    }
+    if (scalar(@{$self->{changes}})) {
+	s/\s+$//g foreach @{$self->{changes}};
+	$self->{blank_after_changes} = [''];
+    } else {
+	$self->{blank_after_changes} = [];
+    }
+    if (defined($self->{trailer})) {
+	$self->{trailer} =~ s/\s+$//g;
+	$self->{blank_after_trailer} = [''];
+    } else {
+	$self->{blank_after_trailer} = [];
+    }
+}
+
+=item my $src = $entry->get_source()
+
+Return the name of the source package associated to the changelog entry.
+
+=cut
+
+sub get_source {
+    return undef;
+}
+
+=item my $ver = $entry->get_version()
+
+Return the version associated to the changelog entry.
+
+=cut
+
+sub get_version {
+    return undef;
+}
+
+=item my @dists = $entry->get_distributions()
+
+Return a list of target distributions for this version.
+
+=cut
+
+sub get_distributions {
+    return () if wantarray;
+    return undef;
+}
+
+=item $fields = $entry->get_optional_fields()
+
+Return a set of optional fields exposed by the changelog entry.
+It always returns a Dpkg::Control object (possibly empty though).
+
+=cut
+
+sub get_optional_fields {
+    return Dpkg::Control::Changelog->new();
+}
+
+=item $urgency = $entry->get_urgency()
+
+Return the urgency of the associated upload.
+
+=cut
+
+sub get_urgency {
+    return undef;
+}
+
+=item my $maint = $entry->get_maintainer()
+
+Return the string identifying the person who signed this changelog entry.
+
+=cut
+
+sub get_maintainer {
+    return undef;
+}
+
+=item my $time = $entry->get_timestamp()
+
+Return the timestamp of the changelog entry.
+
+=cut
+
+sub get_timestamp {
+    return undef;
+}
+
+=back
+
+=head1 AUTHOR
+
+Raphaël Hertzog <hertzog@debian.org>.
+
+=cut
+
+1;

scripts/Dpkg/Changelog/Entry/Debian.pm

@@ -0,0 +1,156 @@
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Changelog::Entry::Debian;
+
+use strict;
+use warnings;
+
+use Exporter;
+use Dpkg::Changelog::Entry;
+use base qw(Exporter Dpkg::Changelog::Entry);
+our @EXPORT_OK = qw($regex_header $regex_trailer);
+
+use Dpkg::Control::Changelog;
+use Dpkg::Version;
+use Dpkg::Changelog qw(:util);
+
+=head1 NAME
+
+Dpkg::Changelog::Entry::Debian - represents a Debian changelog entry
+
+=head1 DESCRIPTION
+
+This object represents a Debian changelog entry. It implements the
+generic interface Dpkg::Changelog::Entry. Only functions specific to this
+implementation are described below.
+
+=head1 VARIABLES
+
+$regex_header, $regex_trailer are two regular expressions that can be used
+to match a line and know whether it's a valid header/trailer line.
+
+The matched content for $regex_header is the source package name ($1), the
+version ($2), the target distributions ($3) and the options on the rest
+of the line ($4). For $regex_trailer, it's the maintainer name ($1), its
+email ($2), some blanks ($3) and the timestamp ($4).
+
+=cut
+
+my $name_chars = qr/[-+0-9a-z.]/i;
+our $regex_header = qr/^(\w$name_chars*) \(([^\(\) \t]+)\)((?:\s+$name_chars+)+)\;(.*)$/i;
+our $regex_trailer = qr/^ \-\- (.*) <(.*)>(  ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)\s*$/o;
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item $entry->normalize()
+
+Normalize the content. Strip whitespaces at end of lines, use a single
+empty line to separate each part.
+
+=cut
+
+sub normalize {
+    my ($self) = @_;
+    $self->SUPER::normalize();
+    #XXX: recreate header/trailer
+}
+
+sub get_source {
+    my ($self) = @_;
+    if (defined($self->{header}) and $self->{header} =~ $regex_header) {
+	return $1;
+    }
+    return undef;
+}
+
+sub get_version {
+    my ($self) = @_;
+    if (defined($self->{header}) and $self->{header} =~ $regex_header) {
+	return Dpkg::Version->new($2) || $2;
+    }
+    return undef;
+}
+
+sub get_distributions {
+    my ($self) = @_;
+    if (defined($self->{header}) and $self->{header} =~ $regex_header) {
+	my $value = $3;
+	$value =~ s/^\s+//;
+	my @dists = split(/\s+/, $value);
+	return @dists if wantarray;
+	return $dists[0];
+    }
+    return () if wantarray;
+    return undef;
+}
+
+sub get_optional_fields {
+    my ($self) = @_;
+    my $f = Dpkg::Control::Changelog->new();
+    if (defined($self->{header}) and $self->{header} =~ $regex_header) {
+	my $options = $4;
+	$options =~ s/^\s+//;
+	foreach my $opt (split(/\s*,\s*/, $options)) {
+	    if ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) {
+		$f->{$1} = $2;
+	    }
+	}
+    }
+    my $closes = find_closes(join("\n", @{$self->{changes}}));
+    if (@$closes) {
+	$f->{Closes} = join(" ", @$closes);
+    }
+    return $f;
+}
+
+sub get_urgency {
+    my ($self) = @_;
+    my $f = $self->get_optional_fields();
+    if (exists $f->{Urgency}) {
+	$f->{Urgency} =~ s/\s.*$//;
+	return lc($f->{Urgency});
+    }
+    return undef;
+}
+
+sub get_maintainer {
+    my ($self) = @_;
+    if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) {
+	return "$1 <$2>";
+    }
+    return undef;
+}
+
+sub get_timestamp {
+    my ($self) = @_;
+    if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) {
+	return $4;
+    }
+    return undef;
+}
+
+=back
+
+=head1 AUTHOR
+
+Raphaël Hertzog <hertzog@debian.org>.
+
+=cut
+
+1;

scripts/Dpkg/Control/Changelog.pm

@@ -0,0 +1,59 @@
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+package Dpkg::Control::Changelog;
+
+use strict;
+use warnings;
+
+use Dpkg::Control;
+use base 'Dpkg::Control';
+
+=head1 NAME
+
+Dpkg::Control::Changelog - represent info fields output by dpkg-parsechangelog
+
+=head1 DESCRIPTION
+
+This object derives directly from Dpkg::Control with the type
+CTRL_CHANGELOG.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item $c = Dpkg::Control::Changelog->new()
+
+Create a new empty set of changelog related fields.
+
+=cut
+
+sub new {
+    my $this = shift;
+    my $class = ref($this) || $this;
+    my $self = Dpkg::Control->new(type => CTRL_CHANGELOG, @_);
+    return bless $self, $class;
+}
+
+=back
+
+=head1 AUTHOR
+
+Raphael Hertzog <hertzog@debian.org>.
+
+=cut
+
+1;

scripts/Makefile.am

@@ -91,9 +91,12 @@ nobase_dist_perllib_DATA = \
 	Dpkg/BuildOptions.pm \
 	Dpkg/Changelog.pm \
 	Dpkg/Changelog/Debian.pm \
+	Dpkg/Changelog/Entry.pm \
+	Dpkg/Changelog/Entry/Debian.pm \
 	Dpkg/Checksums.pm \
 	Dpkg/Compression.pm \
 	Dpkg/Control.pm \
+	Dpkg/Control/Changelog.pm \
 	Dpkg/Control/Fields.pm \
 	Dpkg/Control/Info.pm \
 	Dpkg/Control/Hash.pm \

scripts/po/POTFILES.in

@@ -17,8 +17,11 @@ scripts/changelog/debian.pl
 scripts/Dpkg/Arch.pm
 scripts/Dpkg/Changelog.pm
 scripts/Dpkg/Changelog/Debian.pm
+scripts/Dpkg/Changelog/Entry.pm
+scripts/Dpkg/Changelog/Entry/Debian.pm
 scripts/Dpkg/Checksums.pm
 scripts/Dpkg/Control.pm
+scripts/Dpkg/Control/Changelog.pm
 scripts/Dpkg/Control/Fields.pm
 scripts/Dpkg/Control/Info.pm
 scripts/Dpkg/Control/Hash.pm