diff options
author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-05-06 00:45:20 +0000 |
---|---|---|
committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-05-06 00:45:20 +0000 |
commit | 9a08cbfcc1ef900a04580f35afe2a4592d7d6030 (patch) | |
tree | 004cc7027bca2f2c0bcb5806527c8e0c48df2d6e /scripts/Dpkg/Changelog | |
parent | Initial commit. (diff) | |
download | dpkg-upstream/1.19.8.tar.xz dpkg-upstream/1.19.8.zip |
Adding upstream version 1.19.8.upstream/1.19.8upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
-rw-r--r-- | scripts/Dpkg/Changelog.pm | 779 | ||||
-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 |
5 files changed, 2089 insertions, 0 deletions
diff --git a/scripts/Dpkg/Changelog.pm b/scripts/Dpkg/Changelog.pm new file mode 100644 index 0000000..47752b9 --- /dev/null +++ b/scripts/Dpkg/Changelog.pm @@ -0,0 +1,779 @@ +# Copyright © 2005, 2007 Frank Lichtenheld <frank@lichtenheld.de> +# 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/>. + +=encoding utf8 + +=head1 NAME + +Dpkg::Changelog - base class to implement a changelog parser + +=head1 DESCRIPTION + +Dpkg::Changelog is a class representing a changelog file +as an array of changelog entries (Dpkg::Changelog::Entry). +By deriving this object and implementing its parse method, you +add the ability to fill this object with changelog entries. + +=cut + +package Dpkg::Changelog; + +use strict; +use warnings; + +our $VERSION = '1.01'; + +use Carp; + +use Dpkg::Gettext; +use Dpkg::ErrorHandling qw(:DEFAULT report REPORT_WARN); +use Dpkg::Control; +use Dpkg::Control::Changelog; +use Dpkg::Control::Fields; +use Dpkg::Index; +use Dpkg::Version; +use Dpkg::Vendor qw(run_vendor_hook); + +use parent qw(Dpkg::Interface::Storable); + +use overload + '@{}' => sub { return $_[0]->{data} }; + +=head1 METHODS + +=over 4 + +=item $c = Dpkg::Changelog->new(%options) + +Creates a new changelog object. + +=cut + +sub new { + my ($this, %opts) = @_; + my $class = ref($this) || $this; + my $self = { + verbose => 1, + parse_errors => [] + }; + bless $self, $class; + $self->set_options(%opts); + return $self; +} + +=item $c->set_options(%opts) + +Change the value of some options. "verbose" (defaults to 1) defines +whether parse errors are displayed as warnings by default. "reportfile" +is a string to use instead of the name of the file parsed, in particular +in error messages. "range" defines the range of entries that we want to +parse, the parser will stop as soon as it has parsed enough data to +satisfy $c->get_range($opts{range}). + +=cut + +sub set_options { + my ($self, %opts) = @_; + $self->{$_} = $opts{$_} foreach keys %opts; +} + +=item $c->reset_parse_errors() + +Can be used to delete all information about errors occurred during +previous L<parse> runs. + +=cut + +sub reset_parse_errors { + my $self = shift; + $self->{parse_errors} = []; +} + +=item $c->parse_error($file, $line_nr, $error, [$line]) + +Record a new parse error in $file at line $line_nr. The error message is +specified with $error and a copy of the line can be recorded in $line. + +=cut + +sub parse_error { + my ($self, $file, $line_nr, $error, $line) = @_; + + push @{$self->{parse_errors}}, [ $file, $line_nr, $error, $line ]; + + if ($self->{verbose}) { + if ($line) { + warning("%20s(l$line_nr): $error\nLINE: $line", $file); + } else { + warning("%20s(l$line_nr): $error", $file); + } + } +} + +=item $c->get_parse_errors() + +Returns all error messages from the last L<parse> run. +If called in scalar context returns a human readable +string representation. If called in list context returns +an array of arrays. Each of these arrays contains + +=over 4 + +=item 1. + +a string describing the origin of the data (a filename usually). If the +reportfile configuration option was given, its value will be used instead. + +=item 2. + +the line number where the error occurred + +=item 3. + +an error description + +=item 4. + +the original line + +=back + +=cut + +sub get_parse_errors { + my $self = shift; + + if (wantarray) { + return @{$self->{parse_errors}}; + } else { + my $res = ''; + foreach my $e (@{$self->{parse_errors}}) { + if ($e->[3]) { + $res .= report(REPORT_WARN, g_("%s(l%s): %s\nLINE: %s"), @$e); + } else { + $res .= report(REPORT_WARN, g_('%s(l%s): %s'), @$e); + } + } + return $res; + } +} + +=item $c->set_unparsed_tail($tail) + +Add a string representing unparsed lines after the changelog entries. +Use undef as $tail to remove the unparsed lines currently set. + +=item $c->get_unparsed_tail() + +Return a string representing the unparsed lines after the changelog +entries. Returns undef if there's no such thing. + +=cut + +sub set_unparsed_tail { + my ($self, $tail) = @_; + $self->{unparsed_tail} = $tail; +} + +sub get_unparsed_tail { + my $self = shift; + return $self->{unparsed_tail}; +} + +=item @{$c} + +Returns all the Dpkg::Changelog::Entry objects contained in this changelog +in the order in which they have been parsed. + +=item $c->get_range($range) + +Returns an array (if called in list context) or a reference to an array of +Dpkg::Changelog::Entry objects which each represent one entry of the +changelog. $range is a hash reference describing the range of entries +to return. See section L<"RANGE SELECTION">. + +=cut + +sub __sanity_check_range { + my ($self, $r) = @_; + my $data = $self->{data}; + + if (defined($r->{offset}) and not defined($r->{count})) { + warning(g_("'offset' without 'count' has no effect")) if $self->{verbose}; + delete $r->{offset}; + } + + ## no critic (ControlStructures::ProhibitUntilBlocks) + if ((defined($r->{count}) || defined($r->{offset})) && + (defined($r->{from}) || defined($r->{since}) || + defined($r->{to}) || defined($r->{until}))) + { + warning(g_("you can't combine 'count' or 'offset' with any other " . + 'range option')) if $self->{verbose}; + delete $r->{from}; + delete $r->{since}; + delete $r->{to}; + delete $r->{until}; + } + if (defined($r->{from}) && defined($r->{since})) { + warning(g_("you can only specify one of 'from' and 'since', using " . + "'since'")) if $self->{verbose}; + delete $r->{from}; + } + if (defined($r->{to}) && defined($r->{until})) { + warning(g_("you can only specify one of 'to' and 'until', using " . + "'until'")) if $self->{verbose}; + delete $r->{to}; + } + + # Handle non-existing versions + my (%versions, @versions); + foreach my $entry (@{$data}) { + my $version = $entry->get_version(); + next unless defined $version; + $versions{$version->as_string()} = 1; + push @versions, $version->as_string(); + } + if ((defined($r->{since}) and not exists $versions{$r->{since}})) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'since', $r->{since}); + warning(g_('use newest entry that is earlier than the one specified')); + foreach my $v (@versions) { + if (version_compare_relation($v, REL_LT, $r->{since})) { + $r->{since} = $v; + last; + } + } + if (not exists $versions{$r->{since}}) { + # No version was earlier, include all + warning(g_('none found, starting from the oldest entry')); + delete $r->{since}; + $r->{from} = $versions[-1]; + } + } + if ((defined($r->{from}) and not exists $versions{$r->{from}})) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'from', $r->{from}); + warning(g_('use oldest entry that is later than the one specified')); + my $oldest; + foreach my $v (@versions) { + if (version_compare_relation($v, REL_GT, $r->{from})) { + $oldest = $v; + } + } + if (defined($oldest)) { + $r->{from} = $oldest; + } else { + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'from', $r->{from}); + delete $r->{from}; # No version was oldest + } + } + if (defined($r->{until}) and not exists $versions{$r->{until}}) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'until', $r->{until}); + warning(g_('use oldest entry that is later than the one specified')); + my $oldest; + foreach my $v (@versions) { + if (version_compare_relation($v, REL_GT, $r->{until})) { + $oldest = $v; + } + } + if (defined($oldest)) { + $r->{until} = $oldest; + } else { + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'until', $r->{until}); + delete $r->{until}; # No version was oldest + } + } + if (defined($r->{to}) and not exists $versions{$r->{to}}) { + warning(g_("'%s' option specifies non-existing version '%s'"), 'to', $r->{to}); + warning(g_('use newest entry that is earlier than the one specified')); + foreach my $v (@versions) { + if (version_compare_relation($v, REL_LT, $r->{to})) { + $r->{to} = $v; + last; + } + } + if (not exists $versions{$r->{to}}) { + # No version was earlier + warning(g_("no such entry found, ignoring '%s' parameter '%s'"), 'to', $r->{to}); + delete $r->{to}; + } + } + + if (defined($r->{since}) and $data->[0]->get_version() eq $r->{since}) { + warning(g_("'since' option specifies most recent version '%s', ignoring"), $r->{since}); + delete $r->{since}; + } + if (defined($r->{until}) and $data->[-1]->get_version() eq $r->{until}) { + warning(g_("'until' option specifies oldest version '%s', ignoring"), $r->{until}); + delete $r->{until}; + } + ## use critic +} + +sub get_range { + my ($self, $range) = @_; + $range //= {}; + my $res = $self->_data_range($range); + return unless defined $res; + if (wantarray) { + return reverse @{$res} if $range->{reverse}; + return @{$res}; + } else { + return $res; + } +} + +sub _is_full_range { + my ($self, $range) = @_; + + return 1 if $range->{all}; + + # If no range delimiter is specified, we want everything. + foreach my $delim (qw(since until from to count offset)) { + return 0 if exists $range->{$delim}; + } + + return 1; +} + +sub _data_range { + my ($self, $range) = @_; + + my $data = $self->{data} or return; + + return [ @$data ] if $self->_is_full_range($range); + + $self->__sanity_check_range($range); + + my ($start, $end); + if (defined($range->{count})) { + my $offset = $range->{offset} // 0; + my $count = $range->{count}; + # Convert count/offset in start/end + if ($offset > 0) { + $offset -= ($count < 0); + } elsif ($offset < 0) { + $offset = $#$data + ($count > 0) + $offset; + } else { + $offset = $#$data if $count < 0; + } + $start = $end = $offset; + $start += $count+1 if $count < 0; + $end += $count-1 if $count > 0; + # Check limits + $start = 0 if $start < 0; + return if $start > $#$data; + $end = $#$data if $end > $#$data; + return if $end < 0; + $end = $start if $end < $start; + return [ @{$data}[$start .. $end] ]; + } + + ## no critic (ControlStructures::ProhibitUntilBlocks) + my @result; + my $include = 1; + $include = 0 if defined($range->{to}) or defined($range->{until}); + foreach my $entry (@{$data}) { + my $v = $entry->get_version(); + $include = 1 if defined($range->{to}) and $v eq $range->{to}; + last if defined($range->{since}) and $v eq $range->{since}; + + push @result, $entry if $include; + + $include = 1 if defined($range->{until}) and $v eq $range->{until}; + last if defined($range->{from}) and $v eq $range->{from}; + } + ## use critic + + return \@result if scalar(@result); + return; +} + +=item $c->abort_early() + +Returns true if enough data have been parsed to be able to return all +entries selected by the range set at creation (or with set_options). + +=cut + +sub abort_early { + my $self = shift; + + my $data = $self->{data} or return; + my $r = $self->{range} or return; + my $count = $r->{count} // 0; + my $offset = $r->{offset} // 0; + + return if $self->_is_full_range($r); + return if $offset < 0 or $count < 0; + if (defined($r->{count})) { + if ($offset > 0) { + $offset -= ($count < 0); + } + my $start = my $end = $offset; + $end += $count-1 if $count > 0; + return ($start < @$data and $end < @$data); + } + + return unless defined($r->{since}) or defined($r->{from}); + foreach my $entry (@{$data}) { + my $v = $entry->get_version(); + return 1 if defined($r->{since}) and $v eq $r->{since}; + return 1 if defined($r->{from}) and $v eq $r->{from}; + } + + return; +} + +=item $str = $c->output() + +=item "$c" + +Returns a string representation of the changelog (it's a concatenation of +the string representation of the individual changelog entries). + +=item $c->output($fh) + +Output the changelog to the given filehandle. + +=cut + +sub output { + my ($self, $fh) = @_; + my $str = ''; + foreach my $entry (@{$self}) { + my $text = $entry->output(); + print { $fh } $text if defined $fh; + $str .= $text if defined wantarray; + } + my $text = $self->get_unparsed_tail(); + if (defined $text) { + print { $fh } $text if defined $fh; + $str .= $text if defined wantarray; + } + return $str; +} + +=item $c->save($filename) + +Save the changelog in the given file. + +=cut + +our ( @URGENCIES, %URGENCIES ); +BEGIN { + @URGENCIES = qw(low medium high critical emergency); + my $i = 1; + %URGENCIES = map { $_ => $i++ } @URGENCIES; +} + +sub _format_dpkg { + my ($self, $range) = @_; + + my @data = $self->get_range($range) or return; + my $src = shift @data; + + my $f = Dpkg::Control::Changelog->new(); + $f->{Urgency} = $src->get_urgency() || 'unknown'; + $f->{Source} = $src->get_source() || 'unknown'; + $f->{Version} = $src->get_version() // 'unknown'; + $f->{Distribution} = join(' ', $src->get_distributions()); + $f->{Maintainer} = $src->get_maintainer() // ''; + $f->{Date} = $src->get_timestamp() // ''; + $f->{Timestamp} = $src->get_timepiece && $src->get_timepiece->epoch // ''; + $f->{Changes} = $src->get_dpkg_changes(); + + # handle optional fields + my $opts = $src->get_optional_fields(); + my %closes; + foreach (keys %$opts) { + if (/^Urgency$/i) { # Already dealt + } elsif (/^Closes$/i) { + $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes})); + } else { + field_transfer_single($opts, $f); + } + } + + foreach my $bin (@data) { + my $oldurg = $f->{Urgency} // ''; + my $oldurgn = $URGENCIES{$f->{Urgency}} // -1; + my $newurg = $bin->get_urgency() // ''; + my $newurgn = $URGENCIES{$newurg} // -1; + $f->{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg; + $f->{Changes} .= "\n" . $bin->get_dpkg_changes(); + + # handle optional fields + $opts = $bin->get_optional_fields(); + foreach (keys %$opts) { + if (/^Closes$/i) { + $closes{$_} = 1 foreach (split(/\s+/, $opts->{Closes})); + } elsif (not exists $f->{$_}) { # Don't overwrite an existing field + field_transfer_single($opts, $f); + } + } + } + + if (scalar keys %closes) { + $f->{Closes} = join ' ', sort { $a <=> $b } keys %closes; + } + run_vendor_hook('post-process-changelog-entry', $f); + + return $f; +} + +sub _format_rfc822 { + my ($self, $range) = @_; + + my @data = $self->get_range($range) or return; + my @ctrl; + + foreach my $entry (@data) { + my $f = Dpkg::Control::Changelog->new(); + $f->{Urgency} = $entry->get_urgency() || 'unknown'; + $f->{Source} = $entry->get_source() || 'unknown'; + $f->{Version} = $entry->get_version() // 'unknown'; + $f->{Distribution} = join(' ', $entry->get_distributions()); + $f->{Maintainer} = $entry->get_maintainer() // ''; + $f->{Date} = $entry->get_timestamp() // ''; + $f->{Timestamp} = $entry->get_timepiece && $entry->get_timepiece->epoch // ''; + $f->{Changes} = $entry->get_dpkg_changes(); + + # handle optional fields + my $opts = $entry->get_optional_fields(); + foreach (keys %$opts) { + field_transfer_single($opts, $f) unless exists $f->{$_}; + } + + run_vendor_hook('post-process-changelog-entry', $f); + + push @ctrl, $f; + } + + return @ctrl; +} + +=item $control = $c->format_range($format, $range) + +Formats the changelog into Dpkg::Control::Changelog objects representing the +entries selected by the optional range specifier (see L<"RANGE SELECTION"> +for details). In scalar context returns a Dpkg::Index object containing the +selected entries, in list context returns an array of Dpkg::Control::Changelog +objects. + +With format B<dpkg> the returned Dpkg::Control::Changelog object is coalesced +from the entries in the changelog that are part of the range requested, +with the fields described below, but considering that "selected entry" +means the first entry of the selected range. + +With format B<rfc822> each returned Dpkg::Control::Changelog objects +represents one entry in the changelog that is part of the range requested, +with the fields described below, but considering that "selected entry" +means for each entry. + +The different formats return undef if no entries are matched. The following +fields are contained in the object(s) returned: + +=over 4 + +=item Source + +package name (selected entry) + +=item Version + +packages' version (selected entry) + +=item Distribution + +target distribution (selected entry) + +=item Urgency + +urgency (highest of all entries in range) + +=item Maintainer + +person that created the (selected) entry + +=item Date + +date of the (selected) entry + +=item Timestamp + +date of the (selected) entry as a timestamp in seconds since the epoch + +=item Closes + +bugs closed by the (selected) entry/entries, sorted by bug number + +=item Changes + +content of the (selected) entry/entries + +=back + +=cut + +sub format_range { + my ($self, $format, $range) = @_; + + my @ctrl; + + if ($format eq 'dpkg') { + @ctrl = $self->_format_dpkg($range); + } elsif ($format eq 'rfc822') { + @ctrl = $self->_format_rfc822($range); + } else { + croak "unknown changelog output format $format"; + } + + if (wantarray) { + return @ctrl; + } else { + my $index = Dpkg::Index->new(type => CTRL_CHANGELOG); + + foreach my $f (@ctrl) { + $index->add($f); + } + + return $index; + } +} + +=item $control = $c->dpkg($range) + +This is a deprecated alias for $c->format_range('dpkg', $range). + +=cut + +sub dpkg { + my ($self, $range) = @_; + + warnings::warnif('deprecated', + 'deprecated method, please use format_range("dpkg", $range) instead'); + + return $self->format_range('dpkg', $range); +} + +=item @controls = $c->rfc822($range) + +This is a deprecated alias for C<scalar c->format_range('rfc822', $range)>. + +=cut + +sub rfc822 { + my ($self, $range) = @_; + + warnings::warnif('deprecated', + 'deprecated method, please use format_range("rfc822", $range) instead'); + + return scalar $self->format_range('rfc822', $range); +} + +=back + +=head1 RANGE SELECTION + +A range selection is described by a hash reference where +the allowed keys and values are described below. + +The following options take a version number as value. + +=over 4 + +=item since + +Causes changelog information from all versions strictly +later than B<version> to be used. + +=item until + +Causes changelog information from all versions strictly +earlier than B<version> to be used. + +=item from + +Similar to C<since> but also includes the information for the +specified B<version> itself. + +=item to + +Similar to C<until> but also includes the information for the +specified B<version> itself. + +=back + +The following options don't take version numbers as values: + +=over 4 + +=item all + +If set to a true value, all entries of the changelog are returned, +this overrides all other options. + +=item count + +Expects a signed integer as value. Returns C<value> entries from the +top of the changelog if set to a positive integer, and C<abs(value)> +entries from the tail if set to a negative integer. + +=item offset + +Expects a signed integer as value. Changes the starting point for +C<count>, either counted from the top (positive integer) or from +the tail (negative integer). C<offset> has no effect if C<count> +wasn't given as well. + +=back + +Some examples for the above options. Imagine an example changelog with +entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1. + + Range Included entries + ----- ---------------- + since => '2.0' 3.1, 3.0, 2.2 + until => '2.0' 1.3, 1.2 + from => '2.0' 3.1, 3.0, 2.2, 2.1, 2.0 + to => '2.0' 2.0, 1.3, 1.2 + count => 2 3.1, 3.0 + count => -2 1.3, 1.2 + count => 3, offset => 2 2.2, 2.1, 2.0 + count => 2, offset => -3 2.0, 1.3 + count => -2, offset => 3 3.0, 2.2 + count => -2, offset => -3 2.2, 2.1 + +Any combination of one option of C<since> and C<from> and one of +C<until> and C<to> returns the intersection of the two results +with only one of the options specified. + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.18.8) + +New method: $c->format_range(). + +Deprecated methods: $c->dpkg(), $c->rfc822(). + +New field Timestamp in output formats. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut +1; 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; |