diff options
Diffstat (limited to 'scripts/Dpkg/Changelog')
| -rw-r--r-- | scripts/Dpkg/Changelog/Debian.pm | 264 | ||||
| -rw-r--r-- | scripts/Dpkg/Changelog/Entry.pm | 324 | ||||
| -rw-r--r-- | scripts/Dpkg/Changelog/Entry/Debian.pm | 490 | ||||
| -rw-r--r-- | scripts/Dpkg/Changelog/Parse.pm | 232 |
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; |