summaryrefslogtreecommitdiffstats
path: root/scripts/Dpkg/Changelog
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/Dpkg/Changelog')
-rw-r--r--scripts/Dpkg/Changelog/Debian.pm264
-rw-r--r--scripts/Dpkg/Changelog/Entry.pm324
-rw-r--r--scripts/Dpkg/Changelog/Entry/Debian.pm490
-rw-r--r--scripts/Dpkg/Changelog/Parse.pm232
4 files changed, 1310 insertions, 0 deletions
diff --git a/scripts/Dpkg/Changelog/Debian.pm b/scripts/Dpkg/Changelog/Debian.pm
new file mode 100644
index 0000000..937acb5
--- /dev/null
+++ b/scripts/Dpkg/Changelog/Debian.pm
@@ -0,0 +1,264 @@
+# Copyright © 1996 Ian Jackson
+# Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de>
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
+# Copyright © 2012-2017 Guillem Jover <guillem@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, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Changelog::Debian - parse Debian changelogs
+
+=head1 DESCRIPTION
+
+Dpkg::Changelog::Debian parses Debian changelogs as described in
+deb-changelog(5).
+
+The parser tries to ignore most cruft like # or /* */ style comments,
+RCS keywords, Vim modelines, 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.
+
+=cut
+
+package Dpkg::Changelog::Debian;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.00';
+
+use Dpkg::Gettext;
+use Dpkg::File;
+use Dpkg::Changelog qw(:util);
+use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer);
+
+use parent qw(Dpkg::Changelog);
+
+use constant {
+ FIRST_HEADING => g_('first heading'),
+ NEXT_OR_EOF => g_('next heading or end of file'),
+ START_CHANGES => g_('start of change data'),
+ CHANGES_OR_TRAILER => g_('more change data or trailer'),
+};
+
+my $ancient_delimiter_re = qr{
+ ^
+ (?: # Ancient GNU style changelog entry with expanded date
+ (?:
+ \w+\s+ # Day of week (abbreviated)
+ \w+\s+ # Month name (abbreviated)
+ \d{1,2} # Day of month
+ \Q \E
+ \d{1,2}:\d{1,2}:\d{1,2}\s+ # Time
+ [\w\s]* # Timezone
+ \d{4} # Year
+ )
+ \s+
+ (?:.*) # Maintainer name
+ \s+
+ [<\(]
+ (?:.*) # Maintainer email
+ [\)>]
+ | # Old GNU style changelog entry with expanded date
+ (?:
+ \w+\s+ # Day of week (abbreviated)
+ \w+\s+ # Month name (abbreviated)
+ \d{1,2},?\s* # Day of month
+ \d{4} # Year
+ )
+ \s+
+ (?:.*) # Maintainer name
+ \s+
+ [<\(]
+ (?:.*) # Maintainer email
+ [\)>]
+ | # Ancient changelog header w/o key=value options
+ (?:\w[-+0-9a-z.]*) # Package name
+ \Q \E
+ \(
+ (?:[^\(\) \t]+) # Package version
+ \)
+ \;?
+ | # Ancient changelog header
+ (?:[\w.+-]+) # Package name
+ [- ]
+ (?:\S+) # Package version
+ \ Debian
+ \ (?:\S+) # Package revision
+ |
+ Changes\ from\ version\ (?:.*)\ to\ (?:.*):
+ |
+ Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$
+ |
+ Old\ Changelog:\s*$
+ |
+ (?:\d+:)?
+ \w[\w.+~-]*:?
+ \s*$
+ )
+}xi;
+
+=head1 METHODS
+
+=over 4
+
+=item $c->parse($fh, $description)
+
+Read the filehandle and parse a Debian changelog in it. The data in the
+object is reset before parsing new data.
+
+Returns the number of changelog entries that have been parsed with success.
+
+=cut
+
+sub parse {
+ my ($self, $fh, $file) = @_;
+ $file = $self->{reportfile} if exists $self->{reportfile};
+
+ $self->reset_parse_errors;
+
+ $self->{data} = [];
+ $self->set_unparsed_tail(undef);
+
+ my $expect = FIRST_HEADING;
+ my $entry = Dpkg::Changelog::Entry::Debian->new();
+ my @blanklines = ();
+ my $unknowncounter = 1; # to make version unique, e.g. for using as id
+ local $_;
+
+ while (<$fh>) {
+ chomp;
+ if (match_header($_)) {
+ unless ($expect eq FIRST_HEADING || $expect eq NEXT_OR_EOF) {
+ $self->parse_error($file, $.,
+ sprintf(g_('found start of entry where expected %s'),
+ $expect), "$_");
+ }
+ unless ($entry->is_empty) {
+ push @{$self->{data}}, $entry;
+ $entry = Dpkg::Changelog::Entry::Debian->new();
+ last if $self->abort_early();
+ }
+ $entry->set_part('header', $_);
+ foreach my $error ($entry->parse_header()) {
+ $self->parse_error($file, $., $error, $_);
+ }
+ $expect= START_CHANGES;
+ @blanklines = ();
+ } elsif (m/^(?:;;\s*)?Local variables:/io) {
+ # Save any trailing Emacs variables at end of file.
+ $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // ''));
+ last;
+ } elsif (m/^vim:/io) {
+ # Save any trailing Vim modelines at end of file.
+ $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // ''));
+ last;
+ } elsif (m/^\$\w+:.*\$/o) {
+ next; # skip stuff that look like a RCS keyword
+ } elsif (m/^\# /o) {
+ next; # skip comments, even that's not supported
+ } elsif (m{^/\*.*\*/}o) {
+ next; # more comments
+ } elsif (m/$ancient_delimiter_re/) {
+ # 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->set_unparsed_tail("$_\n" . file_slurp($fh));
+ } elsif (m/^\S/) {
+ $self->parse_error($file, $., g_('badly formatted heading line'), "$_");
+ } elsif (match_trailer($_)) {
+ unless ($expect eq CHANGES_OR_TRAILER) {
+ $self->parse_error($file, $.,
+ sprintf(g_('found trailer where expected %s'), $expect), "$_");
+ }
+ $entry->set_part('trailer', $_);
+ $entry->extend_part('blank_after_changes', [ @blanklines ]);
+ @blanklines = ();
+ foreach my $error ($entry->parse_trailer()) {
+ $self->parse_error($file, $., $error, $_);
+ }
+ $expect = NEXT_OR_EOF;
+ } elsif (m/^ \-\-/) {
+ $self->parse_error($file, $., g_('badly formatted trailer line'), "$_");
+ } elsif (m/^\s{2,}(?:\S)/) {
+ unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
+ $self->parse_error($file, $., sprintf(g_('found change data' .
+ ' where expected %s'), $expect), "$_");
+ if ($expect eq NEXT_OR_EOF and not $entry->is_empty) {
+ # lets assume we have missed the actual header line
+ push @{$self->{data}}, $entry;
+ $entry = Dpkg::Changelog::Entry::Debian->new();
+ $entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown');
+ }
+ }
+ # Keep raw changes
+ $entry->extend_part('changes', [ @blanklines, $_ ]);
+ @blanklines = ();
+ $expect = CHANGES_OR_TRAILER;
+ } elsif (!m/\S/) {
+ if ($expect eq START_CHANGES) {
+ $entry->extend_part('blank_after_header', $_);
+ next;
+ } elsif ($expect eq NEXT_OR_EOF) {
+ $entry->extend_part('blank_after_trailer', $_);
+ next;
+ } elsif ($expect ne CHANGES_OR_TRAILER) {
+ $self->parse_error($file, $.,
+ sprintf(g_('found blank line where expected %s'), $expect));
+ }
+ push @blanklines, $_;
+ } else {
+ $self->parse_error($file, $., g_('unrecognized line'), "$_");
+ unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
+ # lets assume change data if we expected it
+ $entry->extend_part('changes', [ @blanklines, $_]);
+ @blanklines = ();
+ $expect = CHANGES_OR_TRAILER;
+ }
+ }
+ }
+
+ unless ($expect eq NEXT_OR_EOF) {
+ $self->parse_error($file, $.,
+ sprintf(g_('found end of file where expected %s'),
+ $expect));
+ }
+ unless ($entry->is_empty) {
+ push @{$self->{data}}, $entry;
+ }
+
+ return scalar @{$self->{data}};
+}
+
+1;
+__END__
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 1.00 (dpkg 1.15.6)
+
+Mark the module as public.
+
+=head1 SEE ALSO
+
+Dpkg::Changelog
+
+=cut
diff --git a/scripts/Dpkg/Changelog/Entry.pm b/scripts/Dpkg/Changelog/Entry.pm
new file mode 100644
index 0000000..144dacb
--- /dev/null
+++ b/scripts/Dpkg/Changelog/Entry.pm
@@ -0,0 +1,324 @@
+# 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, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Changelog::Entry;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.01';
+
+use Carp;
+
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control::Changelog;
+
+use overload
+ '""' => \&output,
+ 'eq' => sub { defined($_[1]) and "$_[0]" eq "$_[1]" },
+ fallback => 1;
+
+=encoding utf8
+
+=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 METHODS
+
+=over 4
+
+=item $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 = shift;
+ 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 $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 _format_output_block {
+ my $lines = shift;
+ return join('', map { $_ . "\n" } @{$lines});
+}
+
+sub output {
+ my ($self, $fh) = @_;
+ my $str = '';
+ $str .= $self->{header} . "\n" if defined($self->{header});
+ $str .= _format_output_block($self->{blank_after_header});
+ $str .= _format_output_block($self->{changes});
+ $str .= _format_output_block($self->{blank_after_changes});
+ $str .= $self->{trailer} . "\n" if defined($self->{trailer});
+ $str .= _format_output_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) = @_;
+ croak "invalid part of changelog entry: $part" 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) = @_;
+ croak "invalid part of changelog entry: $part" 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) = @_;
+ croak "invalid part of changelog entry: $part" 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 = shift;
+ 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 = shift;
+ 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 $src = $entry->get_source()
+
+Return the name of the source package associated to the changelog entry.
+
+=cut
+
+sub get_source {
+ return;
+}
+
+=item $ver = $entry->get_version()
+
+Return the version associated to the changelog entry.
+
+=cut
+
+sub get_version {
+ return;
+}
+
+=item @dists = $entry->get_distributions()
+
+Return a list of target distributions for this version.
+
+=cut
+
+sub get_distributions {
+ return;
+}
+
+=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;
+}
+
+=item $maint = $entry->get_maintainer()
+
+Return the string identifying the person who signed this changelog entry.
+
+=cut
+
+sub get_maintainer {
+ return;
+}
+
+=item $time = $entry->get_timestamp()
+
+Return the timestamp of the changelog entry.
+
+=cut
+
+sub get_timestamp {
+ return;
+}
+
+=item $time = $entry->get_timepiece()
+
+Return the timestamp of the changelog entry as a Time::Piece object.
+
+This function might return undef if there was no timestamp.
+
+=cut
+
+sub get_timepiece {
+ return;
+}
+
+=item $str = $entry->get_dpkg_changes()
+
+Returns a string that is suitable for usage in a C<Changes> field
+in the output format of C<dpkg-parsechangelog>.
+
+=cut
+
+sub get_dpkg_changes {
+ my $self = shift;
+ my $header = $self->get_part('header') // '';
+ $header =~ s/\s+$//;
+ return "\n$header\n\n" . join("\n", @{$self->get_part('changes')});
+}
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 1.01 (dpkg 1.18.8)
+
+New method: $entry->get_timepiece().
+
+=head2 Version 1.00 (dpkg 1.15.6)
+
+Mark the module as public.
+
+=cut
+
+1;
diff --git a/scripts/Dpkg/Changelog/Entry/Debian.pm b/scripts/Dpkg/Changelog/Entry/Debian.pm
new file mode 100644
index 0000000..5f4c9e5
--- /dev/null
+++ b/scripts/Dpkg/Changelog/Entry/Debian.pm
@@ -0,0 +1,490 @@
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
+# Copyright © 2012-2013 Guillem Jover <guillem@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, see <https://www.gnu.org/licenses/>.
+
+package Dpkg::Changelog::Entry::Debian;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.03';
+our @EXPORT_OK = qw(
+ $regex_header
+ $regex_trailer
+ match_header
+ match_trailer
+ find_closes
+);
+
+use Exporter qw(import);
+use Time::Piece;
+
+use Dpkg::Gettext;
+use Dpkg::Control::Fields;
+use Dpkg::Control::Changelog;
+use Dpkg::Changelog::Entry;
+use Dpkg::Version;
+
+use parent qw(Dpkg::Changelog::Entry);
+
+=encoding utf8
+
+=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.
+
+=cut
+
+my $name_chars = qr/[-+0-9a-z.]/i;
+
+# XXX: Backwards compatibility, stop exporting on VERSION 2.00.
+## no critic (Variables::ProhibitPackageVars)
+
+# The matched content is the source package name ($1), the version ($2),
+# the target distributions ($3) and the options on the rest of the line ($4).
+our $regex_header = qr{
+ ^
+ (\w$name_chars*) # Package name
+ \ \(([^\(\) \t]+)\) # Package version
+ ((?:\s+$name_chars+)+) # Target distribution
+ \; # Separator
+ (.*?) # Key=Value options
+ \s*$ # Trailing space
+}xi;
+
+# The matched content is the maintainer name ($1), its email ($2),
+# some blanks ($3) and the timestamp ($4), which is decomposed into
+# day of week ($6), date-time ($7) and this into month name ($8).
+our $regex_trailer = qr<
+ ^
+ \ \-\- # Trailer marker
+ \ (.*) # Maintainer name
+ \ \<(.*)\> # Maintainer email
+ (\ \ ?) # Blanks
+ (
+ ((\w+)\,\s*)? # Day of week (abbreviated)
+ (
+ \d{1,2}\s+ # Day of month
+ (\w+)\s+ # Month name (abbreviated)
+ \d{4}\s+ # Year
+ \d{1,2}:\d\d:\d\d\s+[-+]\d{4} # ISO 8601 date
+ )
+ )
+ \s*$ # Trailing space
+>xo;
+
+my %week_day = map { $_ => 1 } qw(Mon Tue Wed Thu Fri Sat Sun);
+my %month_abbrev = map { $_ => 1 } qw(
+ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
+);
+my %month_name = map { $_ => } qw(
+ January February March April May June July
+ August September October November December
+);
+
+## use critic
+
+=head1 METHODS
+
+=over 4
+
+=item @items = $entry->get_change_items()
+
+Return a list of change items. Each item contains at least one line.
+A change line starting with an asterisk denotes the start of a new item.
+Any change line like "C<[ Raphaël Hertzog ]>" is treated like an item of its
+own even if it starts a set of items attributed to this person (the
+following line necessarily starts a new item).
+
+=cut
+
+sub get_change_items {
+ my $self = shift;
+ my (@items, @blanks, $item);
+ foreach my $line (@{$self->get_part('changes')}) {
+ if ($line =~ /^\s*\*/) {
+ push @items, $item if defined $item;
+ $item = "$line\n";
+ } elsif ($line =~ /^\s*\[\s[^\]]+\s\]\s*$/) {
+ push @items, $item if defined $item;
+ push @items, "$line\n";
+ $item = undef;
+ @blanks = ();
+ } elsif ($line =~ /^\s*$/) {
+ push @blanks, "$line\n";
+ } else {
+ if (defined $item) {
+ $item .= "@blanks$line\n";
+ } else {
+ $item = "$line\n";
+ }
+ @blanks = ();
+ }
+ }
+ push @items, $item if defined $item;
+ return @items;
+}
+
+=item @errors = $entry->parse_header()
+
+=item @errors = $entry->parse_trailer()
+
+Return a list of errors. Each item in the list is an error message
+describing the problem. If the empty list is returned, no errors
+have been found.
+
+=cut
+
+sub parse_header {
+ my $self = shift;
+ my @errors;
+ if (defined($self->{header}) and $self->{header} =~ $regex_header) {
+ $self->{header_source} = $1;
+
+ my $version = Dpkg::Version->new($2);
+ my ($ok, $msg) = version_check($version);
+ if ($ok) {
+ $self->{header_version} = $version;
+ } else {
+ push @errors, sprintf(g_("version '%s' is invalid: %s"), $version, $msg);
+ }
+
+ @{$self->{header_dists}} = split ' ', $3;
+
+ my $options = $4;
+ $options =~ s/^\s+//;
+ my $f = Dpkg::Control::Changelog->new();
+ foreach my $opt (split(/\s*,\s*/, $options)) {
+ unless ($opt =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i) {
+ push @errors, sprintf(g_("bad key-value after ';': '%s'"), $opt);
+ next;
+ }
+ my ($k, $v) = (field_capitalize($1), $2);
+ if (exists $f->{$k}) {
+ push @errors, sprintf(g_('repeated key-value %s'), $k);
+ } else {
+ $f->{$k} = $v;
+ }
+ if ($k eq 'Urgency') {
+ push @errors, sprintf(g_('badly formatted urgency value: %s'), $v)
+ unless ($v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i);
+ } elsif ($k eq 'Binary-Only') {
+ push @errors, sprintf(g_('bad binary-only value: %s'), $v)
+ unless ($v eq 'yes');
+ } elsif ($k =~ m/^X[BCS]+-/i) {
+ } else {
+ push @errors, sprintf(g_('unknown key-value %s'), $k);
+ }
+ }
+ $self->{header_fields} = $f;
+ } else {
+ push @errors, g_("the header doesn't match the expected regex");
+ }
+ return @errors;
+}
+
+sub parse_trailer {
+ my $self = shift;
+ my @errors;
+ if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) {
+ $self->{trailer_maintainer} = "$1 <$2>";
+
+ if ($3 ne ' ') {
+ push @errors, g_('badly formatted trailer line');
+ }
+
+ # Validate the week day. Date::Parse used to ignore it, but Time::Piece
+ # is much more strict and it does not gracefully handle bogus values.
+ if (defined $5 and not exists $week_day{$6}) {
+ push @errors, sprintf(g_('ignoring invalid week day \'%s\''), $6);
+ }
+
+ # Ignore the week day ('%a, '), as we have validated it above.
+ local $ENV{LC_ALL} = 'C';
+ eval {
+ my $tp = Time::Piece->strptime($7, '%d %b %Y %T %z');
+ $self->{trailer_timepiece} = $tp;
+ } or do {
+ # Validate the month. Date::Parse used to accept both abbreviated
+ # and full months, but Time::Piece strptime() implementation only
+ # matches the abbreviated one with %b, which is what we want anyway.
+ if (not exists $month_abbrev{$8}) {
+ # We have to nest the conditionals because May is the same in
+ # full and abbreviated forms!
+ if (exists $month_name{$8}) {
+ push @errors, sprintf(g_('uses full instead of abbreviated month name \'%s\''),
+ $8, $month_name{$8});
+ } else {
+ push @errors, sprintf(g_('invalid abbreviated month name \'%s\''), $8);
+ }
+ }
+ push @errors, sprintf(g_("cannot parse non-conformant date '%s'"), $7);
+ };
+ $self->{trailer_timestamp_date} = $4;
+ } else {
+ push @errors, g_("the trailer doesn't match the expected regex");
+ }
+ return @errors;
+}
+
+=item $entry->check_header()
+
+Obsolete method. Use parse_header() instead.
+
+=cut
+
+sub check_header {
+ my $self = shift;
+
+ warnings::warnif('deprecated',
+ 'obsolete check_header(), use parse_header() instead');
+
+ return $self->parse_header();
+}
+
+=item $entry->check_trailer()
+
+Obsolete method. Use parse_trailer() instead.
+
+=cut
+
+sub check_trailer {
+ my $self = shift;
+
+ warnings::warnif('deprecated',
+ 'obsolete check_trailer(), use parse_trailer() instead');
+
+ return $self->parse_header();
+}
+
+=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 = shift;
+ $self->SUPER::normalize();
+ #XXX: recreate header/trailer
+}
+
+=item $src = $entry->get_source()
+
+Return the name of the source package associated to the changelog entry.
+
+=cut
+
+sub get_source {
+ my $self = shift;
+
+ return $self->{header_source};
+}
+
+=item $ver = $entry->get_version()
+
+Return the version associated to the changelog entry.
+
+=cut
+
+sub get_version {
+ my $self = shift;
+
+ return $self->{header_version};
+}
+
+=item @dists = $entry->get_distributions()
+
+Return a list of target distributions for this version.
+
+=cut
+
+sub get_distributions {
+ my $self = shift;
+
+ if (defined $self->{header_dists}) {
+ return @{$self->{header_dists}} if wantarray;
+ return $self->{header_dists}[0];
+ }
+ return;
+}
+
+=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 {
+ my $self = shift;
+ my $f;
+
+ if (defined $self->{header_fields}) {
+ $f = $self->{header_fields};
+ } else {
+ $f = Dpkg::Control::Changelog->new();
+ }
+
+ my @closes = find_closes(join("\n", @{$self->{changes}}));
+ if (@closes) {
+ $f->{Closes} = join(' ', @closes);
+ }
+
+ return $f;
+}
+
+=item $urgency = $entry->get_urgency()
+
+Return the urgency of the associated upload.
+
+=cut
+
+sub get_urgency {
+ my $self = shift;
+ my $f = $self->get_optional_fields();
+ if (exists $f->{Urgency}) {
+ $f->{Urgency} =~ s/\s.*$//;
+ return lc($f->{Urgency});
+ }
+ return;
+}
+
+=item $maint = $entry->get_maintainer()
+
+Return the string identifying the person who signed this changelog entry.
+
+=cut
+
+sub get_maintainer {
+ my $self = shift;
+
+ return $self->{trailer_maintainer};
+}
+
+=item $time = $entry->get_timestamp()
+
+Return the timestamp of the changelog entry.
+
+=cut
+
+sub get_timestamp {
+ my $self = shift;
+
+ return $self->{trailer_timestamp_date};
+}
+
+=item $time = $entry->get_timepiece()
+
+Return the timestamp of the changelog entry as a Time::Piece object.
+
+This function might return undef if there was no timestamp.
+
+=cut
+
+sub get_timepiece {
+ my $self = shift;
+
+ return $self->{trailer_timepiece};
+}
+
+=back
+
+=head1 UTILITY FUNCTIONS
+
+=over 4
+
+=item $bool = match_header($line)
+
+Checks if the line matches a valid changelog header line.
+
+=cut
+
+sub match_header {
+ my $line = shift;
+
+ return $line =~ /$regex_header/;
+}
+
+=item $bool = match_trailer($line)
+
+Checks if the line matches a valid changelog trailing line.
+
+=cut
+
+sub match_trailer {
+ my $line = shift;
+
+ return $line =~ /$regex_trailer/;
+}
+
+=item @closed_bugs = find_closes($changes)
+
+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.
+
+=cut
+
+sub find_closes {
+ my $changes = shift;
+ my %closes;
+
+ while ($changes && ($changes =~ m{
+ closes:\s*
+ (?:bug)?\#?\s?\d+
+ (?:,\s*(?:bug)?\#?\s?\d+)*
+ }pigx)) {
+ $closes{$_} = 1 foreach (${^MATCH} =~ /\#?\s?(\d+)/g);
+ }
+
+ my @closes = sort { $a <=> $b } keys %closes;
+ return @closes;
+}
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 1.03 (dpkg 1.18.8)
+
+New methods: $entry->get_timepiece().
+
+=head2 Version 1.02 (dpkg 1.18.5)
+
+New methods: $entry->parse_header(), $entry->parse_trailer().
+
+Deprecated methods: $entry->check_header(), $entry->check_trailer().
+
+=head2 Version 1.01 (dpkg 1.17.2)
+
+New functions: match_header(), match_trailer()
+
+Deprecated variables: $regex_header, $regex_trailer
+
+=head2 Version 1.00 (dpkg 1.15.6)
+
+Mark the module as public.
+
+=cut
+
+1;
diff --git a/scripts/Dpkg/Changelog/Parse.pm b/scripts/Dpkg/Changelog/Parse.pm
new file mode 100644
index 0000000..91da43a
--- /dev/null
+++ b/scripts/Dpkg/Changelog/Parse.pm
@@ -0,0 +1,232 @@
+# Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de>
+# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
+# Copyright © 2010, 2012-2015 Guillem Jover <guillem@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, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dpkg::Changelog::Parse - generic changelog parser for dpkg-parsechangelog
+
+=head1 DESCRIPTION
+
+This module provides a set of functions which reproduce all the features
+of dpkg-parsechangelog.
+
+=cut
+
+package Dpkg::Changelog::Parse;
+
+use strict;
+use warnings;
+
+our $VERSION = '1.03';
+our @EXPORT = qw(
+ changelog_parse_debian
+ changelog_parse_plugin
+ changelog_parse
+);
+
+use Exporter qw(import);
+use List::Util qw(none);
+
+use Dpkg ();
+use Dpkg::Gettext;
+use Dpkg::ErrorHandling;
+use Dpkg::Control::Changelog;
+
+sub _changelog_detect_format {
+ my $file = shift;
+ my $format = 'debian';
+
+ # Extract the format from the changelog file if possible
+ if ($file ne '-') {
+ local $_;
+
+ open my $format_fh, '<', $file
+ or syserr(g_('cannot open file %s'), $file);
+ if (-s $format_fh > 4096) {
+ seek $format_fh, -4096, 2
+ or syserr(g_('cannot seek into file %s'), $file);
+ }
+ while (<$format_fh>) {
+ $format = $1 if m/\schangelog-format:\s+([0-9a-z]+)\W/;
+ }
+ close $format_fh;
+ }
+
+ return $format;
+}
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item $fields = changelog_parse_debian(%opt)
+
+This function is deprecated, use changelog_parse() instead, with the changelog
+format set to "debian".
+
+=cut
+
+sub changelog_parse_debian {
+ my (%options) = @_;
+
+ warnings::warnif('deprecated',
+ 'deprecated function changelog_parse_debian, use changelog_parse instead');
+
+ # Force the plugin to be debian.
+ $options{changelogformat} = 'debian';
+
+ return _changelog_parse(%options);
+}
+
+=item $fields = changelog_parse_plugin(%opt)
+
+This function is deprecated, use changelog_parse() instead.
+
+=cut
+
+sub changelog_parse_plugin {
+ my (%options) = @_;
+
+ warnings::warnif('deprecated',
+ 'deprecated function changelog_parse_plugin, use changelog_parse instead');
+
+ return _changelog_parse(%options);
+}
+
+=item $fields = changelog_parse(%opt)
+
+This function will parse a changelog. In list context, it returns as many
+Dpkg::Control objects as the parser did create. In scalar context, it will
+return only the first one. If the parser did not return any data, it will
+return an empty list in list context or undef on scalar context. If the
+parser failed, it will die.
+
+The changelog file that is parsed is F<debian/changelog> by default but it
+can be overridden with $opt{file}. The default output format is "dpkg" but
+it can be overridden with $opt{format}.
+
+The parsing itself is done by a parser module (searched in the standard
+perl library directories. That module is named according to the format that
+it is able to parse, with the name capitalized. By default it is either
+Dpkg::Changelog::Debian (from the "debian" format) or the format name looked
+up in the 40 last lines of the changelog itself (extracted with this perl
+regular expression "\schangelog-format:\s+([0-9a-z]+)\W"). But it can be
+overridden with $opt{changelogformat}.
+
+If $opt{compression} is false, the file will be loaded without compression
+support, otherwise by default compression support is disabled if the file
+is the default.
+
+All the other keys in %opt are forwarded to the parser module constructor.
+
+=cut
+
+sub _changelog_parse {
+ my (%options) = @_;
+
+ # Setup and sanity checks.
+ if (exists $options{libdir}) {
+ warnings::warnif('deprecated',
+ 'obsolete libdir option, changelog parsers are now perl modules');
+ }
+
+ $options{file} //= 'debian/changelog';
+ $options{label} //= $options{file};
+ $options{changelogformat} //= _changelog_detect_format($options{file});
+ $options{format} //= 'dpkg';
+ $options{compression} //= $options{file} ne 'debian/changelog';
+
+ my @range_opts = qw(since until from to offset count reverse all);
+ $options{all} = 1 if exists $options{all};
+ if (none { defined $options{$_} } @range_opts) {
+ $options{count} = 1;
+ }
+ my $range;
+ foreach my $opt (@range_opts) {
+ $range->{$opt} = $options{$opt} if exists $options{$opt};
+ }
+
+ # Find the right changelog parser.
+ my $format = ucfirst lc $options{changelogformat};
+ my $changes;
+ eval qq{
+ pop \@INC if \$INC[-1] eq '.';
+ require Dpkg::Changelog::$format;
+ \$changes = Dpkg::Changelog::$format->new();
+ };
+ error(g_('changelog format %s is unknown: %s'), $format, $@) if $@;
+ $changes->set_options(reportfile => $options{label}, range => $range);
+
+ # Load and parse the changelog.
+ $changes->load($options{file}, compression => $options{compression})
+ or error(g_('fatal error occurred while parsing %s'), $options{file});
+
+ # Get the output into several Dpkg::Control objects.
+ my @res;
+ if ($options{format} eq 'dpkg') {
+ push @res, $changes->format_range('dpkg', $range);
+ } elsif ($options{format} eq 'rfc822') {
+ push @res, $changes->format_range('rfc822', $range);
+ } else {
+ error(g_('unknown output format %s'), $options{format});
+ }
+
+ if (wantarray) {
+ return @res;
+ } else {
+ return $res[0] if @res;
+ return;
+ }
+}
+
+sub changelog_parse {
+ my (%options) = @_;
+
+ if (exists $options{forceplugin}) {
+ warnings::warnif('deprecated', 'obsolete forceplugin option');
+ }
+
+ return _changelog_parse(%options);
+}
+
+=back
+
+=head1 CHANGES
+
+=head2 Version 1.03 (dpkg 1.19.0)
+
+New option: 'compression' in changelog_parse().
+
+=head2 Version 1.02 (dpkg 1.18.8)
+
+Deprecated functions: changelog_parse_debian(), changelog_parse_plugin().
+
+Obsolete options: $forceplugin, $libdir.
+
+=head2 Version 1.01 (dpkg 1.18.2)
+
+New functions: changelog_parse_debian(), changelog_parse_plugin().
+
+=head2 Version 1.00 (dpkg 1.15.6)
+
+Mark the module as public.
+
+=cut
+
+1;