Index: third_party/dpkg-dev/scripts/Dpkg/Changelog/Entry/Debian.pm |
diff --git a/third_party/dpkg-dev/scripts/Dpkg/Changelog/Entry/Debian.pm b/third_party/dpkg-dev/scripts/Dpkg/Changelog/Entry/Debian.pm |
new file mode 100644 |
index 0000000000000000000000000000000000000000..8d059533a6eb34294b7ec4d8e2b6e198c88a8358 |
--- /dev/null |
+++ b/third_party/dpkg-dev/scripts/Dpkg/Changelog/Entry/Debian.pm |
@@ -0,0 +1,323 @@ |
+# 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.01'; |
+ |
+use Exporter qw(import); |
+use Dpkg::Changelog::Entry; |
+use parent qw(Dpkg::Changelog::Entry); |
+our @EXPORT_OK = qw(match_header match_trailer find_closes |
+ $regex_header $regex_trailer); |
+ |
+use Date::Parse; |
+ |
+use Dpkg::Gettext; |
+use Dpkg::Control::Fields; |
+use Dpkg::Control::Changelog; |
+use Dpkg::Version; |
+ |
+=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*) \(([^\(\) \t]+)\)((?:\s+$name_chars+)+)\;(.*?)\s*$/i; |
+ |
+# The matched content is the maintainer name ($1), its email ($2), |
+# some blanks ($3) and the timestamp ($4). |
+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; |
+ |
+## use critic |
+ |
+=head1 FUNCTIONS |
+ |
+=over 4 |
+ |
+=item my @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 "[ 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) = @_; |
+ 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 my @errors = $entry->check_header() |
+ |
+=item my @errors = $entry->check_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 check_header { |
+ my ($self) = @_; |
+ my @errors; |
+ if (defined($self->{header}) and $self->{header} =~ $regex_header) { |
+ my ($version, $options) = ($2, $4); |
+ $options =~ s/^\s+//; |
+ my %optdone; |
+ 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 ($optdone{$k}) { |
+ push @errors, sprintf(_g('repeated key-value %s'), $k); |
+ } |
+ $optdone{$k} = 1; |
+ 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); |
+ } |
+ } |
+ my ($ok, $msg) = version_check($version); |
+ unless ($ok) { |
+ push @errors, sprintf(_g("version '%s' is invalid: %s"), $version, $msg); |
+ } |
+ } else { |
+ push @errors, _g("the header doesn't match the expected regex"); |
+ } |
+ return @errors; |
+} |
+ |
+sub check_trailer { |
+ my ($self) = @_; |
+ my @errors; |
+ if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { |
+ if ($3 ne ' ') { |
+ push @errors, _g('badly formatted trailer line'); |
+ } |
+ unless (defined str2time($4)) { |
+ push @errors, sprintf(_g("couldn't parse date %s"), $4); |
+ } |
+ } else { |
+ push @errors, _g("the trailer doesn't match the expected regex"); |
+ } |
+ return @errors; |
+} |
+ |
+=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; |
+} |
+ |
+sub get_version { |
+ my ($self) = @_; |
+ if (defined($self->{header}) and $self->{header} =~ $regex_header) { |
+ return Dpkg::Version->new($2); |
+ } |
+ return; |
+} |
+ |
+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; |
+} |
+ |
+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; |
+} |
+ |
+sub get_maintainer { |
+ my ($self) = @_; |
+ if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { |
+ return "$1 <$2>"; |
+ } |
+ return; |
+} |
+ |
+sub get_timestamp { |
+ my ($self) = @_; |
+ if (defined($self->{trailer}) and $self->{trailer} =~ $regex_trailer) { |
+ return $4; |
+ } |
+ return; |
+} |
+ |
+=back |
+ |
+=head1 UTILITY FUNCTIONS |
+ |
+=over 4 |
+ |
+=item my $bool = match_header($line) |
+ |
+Checks if the line matches a valid changelog header line. |
+ |
+=cut |
+ |
+sub match_header { |
+ my ($line) = @_; |
+ |
+ return $line =~ /$regex_header/; |
+} |
+ |
+=item my $bool = match_trailer($line) |
+ |
+Checks if the line matches a valid changelog trailing line. |
+ |
+=cut |
+ |
+sub match_trailer { |
+ my ($line) = @_; |
+ |
+ return $line =~ /$regex_trailer/; |
+} |
+ |
+=item my @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 =~ /closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*/ig)) { |
+ $closes{$_} = 1 foreach($& =~ /\#?\s?(\d+)/g); |
+ } |
+ |
+ my @closes = sort { $a <=> $b } keys %closes; |
+ return @closes; |
+} |
+ |
+=back |
+ |
+=head1 CHANGES |
+ |
+=head2 Version 1.01 |
+ |
+New functions: match_header(), match_trailer() |
+Deprecated variables: $regex_header, $regex_trailer |
+ |
+=head1 AUTHOR |
+ |
+Raphaël Hertzog <hertzog@debian.org>. |
+ |
+=cut |
+ |
+1; |