| 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;
|
|
|