From 33283a4b7078bf7b25cef28005e0454674ba3b4f Mon Sep 17 00:00:00 2001 From: Frank Lichtenheld Date: Fri, 30 Nov 2007 22:41:31 +0100 Subject: [PATCH] Dpkg::Changelog: New naming scheme Rename DebianChangelog to Dpkg::Changelog::Debian. Rename DebianChangelog::Entry to Dpkg::Changelog::Entry. Move code from DebianChangelog::Util to Dpkg::Changelog. Move code not specific to the Debian format from DebianChangelog to Dpkg::Changelog. Adapt all the code to Dpkg utility modules. Remove all code for the HTML and XML output. This should remain outside of dpkg-dev. This passes the test suite. --- scripts/Dpkg/Changelog.pm | 803 ++++++++++++++++ scripts/Dpkg/Changelog/Debian.pm | 363 +++++++ scripts/Dpkg/DebianChangelog.pm | 1282 ------------------------- scripts/Dpkg/DebianChangelog/Entry.pm | 175 ---- scripts/Dpkg/DebianChangelog/Util.pm | 184 ---- 5 files changed, 1166 insertions(+), 1641 deletions(-) create mode 100644 scripts/Dpkg/Changelog.pm create mode 100644 scripts/Dpkg/Changelog/Debian.pm delete mode 100644 scripts/Dpkg/DebianChangelog.pm delete mode 100644 scripts/Dpkg/DebianChangelog/Entry.pm delete mode 100644 scripts/Dpkg/DebianChangelog/Util.pm diff --git a/scripts/Dpkg/Changelog.pm b/scripts/Dpkg/Changelog.pm new file mode 100644 index 00000000..f8df3f35 --- /dev/null +++ b/scripts/Dpkg/Changelog.pm @@ -0,0 +1,803 @@ +# +# Dpkg::Changelog +# +# Copyright 2005 Frank Lichtenheld +# +# 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, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# + +=head1 NAME + +Dpkg::Changelog + +=head1 DESCRIPTION + +to be written + +=head2 Functions + +=cut + +package Dpkg::Changelog; + +use strict; +use warnings; + +use English; + +use Dpkg; +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use base qw(Exporter); + +our %EXPORT_TAGS = ( 'util' => [ qw( + find_closes + data2rfc822 + data2rfc822_mult + get_dpkg_changes +) ] ); +our @EXPORT_OK = @{$EXPORT_TAGS{util}}; + +=pod + +=head3 init + +Creates a new object instance. Takes a reference to a hash as +optional argument, which is interpreted as configuration options. +There are currently no supported general configuration options, but +see the other methods for more specific configuration options which +can also specified to C. + +If C or C are specified (see L), C +is called from C. If a fatal error is encountered during parsing +(e.g. the file can't be opened), C will not return a +valid object but C! + +=cut + +sub init { + my $classname = shift; + my $config = shift || {}; + my $self = {}; + bless( $self, $classname ); + + $config->{verbose} = 1 if $config->{debug}; + $self->{config} = $config; + + $self->reset_parse_errors; + + if ($self->{config}{infile} || $self->{config}{instring}) { + defined($self->parse) or return undef; + } + + return $self; +} + +=pod + +=head3 reset_parse_errors + +Can be used to delete all information about errors ocurred during +previous L runs. Note that C also calls this method. + +=cut + +sub reset_parse_errors { + my ($self) = @_; + + $self->{errors}{parser} = []; +} + +sub _do_parse_error { + my ($self, $file, $line_nr, $error, $line) = @_; + shift; + + push @{$self->{errors}{parser}}, [ @_ ]; + + unless ($self->{config}{quiet}) { + if ($line) { + warning("%20s(l$NR): $error\nLINE: $line", $file); + } else { + warning("%20s(l$NR): $error", $file); + } + } +} + +=pod + +=head3 get_parse_errors + +Returns all error messages from the last L 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. + +the filename of the parsed file or C if a string was +parsed directly + +=item 2. + +the line number where the error occurred + +=item 3. + +an error description + +=item 4. + +the original line + +=back + +NOTE: This format isn't stable yet and may change in later versions +of this module. + +=cut + +sub get_parse_errors { + my ($self) = @_; + + if (wantarray) { + return @{$self->{errors}{parser}}; + } else { + my $res = ""; + foreach my $e (@{$self->{errors}{parser}}) { + if ($e->[3]) { + $res .= warning(_g("%s(l%s): %s\nLINE: %s"), @$e ); + } else { + $res .= warning(_g("%s(l%s): %s"), @$e ); + } + } + return $res; + } +} + +sub _do_fatal_error { + my ($self, @msg) = @_; + + $self->{errors}{fatal} = "@msg"; + warning(_g("FATAL: %s"), "@msg")."\n" unless $self->{config}{quiet}; +} + +=pod + +=head3 get_error + +Get the last non-parser error (e.g. the file to parse couldn't be opened). + +=cut + +sub get_error { + my ($self) = @_; + + return $self->{errors}{fatal}; +} + +=pod + +=head3 data + +C returns an array (if called in list context) or a reference +to an array of Parse::DebianChangelog::Entry objects which each +represent one entry of the changelog. + +This is currently merely a placeholder to enable users to get to the +raw data, expect changes to this API in the near future. + +This method supports the common output options described in +section L<"COMMON OUTPUT OPTIONS">. + +=cut + +sub data { + my ($self, $config) = @_; + + my $data = $self->{data}; + if ($config) { + $self->{config}{DATA} = $config if $config; + $data = $self->_data_range( $config ) or return undef; + } + return @$data if wantarray; + return $data; +} + +sub __sanity_check_range { + my ( $data, $from, $to, $since, $until, $start, $end ) = @_; + + if (($$start || $$end) && ($$from || $$since || $$to || $$until)) { + warning(_g( "you can't combine 'count' or 'offset' with any other range option" )); + $$from = $$since = $$to = $$until = ''; + } + if ($$from && $$since) { + warning(_g( "you can only specify one of 'from' and 'since'" )); + $$from = ''; + } + if ($$to && $$until) { + warning(_g( "you can only specify one of 'to' and 'until'" )); + $$to = ''; + } + if ($$since && ($data->[0]{Version} eq $$since)) { + warning(_g( "'since' option specifies most recent version" )); + $$since = ''; + } + if ($$until && ($data->[$#{$data}]{Version} eq $$until)) { + warning(_g( "'until' option specifies oldest version" )); + $$until = ''; + } + $$start = 0 if $$start < 0; + return if $$start > $#$data; + $$end = $#$data if $$end > $#$data; + return if $$end < 0; + $$end = $$start if $$end < $$start; + #TODO: compare versions + return 1; +} + +sub _data_range { + my ($self, $config) = @_; + + my $data = $self->data or return undef; + + return [ @$data ] if $config->{all}; + + my $since = $config->{since} || ''; + my $until = $config->{until} || ''; + my $from = $config->{from} || ''; + my $to = $config->{to} || ''; + my $count = $config->{count} || 0; + my $offset = $config->{offset} || 0; + + return if $offset and not $count; + if ($offset > 0) { + $offset -= ($count < 0); + } elsif ($offset < 0) { + $offset = $#$data + ($count > 0) + $offset; + } else { + $offset = $#$data if $count < 0; + } + my $start = my $end = $offset; + $start += $count+1 if $count < 0; + $end += $count-1 if $count > 0; + + return unless __sanity_check_range( $data, \$from, \$to, + \$since, \$until, + \$start, \$end ); + + + unless ($from or $to or $since or $until or $start or $end) { + return [ @$data ] if $config->{default_all} and not $count; + return [ $data->[0] ]; + } + + return [ @{$data}[$start .. $end] ] if $start or $end; + + my @result; + + my $include = 1; + $include = 0 if $to or $until; + foreach (@$data) { + my $v = $_->{Version}; + $include = 1 if $v eq $to; + last if $v eq $since; + + push @result, $_ if $include; + + $include = 1 if $v eq $until; + last if $v eq $from; + } + + return \@result; +} + +=pod + +=head3 dpkg + +(and B) + +C returns a hash (in list context) or a hash reference +(in scalar context) where the keys are field names and the values are +field values. The following fields are given: + +=over 4 + +=item Source + +package name (in the first entry) + +=item Version + +packages' version (from first entry) + +=item Distribution + +target distribution (from first entry) + +=item Urgency + +urgency (highest of all printed entries) + +=item Maintainer + +person that created the (first) entry + +=item Date + +date of the (first) entry + +=item Closes + +bugs closed by the entry/entries, sorted by bug number + +=item Changes + +content of the the entry/entries + +=back + +C returns a stringified version of this hash which should look +exactly like the output of L. The fields are +ordered like in the list above. + +Both methods only support the common output options described in +section L<"COMMON OUTPUT OPTIONS">. + +=head3 dpkg_str + +See L. + +=cut + +our ( %FIELDIMPS, %URGENCIES ); +BEGIN { + my $i=100; + grep($FIELDIMPS{$_}=$i--, + qw(Source Version Distribution Urgency Maintainer Date Closes + Changes)); + $i=1; + grep($URGENCIES{$_}=$i++, + qw(low medium high critical emergency)); +} + +sub dpkg { + my ($self, $config) = @_; + + $self->{config}{DPKG} = $config if $config; + + $config = $self->{config}{DPKG} || {}; + my $data = $self->_data_range( $config ) or return undef; + + my %f; + foreach my $field (qw( Urgency Source Version + Distribution Maintainer Date )) { + $f{$field} = $data->[0]{$field}; + } + + $f{Changes} = get_dpkg_changes( $data->[0] ); + $f{Closes} = [ @{$data->[0]{Closes}} ]; + + my $first = 1; my $urg_comment = ''; + foreach my $entry (@$data) { + $first = 0, next if $first; + + my $oldurg = $f{Urgency} || ''; + my $oldurgn = $URGENCIES{$f{Urgency}} || -1; + my $newurg = $entry->{Urgency_LC} || ''; + my $newurgn = $URGENCIES{$entry->{Urgency_LC}} || -1; + $f{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg; + $urg_comment .= $entry->{Urgency_Comment}; + + $f{Changes} .= "\n .".get_dpkg_changes( $entry ); + push @{$f{Closes}}, @{$entry->{Closes}}; + } + + $f{Closes} = join " ", sort { $a <=> $b } @{$f{Closes}}; + $f{Urgency} .= $urg_comment; + + return %f if wantarray; + return \%f; +} + +sub dpkg_str { + return data2rfc822( scalar dpkg(@_), \%FIELDIMPS ); +} + +=pod + +=head3 rfc822 + +(and B) + +C returns an array of hashes (in list context) or a reference +to this array (in scalar context) where each hash represents one entry +in the changelog. For the format of such a hash see the description +of the L<"dpkg"> method (while ignoring the remarks about which +values are taken from the first entry). + +C returns a stringified version of this hash which looks +similar to the output of dpkg-parsechangelog but instead of one +stanza the output contains one stanza for each entry. + +Both methods only support the common output options described in +section L<"COMMON OUTPUT OPTIONS">. + +=head3 rfc822_str + +See L. + +=cut + +sub rfc822 { + my ($self, $config) = @_; + + $self->{config}{RFC822} = $config if $config; + + $config = $self->{config}{RFC822} || {}; + my $data = $self->_data_range( $config ) or return undef; + my @out_data; + + foreach my $entry (@$data) { + my %f; + foreach my $field (qw( Urgency Source Version + Distribution Maintainer Date )) { + $f{$field} = $entry->{$field}; + } + + $f{Urgency} .= $entry->{Urgency_Comment}; + $f{Changes} = get_dpkg_changes( $entry ); + $f{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}}; + push @out_data, \%f; + } + + return @out_data if wantarray; + return \@out_data; +} + +sub rfc822_str { + return data2rfc822_mult( scalar rfc822(@_), \%FIELDIMPS ); +} + +=pod + +=head1 COMMON OUTPUT OPTIONS + +The following options are supported by all output methods, +all take a version number as value: + +=over 4 + +=item since + +Causes changelog information from all versions strictly +later than B to be used. + +(works exactly like the C<-v> option of dpkg-parsechangelog). + +=item until + +Causes changelog information from all versions strictly +earlier than B to be used. + +=item from + +Similar to C but also includes the information for the +specified B itself. + +=item to + +Similar to C but also includes the information for the +specified B itself. + +=back + +The following options also supported by all output methods but +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. While the XML and HTML formats +default to all == true, this does of course not overwrite other +options unless it is set explicitly with the call. + +=item count + +Expects a signed integer as value. Returns C entries from the +top of the changelog if set to a positive integer, and C +entries from the tail if set to a negative integer. + +=item offset + +Expects a signed integer as value. Changes the starting point for +C, either counted from the top (positive integer) or from +the tail (negative integer). C has no effect if C +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. + + Call Included entries + CformatE({ since =E '2.0' })> 3.1, 3.0, 2.2 + CformatE({ until =E '2.0' })> 1.3, 1.2 + CformatE({ from =E '2.0' })> 3.1, 3.0, 2.2, 2.1, 2.0 + CformatE({ to =E '2.0' })> 2.0, 1.3, 1.2 + CformatE({ count =E 2 }>> 3.1, 3.0 + CformatE({ count =E -2 }>> 1.3, 1.2 + CformatE({ count =E 3, + offset=E 2 }>> 2.2, 2.1, 2.0 + CformatE({ count =E 2, + offset=E -3 }>> 2.0, 1.3 + CformatE({ count =E -2, + offset=E 3 }>> 3.0, 2.2 + CformatE({ count =E -2, + offset=E -3 }>> 2.2, 2.1 + +Any combination of one option of C and C and one of +C and C returns the intersection of the two results +with only one of the options specified. + +=head3 find_closes + +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 reference. + +=cut + +sub find_closes { + my $changes = shift; + my @closes = (); + + while ($changes && ($changes =~ /closes:\s*(?:bug)?\#?\s?\d+(?:,\s*(?:bug)?\#?\s?\d+)*/ig)) { + push(@closes, $& =~ /\#?\s?(\d+)/g); + } + + @closes = sort { $a <=> $b } @closes; + return \@closes; +} + +=pod + +=head3 data2rfc822 + +Takes two hash references as arguments. The first should contain the +data to output in RFC822 format. The second can contain a sorting order +for the fields. The higher the numerical value of the hash value, the +earlier the field is printed if it exists. + +Return the data in RFC822 format as string. + +=cut + +sub data2rfc822 { + my ($data, $fieldimps) = @_; + my $rfc822_str = ''; + +# based on /usr/lib/dpkg/controllib.pl + for my $f (sort { $fieldimps->{$b} <=> $fieldimps->{$a} } keys %$data) { + my $v= $data->{$f} or next; + $v =~ m/\S/o || next; # delete whitespace-only fields + $v =~ m/\n\S/o + && warning(_g("field %s has newline then non whitespace >%s<", + $f, $v )); + $v =~ m/\n[ \t]*\n/o && warning(_g("field %s has blank lines >%s<", + $f, $v )); + $v =~ m/\n$/o && warning(_g("field %s has trailing newline >%s<", + $f, $v )); + $v =~ s/\$\{\}/\$/go; + $rfc822_str .= "$f: $v\n"; + } + + return $rfc822_str; +} + +=pod + +=head3 data2rfc822_mult + +The first argument should be an array ref to an array of hash references. +The second argument is a hash reference and has the same meaning as +the second argument of L. + +Calls L for each element of the array given as first +argument and returns the concatenated results. + +=cut + +sub data2rfc822_mult { + my ($data, $fieldimps) = @_; + my @rfc822 = (); + + foreach my $entry (@$data) { + push @rfc822, data2rfc822($entry,$fieldimps); + } + + return join "\n", @rfc822; +} + +=pod + +=head3 get_dpkg_changes + +Takes a Dpkg::Changelog::Entry object as first argument. + +Returns a string that is suitable for using it in a C field +in the output format of C. + +=cut + +sub get_dpkg_changes { + my $changes = "\n ".($_[0]->Header||'')."\n .\n".($_[0]->Changes||''); + chomp $changes; + $changes =~ s/^ $/ ./mgo; + return $changes; +} + +=head1 NAME + +Dpkg::Changelog::Entry - represents one entry in a Debian changelog + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head2 Methods + +=head3 init + +Creates a new object, no options. + +=head3 new + +Alias for init. + +=head3 is_empty + +Checks if the object is actually initialized with data. This +currently simply checks if one of the fields Source, Version, +Maintainer, Date, or Changes is initalized. + +=head2 Accessors + +The following fields are available via accessor functions (all +fields are string values unless otherwise noted): + +=over 4 + +=item * + +Source + +=item * + +Version + +=item * + +Distribution + +=item * + +Urgency + +=item * + +ExtraFields (all fields except for urgency as hash) + +=item * + +Header (the whole header in verbatim form) + +=item * + +Changes (the actual content of the bug report, in verbatim form) + +=item * + +Trailer (the whole trailer in verbatim form) + +=item * + +Closes (Array of bug numbers) + +=item * + +Maintainer (name B email address) + +=item * + +Date + +=item * + +Timestamp (Date expressed in seconds since the epoche) + +=item * + +ERROR (last parse error related to this entry in the format described +at Parse::DebianChangelog::get_parse_errors. + +=back + +=cut + +package Dpkg::Changelog::Entry; + +use base qw( Class::Accessor ); + +Dpkg::Changelog::Entry->mk_accessors(qw( Closes Changes Maintainer + MaintainerEmail Date + Urgency Distribution + Source Version ERROR + ExtraFields Header + Trailer Timestamp )); + +sub new { + return init(@_); +} + +sub init { + my $classname = shift; + my $self = {}; + bless( $self, $classname ); + + return $self; +} + +sub is_empty { + my ($self) = @_; + + return !($self->{Changes} + || $self->{Source} + || $self->{Version} + || $self->{Maintainer} + || $self->{Date}); +} + +1; +__END__ + +=head1 AUTHOR + +Frank Lichtenheld, Efrank@lichtenheld.deE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Frank Lichtenheld + +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, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +=cut diff --git a/scripts/Dpkg/Changelog/Debian.pm b/scripts/Dpkg/Changelog/Debian.pm new file mode 100644 index 00000000..7cfd0ace --- /dev/null +++ b/scripts/Dpkg/Changelog/Debian.pm @@ -0,0 +1,363 @@ +# +# Dpkg::Changelog::Debian +# +# Copyright 1996 Ian Jackson +# Copyright 2005 Frank Lichtenheld +# +# 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, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA +# + +=head1 NAME + +Dpkg::Changelog::Debian - parse Debian changelogs + +=head1 SYNOPSIS + + use Parse::DebianChangelog; + + my $chglog = Parse::DebianChangelog->init( { infile => 'debian/changelog', + HTML => { outfile => 'changelog.html' } ); + $chglog->html; + + # the following is semantically equivalent + my $chglog = Parse::DebianChangelog->init(); + $chglog->parse( { infile => 'debian/changelog' } ); + $chglog->html( { outfile => 'changelog.html' } ); + + my $changes = $chglog->dpkg_str( { since => '1.0-1' } ); + print $changes; + +=head1 DESCRIPTION + +Dpkg::Changelog::Debian parses Debian changelogs as described in the Debian +policy (version 3.6.2.1 at the time of this writing). See section +L<"SEE ALSO"> for locations where to find this definition. + +The parser tries to ignore most cruft like # or /* */ style comments, +CVS comments, vim variables, 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. + +=head2 METHODS + +=cut + +package Dpkg::Changelog::Debian; + +use strict; +use warnings; + +use Fcntl qw( :flock ); +use English; +use Date::Parse; + +use Dpkg; +use Dpkg::Gettext; +use Dpkg::ErrorHandling; +use Dpkg::Changelog qw( :util ); +use base qw(Dpkg::Changelog); + +=pod + +=head3 parse + +Parses either the file named in configuration item C or the string +saved in configuration item C. +Accepts a hash ref as optional argument which can contain configuration +items. + +Returns C in case of error (e.g. "file not found", B parse +errors) and the object if successful. If C was returned, you +can get the reason for the failure by calling the L method. + +=cut + +sub parse { + my ($self, $config) = @_; + + foreach my $c (keys %$config) { + $self->{config}{$c} = $config->{$c}; + } + + my ($fh, $file); + if ($file = $self->{config}{infile}) { + open $fh, '<', $file or do { + $self->_do_fatal_error( _g("can't open file %s: %s"), + $file, $! ); + return undef; + }; + flock $fh, LOCK_SH or do { + $self->_do_fatal_error( _g("can't lock file %s: %s"), + $file, $! ); + return undef; + }; + } elsif (my $string = $self->{config}{instring}) { + eval { require IO::String }; + if ($@) { + $self->_do_fatal_error( _g("can't load IO::String: %s"), + $@ ); + return undef; + } + $fh = IO::String->new( $string ); + $file = 'String'; + } else { + $self->_do_fatal_error(_g('no changelog file specified')); + return undef; + } + + $self->reset_parse_errors; + + $self->{data} = []; + +# based on /usr/lib/dpkg/parsechangelog/debian + my $expect='first heading'; + my $entry = Dpkg::Changelog::Entry->init(); + my $blanklines = 0; + my $unknowncounter = 1; # to make version unique, e.g. for using as id + + while (<$fh>) { + s/\s*\n$//; +# printf(STDERR "%-39.39s %-39.39s\n",$expect,$_); + if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) { + unless ($expect eq 'first heading' + || $expect eq 'next heading or eof') { + $entry->{ERROR} = [ $file, $NR, + _g( "found start of entry where expected %s", + $expect ), "$_" ]; + $self->_do_parse_error(@{$entry->{ERROR}}); + } + unless ($entry->is_empty) { + $entry->{'Closes'} = find_closes( $entry->{Changes} ); +# print STDERR, Dumper($entry); + push @{$self->{data}}, $entry; + $entry = Dpkg::Changelog::Entry->init(); + } + { + $entry->{'Source'} = "$1"; + $entry->{'Version'} = "$2"; + $entry->{'Header'} = "$_"; + ($entry->{'Distribution'} = "$3") =~ s/^\s+//; + $entry->{'Changes'} = $entry->{'Urgency_Comment'} = ''; + $entry->{'Urgency'} = $entry->{'Urgency_LC'} = 'unknown'; + } + (my $rhs = $POSTMATCH) =~ s/^\s+//; + my %kvdone; +# print STDERR "RHS: $rhs\n"; + for my $kv (split(/\s*,\s*/,$rhs)) { + $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i || + $self->_do_parse_error($file, $NR, + _g( "bad key-value after \`;': \`%s'", $kv )); + my $k = ucfirst $1; + my $v = $2; + $kvdone{$k}++ && $self->_do_parse_error($file, $NR, + _g( "repeated key-value %s", $k )); + if ($k eq 'Urgency') { + $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i || + $self->_do_parse_error($file, $NR, + _g( "badly formatted urgency value" ), + $v); + $entry->{'Urgency'} = "$1"; + $entry->{'Urgency_LC'} = lc("$1"); + $entry->{'Urgency_Comment'} = "$2"; + } elsif ($k =~ m/^X[BCS]+-/i) { + # Extensions - XB for putting in Binary, + # XC for putting in Control, XS for putting in Source + $entry->{$k}= $v; + } else { + $self->_do_parse_error($file, $NR, + _g( "unknown key-value key %s - copying to XS-%s", $k, $k )); + $entry->{ExtraFields}{"XS-$k"} = $v; + } + } + $expect= 'start of change data'; + $blanklines = 0; + } elsif (m/^(;;\s*)?Local variables:/io) { + last; # skip Emacs variables at end of file + } elsif (m/^vim:/io) { + last; # skip vim variables at end of file + } elsif (m/^\$\w+:.*\$/o) { + next; # skip stuff that look like a CVS keyword + } elsif (m/^\# /o) { + next; # skip comments, even that's not supported + } elsif (m,^/\*.*\*/,o) { + next; # more comments + } elsif (m/^(\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o + || m/^(\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o + || m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)\;?/io + || m/^([\w.+-]+)(-| )(\S+) Debian (\S+)/io + || m/^Changes from version (.*) to (.*):/io + || m/^Changes for [\w.+-]+-[\w.+-]+:?$/io + || m/^Old Changelog:$/io + || m/^(?:\d+:)?\w[\w.+~-]*:?$/o) { + # 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->{oldformat} = "$_\n"; + $self->{oldformat} .= join "", <$fh>; + } elsif (m/^\S/) { + $self->_do_parse_error($file, $NR, + _g( "badly formatted heading line" ), "$_"); + } elsif (m/^ \-\- (.*) <(.*)>( ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)$/o) { + $expect eq 'more change data or trailer' || + $self->_do_parse_error($file, $NR, + _g( "found trailer where expected %s", + $expect ), "$_"); + if ($3 ne ' ') { + $self->_do_parse_error($file, $NR, + _g( "badly formatted trailer line" ), + "$_"); + } + $entry->{'Trailer'} = $_; + $entry->{'Maintainer'} = "$1 <$2>" unless $entry->{'Maintainer'}; + unless($entry->{'Date'} && defined $entry->{'Timestamp'}) { + $entry->{'Date'} = "$4"; + $entry->{'Timestamp'} = str2time($4); + unless (defined $entry->{'Timestamp'}) { + $self->_do_parse_error( $file, $NR, + _g( "couldn't parse date %s", + "$4" ) ); + } + } + $expect = 'next heading or eof'; + } elsif (m/^ \-\-/) { + $entry->{ERROR} = [ $file, $NR, + _g( "badly formatted trailer line" ), "$_" ]; + $self->_do_parse_error(@{$entry->{ERROR}}); +# $expect = 'next heading or eof' +# if $expect eq 'more change data or trailer'; + } elsif (m/^\s{2,}(\S)/) { + $expect eq 'start of change data' + || $expect eq 'more change data or trailer' + || do { + $self->_do_parse_error($file, $NR, + _g( "found change data where expected %s", + $expect ), "$_"); + if (($expect eq 'next heading or eof') + && !$entry->is_empty) { + # lets assume we have missed the actual header line + $entry->{'Closes'} = find_closes( $entry->{Changes} ); +# print STDERR, Dumper($entry); + push @{$self->{data}}, $entry; + $entry = Dpkg::Changelog::Entry->init(); + $entry->{Source} = + $entry->{Distribution} = $entry->{Urgency} = + $entry->{Urgency_LC} = 'unknown'; + $entry->{Version} = 'unknown'.($unknowncounter++); + $entry->{Urgency_Comment} = ''; + $entry->{ERROR} = [ $file, $NR, + _g( "found change data where expected %s", + $expect ), "$_" ]; + } + }; + $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n"; + if (!$entry->{'Items'} || ($1 eq '*')) { + $entry->{'Items'} ||= []; + push @{$entry->{'Items'}}, "$_\n"; + } else { + $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n"; + } + $blanklines = 0; + $expect = 'more change data or trailer'; + } elsif (!m/\S/) { + next if $expect eq 'start of change data' + || $expect eq 'next heading or eof'; + $expect eq 'more change data or trailer' + || $self->_do_parse_error($file, $NR, + _g( "found blank line where expected %s", + $expect )); + $blanklines++; + } else { + $self->_do_parse_error($file, $NR, _g( "unrecognised line" ), + "$_"); + ($expect eq 'start of change data' + || $expect eq 'more change data or trailer') + && do { + # lets assume change data if we expected it + $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n"; + if (!$entry->{'Items'}) { + $entry->{'Items'} ||= []; + push @{$entry->{'Items'}}, "$_\n"; + } else { + $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n"; + } + $blanklines = 0; + $expect = 'more change data or trailer'; + $entry->{ERROR} = [ $file, $NR, _g( "unrecognised line" ), + "$_" ]; + }; + } + } + + $expect eq 'next heading or eof' + || do { + $entry->{ERROR} = [ $file, $NR, + _g( "found eof where expected %s", + $expect ) ]; + $self->_do_parse_error( @{$entry->{ERROR}} ); + }; + unless ($entry->is_empty) { + $entry->{'Closes'} = find_closes( $entry->{Changes} ); + push @{$self->{data}}, $entry; + } + + if ($self->{config}{infile}) { + close $fh or do { + $self->_do_fatal_error( _g( "can't close file %s: %s", + $file, $! )); + return undef; + }; + } + +# use Data::Dumper; +# print Dumper( $self ); + + return $self; +} + +1; +__END__ + +=head1 SEE ALSO + +Dpkg::Changelog + +Description of the Debian changelog format in the Debian policy: +L. + +=head1 AUTHOR + +Frank Lichtenheld, Efrank@lichtenheld.deE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 by Frank Lichtenheld + +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, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +=cut diff --git a/scripts/Dpkg/DebianChangelog.pm b/scripts/Dpkg/DebianChangelog.pm deleted file mode 100644 index 30186de8..00000000 --- a/scripts/Dpkg/DebianChangelog.pm +++ /dev/null @@ -1,1282 +0,0 @@ -# -# Parse::DebianChangelog -# -# Copyright 1996 Ian Jackson -# Copyright 2005 Frank Lichtenheld -# -# 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, write to the Free Software -# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -# - -=head1 NAME - -Parse::DebianChangelog - parse Debian changelogs and output them in other formats - -=head1 SYNOPSIS - - use Parse::DebianChangelog; - - my $chglog = Parse::DebianChangelog->init( { infile => 'debian/changelog', - HTML => { outfile => 'changelog.html' } ); - $chglog->html; - - # the following is semantically equivalent - my $chglog = Parse::DebianChangelog->init(); - $chglog->parse( { infile => 'debian/changelog' } ); - $chglog->html( { outfile => 'changelog.html' } ); - - my $changes = $chglog->dpkg_str( { since => '1.0-1' } ); - print $changes; - -=head1 DESCRIPTION - -Parse::DebianChangelog parses Debian changelogs as described in the Debian -policy (version 3.6.2.1 at the time of this writing). See section -L<"SEE ALSO"> for locations where to find this definition. - -The parser tries to ignore most cruft like # or /* */ style comments, -CVS comments, vim variables, 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. - -Beside giving access to the details of the parsed file via the -L<"data"> method, Parse::DebianChangelog also supports converting these -changelogs to various other formats. These are currently: - -=over 4 - -=item dpkg - -Format as known from L. All requested entries -(see L<"METHODS"> for an explanation what this means) are returned in -the usual Debian control format, merged in one stanza, ready to be used -in a F<.changes> file. - -=item rfc822 - -Similar to the C format, but the requested entries are returned -as one stanza each, i.e. they are not merged. This is probably the format -to use if you want a machine-usable representation of the changelog. - -=item xml - -Just a simple XML dump of the changelog data. Without any schema or -DTD currently, just some made up XML. The actual format might still -change. Comments and Improvements welcome. - -=item html - -The changelog is converted to a somewhat nice looking HTML file with -some nice features as a quick-link bar with direct links to every entry. -NOTE: This is not very configurable yet and was specifically designed -to be used on L. This is planned to be -changed until version 1.0. - -=back - -=head2 METHODS - -=cut - -package Parse::DebianChangelog; - -use strict; -use warnings; - -use Fcntl qw( :flock ); -use English; -use Locale::gettext; -use Date::Parse; -use Parse::DebianChangelog::Util qw( :all ); -use Parse::DebianChangelog::Entry; - -our $VERSION = '1.1.1'; - -=pod - -=head3 init - -Creates a new object instance. Takes a reference to a hash as -optional argument, which is interpreted as configuration options. -There are currently no supported general configuration options, but -see the other methods for more specific configuration options which -can also specified to C. - -If C or C are specified (see L), C -is called from C. If a fatal error is encountered during parsing -(e.g. the file can't be opened), C will not return a -valid object but C! - -=cut - -sub init { - my $classname = shift; - my $config = shift || {}; - my $self = {}; - bless( $self, $classname ); - - $config->{verbose} = 1 if $config->{debug}; - $self->{config} = $config; - - $self->init_filters; - $self->reset_parse_errors; - - if ($self->{config}{infile} || $self->{config}{instring}) { - defined($self->parse) or return undef; - } - - return $self; -} - -=pod - -=head3 reset_parse_errors - -Can be used to delete all information about errors ocurred during -previous L runs. Note that C also calls this method. - -=cut - -sub reset_parse_errors { - my ($self) = @_; - - $self->{errors}{parser} = []; -} - -sub _do_parse_error { - my ($self, $file, $line_nr, $error, $line) = @_; - shift; - - push @{$self->{errors}{parser}}, [ @_ ]; - - $file = substr $file, 0, 20; - unless ($self->{config}{quiet}) { - if ($line) { - warn "WARN: $file(l$NR): $error\nLINE: $line\n"; - } else { - warn "WARN: $file(l$NR): $error\n"; - } - } -} - -=pod - -=head3 get_parse_errors - -Returns all error messages from the last L 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. - -the filename of the parsed file or C if a string was -parsed directly - -=item 2. - -the line number where the error occurred - -=item 3. - -an error description - -=item 4. - -the original line - -=back - -NOTE: This format isn't stable yet and may change in later versions -of this module. - -=cut - -sub get_parse_errors { - my ($self) = @_; - - if (wantarray) { - return @{$self->{errors}{parser}}; - } else { - my $res = ""; - foreach my $e (@{$self->{errors}{parser}}) { - if ($e->[3]) { - $res .= __g( "WARN: %s(l%s): %s\nLINE: %s\n", @$e ); - } else { - $res .= __g( "WARN: %s(l%s): %s\n", @$e ); - } - } - return $res; - } -} - -sub _do_fatal_error { - my ($self, @msg) = @_; - - $self->{errors}{fatal} = "@msg"; - warn __g( "FATAL: %s", "@msg")."\n" unless $self->{config}{quiet}; -} - -=pod - -=head3 get_error - -Get the last non-parser error (e.g. the file to parse couldn't be opened). - -=cut - -sub get_error { - my ($self) = @_; - - return $self->{errors}{fatal}; -} - -=pod - -=head3 parse - -Parses either the file named in configuration item C or the string -saved in configuration item C. -Accepts a hash ref as optional argument which can contain configuration -items. - -Returns C in case of error (e.g. "file not found", B parse -errors) and the object if successful. If C was returned, you -can get the reason for the failure by calling the L method. - -=cut - -sub __g { - my $string = shift; - return sprintf( dgettext( 'Parse-DebianChangelog', $string ), @_ ); -} - -sub parse { - my ($self, $config) = @_; - - foreach my $c (keys %$config) { - $self->{config}{$c} = $config->{$c}; - } - - my ($fh, $file); - if ($file = $self->{config}{infile}) { - open $fh, '<', $file or do { - $self->_do_fatal_error( __g( "can't open file %s: %s", - $file, $! )); - return undef; - }; - flock $fh, LOCK_SH or do { - $self->_do_fatal_error( __g( "can't lock file %s: %s", - $file, $! )); - return undef; - }; - } elsif (my $string = $self->{config}{instring}) { - eval { require IO::String }; - if ($@) { - $self->_do_fatal_error( __g( "can't load IO::String: %s", - $@ )); - return undef; - } - $fh = IO::String->new( $string ); - $file = 'String'; - } else { - $self->_do_fatal_error( __g( 'no changelog file specified' )); - return undef; - } - - $self->reset_parse_errors; - - $self->{data} = []; - -# based on /usr/lib/dpkg/parsechangelog/debian - my $expect='first heading'; - my $entry = Parse::DebianChangelog::Entry->init(); - my $blanklines = 0; - my $unknowncounter = 1; # to make version unique, e.g. for using as id - - while (<$fh>) { - s/\s*\n$//; -# printf(STDERR "%-39.39s %-39.39s\n",$expect,$_); - if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) { - unless ($expect eq 'first heading' - || $expect eq 'next heading or eof') { - $entry->{ERROR} = [ $file, $NR, - __g( "found start of entry where expected %s", - $expect ), "$_" ]; - $self->_do_parse_error(@{$entry->{ERROR}}); - } - unless ($entry->is_empty) { - $entry->{'Closes'} = find_closes( $entry->{Changes} ); -# print STDERR, Dumper($entry); - push @{$self->{data}}, $entry; - $entry = Parse::DebianChangelog::Entry->init(); - } - { - $entry->{'Source'} = "$1"; - $entry->{'Version'} = "$2"; - $entry->{'Header'} = "$_"; - ($entry->{'Distribution'} = "$3") =~ s/^\s+//; - $entry->{'Changes'} = $entry->{'Urgency_Comment'} = ''; - $entry->{'Urgency'} = $entry->{'Urgency_LC'} = 'unknown'; - } - (my $rhs = $POSTMATCH) =~ s/^\s+//; - my %kvdone; -# print STDERR "RHS: $rhs\n"; - for my $kv (split(/\s*,\s*/,$rhs)) { - $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i || - $self->_do_parse_error($file, $NR, - __g( "bad key-value after \`;': \`%s'", $kv )); - my $k = ucfirst $1; - my $v = $2; - $kvdone{$k}++ && $self->_do_parse_error($file, $NR, - __g( "repeated key-value %s", $k )); - if ($k eq 'Urgency') { - $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i || - $self->_do_parse_error($file, $NR, - __g( "badly formatted urgency value" ), - $v); - $entry->{'Urgency'} = "$1"; - $entry->{'Urgency_LC'} = lc("$1"); - $entry->{'Urgency_Comment'} = "$2"; - } elsif ($k =~ m/^X[BCS]+-/i) { - # Extensions - XB for putting in Binary, - # XC for putting in Control, XS for putting in Source - $entry->{$k}= $v; - } else { - $self->_do_parse_error($file, $NR, - __g( "unknown key-value key %s - copying to XS-%s", $k, $k )); - $entry->{ExtraFields}{"XS-$k"} = $v; - } - } - $expect= 'start of change data'; - $blanklines = 0; - } elsif (m/^(;;\s*)?Local variables:/io) { - last; # skip Emacs variables at end of file - } elsif (m/^vim:/io) { - last; # skip vim variables at end of file - } elsif (m/^\$\w+:.*\$/o) { - next; # skip stuff that look like a CVS keyword - } elsif (m/^\# /o) { - next; # skip comments, even that's not supported - } elsif (m,^/\*.*\*/,o) { - next; # more comments - } elsif (m/^(\w+\s+\w+\s+\d{1,2} \d{1,2}:\d{1,2}:\d{1,2}\s+[\w\s]*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o - || m/^(\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o - || m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)\;?/io - || m/^([\w.+-]+)(-| )(\S+) Debian (\S+)/io - || m/^Changes from version (.*) to (.*):/io - || m/^Changes for [\w.+-]+-[\w.+-]+:?$/io - || m/^Old Changelog:$/io - || m/^(?:\d+:)?\w[\w.+~-]*:?$/o) { - # 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->{oldformat} = "$_\n"; - $self->{oldformat} .= join "", <$fh>; - } elsif (m/^\S/) { - $self->_do_parse_error($file, $NR, - __g( "badly formatted heading line" ), "$_"); - } elsif (m/^ \-\- (.*) <(.*)>( ?)((\w+\,\s*)?\d{1,2}\s+\w+\s+\d{4}\s+\d{1,2}:\d\d:\d\d\s+[-+]\d{4}(\s+\([^\\\(\)]\))?)$/o) { - $expect eq 'more change data or trailer' || - $self->_do_parse_error($file, $NR, - __g( "found trailer where expected %s", - $expect ), "$_"); - if ($3 ne ' ') { - $self->_do_parse_error($file, $NR, - __g( "badly formatted trailer line" ), - "$_"); - } - $entry->{'Trailer'} = $_; - $entry->{'Maintainer'} = "$1 <$2>" unless $entry->{'Maintainer'}; - unless($entry->{'Date'} && defined $entry->{'Timestamp'}) { - $entry->{'Date'} = "$4"; - $entry->{'Timestamp'} = str2time($4); - unless (defined $entry->{'Timestamp'}) { - $self->_do_parse_error( $file, $NR, - __g( "couldn't parse date %s", - "$4" ) ); - } - } - $expect = 'next heading or eof'; - } elsif (m/^ \-\-/) { - $entry->{ERROR} = [ $file, $NR, - __g( "badly formatted trailer line" ), "$_" ]; - $self->_do_parse_error(@{$entry->{ERROR}}); -# $expect = 'next heading or eof' -# if $expect eq 'more change data or trailer'; - } elsif (m/^\s{2,}(\S)/) { - $expect eq 'start of change data' - || $expect eq 'more change data or trailer' - || do { - $self->_do_parse_error($file, $NR, - __g( "found change data where expected %s", - $expect ), "$_"); - if (($expect eq 'next heading or eof') - && !$entry->is_empty) { - # lets assume we have missed the actual header line - $entry->{'Closes'} = find_closes( $entry->{Changes} ); -# print STDERR, Dumper($entry); - push @{$self->{data}}, $entry; - $entry = Parse::DebianChangelog::Entry->init(); - $entry->{Source} = - $entry->{Distribution} = $entry->{Urgency} = - $entry->{Urgency_LC} = 'unknown'; - $entry->{Version} = 'unknown'.($unknowncounter++); - $entry->{Urgency_Comment} = ''; - $entry->{ERROR} = [ $file, $NR, - __g( "found change data where expected %s", - $expect ), "$_" ]; - } - }; - $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n"; - if (!$entry->{'Items'} || ($1 eq '*')) { - $entry->{'Items'} ||= []; - push @{$entry->{'Items'}}, "$_\n"; - } else { - $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n"; - } - $blanklines = 0; - $expect = 'more change data or trailer'; - } elsif (!m/\S/) { - next if $expect eq 'start of change data' - || $expect eq 'next heading or eof'; - $expect eq 'more change data or trailer' - || $self->_do_parse_error($file, $NR, - __g( "found blank line where expected %s", - $expect )); - $blanklines++; - } else { - $self->_do_parse_error($file, $NR, __g( "unrecognised line" ), - "$_"); - ($expect eq 'start of change data' - || $expect eq 'more change data or trailer') - && do { - # lets assume change data if we expected it - $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n"; - if (!$entry->{'Items'}) { - $entry->{'Items'} ||= []; - push @{$entry->{'Items'}}, "$_\n"; - } else { - $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n"; - } - $blanklines = 0; - $expect = 'more change data or trailer'; - $entry->{ERROR} = [ $file, $NR, __g( "unrecognised line" ), - "$_" ]; - }; - } - } - - $expect eq 'next heading or eof' - || do { - $entry->{ERROR} = [ $file, $NR, - __g( "found eof where expected %s", - $expect ) ]; - $self->_do_parse_error( @{$entry->{ERROR}} ); - }; - unless ($entry->is_empty) { - $entry->{'Closes'} = find_closes( $entry->{Changes} ); - push @{$self->{data}}, $entry; - } - - if ($self->{config}{infile}) { - close $fh or do { - $self->_do_fatal_error( __g( "can't close file %s: %s", - $file, $! )); - return undef; - }; - } - -# use Data::Dumper; -# print Dumper( $self ); - - return $self; -} - -=pod - -=head3 data - -C returns an array (if called in list context) or a reference -to an array of Parse::DebianChangelog::Entry objects which each -represent one entry of the changelog. - -This is currently merely a placeholder to enable users to get to the -raw data, expect changes to this API in the near future. - -This method supports the common output options described in -section L<"COMMON OUTPUT OPTIONS">. - -=cut - -sub data { - my ($self, $config) = @_; - - my $data = $self->{data}; - if ($config) { - $self->{config}{DATA} = $config if $config; - $data = $self->_data_range( $config ) or return undef; - } - return @$data if wantarray; - return $data; -} - -sub __sanity_check_range { - my ( $data, $from, $to, $since, $until, $start, $end ) = @_; - - if (($$start || $$end) && ($$from || $$since || $$to || $$until)) { - warn( __g( "you can't combine 'count' or 'offset' with any other range option" ) ."\n"); - $$from = $$since = $$to = $$until = ''; - } - if ($$from && $$since) { - warn( __g( "you can only specify one of 'from' and 'since'" ) ."\n"); - $$from = ''; - } - if ($$to && $$until) { - warn( __g( "you can only specify one of 'to' and 'until'" ) ."\n"); - $$to = ''; - } - if ($$since && ($data->[0]{Version} eq $$since)) { - warn( __g( "'since' option specifies most recent version" ) ."\n"); - $$since = ''; - } - if ($$until && ($data->[$#{$data}]{Version} eq $$until)) { - warn( __g( "'until' option specifies oldest version" ) ."\n"); - $$until = ''; - } - $$start = 0 if $$start < 0; - return if $$start > $#$data; - $$end = $#$data if $$end > $#$data; - return if $$end < 0; - $$end = $$start if $$end < $$start; - #TODO: compare versions - return 1; -} - -sub _data_range { - my ($self, $config) = @_; - - my $data = $self->data or return undef; - - return [ @$data ] if $config->{all}; - - my $since = $config->{since} || ''; - my $until = $config->{until} || ''; - my $from = $config->{from} || ''; - my $to = $config->{to} || ''; - my $count = $config->{count} || 0; - my $offset = $config->{offset} || 0; - - return if $offset and not $count; - if ($offset > 0) { - $offset -= ($count < 0); - } elsif ($offset < 0) { - $offset = $#$data + ($count > 0) + $offset; - } else { - $offset = $#$data if $count < 0; - } - my $start = my $end = $offset; - $start += $count+1 if $count < 0; - $end += $count-1 if $count > 0; - - return unless __sanity_check_range( $data, \$from, \$to, - \$since, \$until, - \$start, \$end ); - - - unless ($from or $to or $since or $until or $start or $end) { - return [ @$data ] if $config->{default_all} and not $count; - return [ $data->[0] ]; - } - - return [ @{$data}[$start .. $end] ] if $start or $end; - - my @result; - - my $include = 1; - $include = 0 if $to or $until; - foreach (@$data) { - my $v = $_->{Version}; - $include = 1 if $v eq $to; - last if $v eq $since; - - push @result, $_ if $include; - - $include = 1 if $v eq $until; - last if $v eq $from; - } - - return \@result; -} - -=pod - -=head3 dpkg - -(and B) - -C returns a hash (in list context) or a hash reference -(in scalar context) where the keys are field names and the values are -field values. The following fields are given: - -=over 4 - -=item Source - -package name (in the first entry) - -=item Version - -packages' version (from first entry) - -=item Distribution - -target distribution (from first entry) - -=item Urgency - -urgency (highest of all printed entries) - -=item Maintainer - -person that created the (first) entry - -=item Date - -date of the (first) entry - -=item Closes - -bugs closed by the entry/entries, sorted by bug number - -=item Changes - -content of the the entry/entries - -=back - -C returns a stringified version of this hash which should look -exactly like the output of L. The fields are -ordered like in the list above. - -Both methods only support the common output options described in -section L<"COMMON OUTPUT OPTIONS">. - -=head3 dpkg_str - -See L. - -=cut - -our ( %FIELDIMPS, %URGENCIES ); -BEGIN { - my $i=100; - grep($FIELDIMPS{$_}=$i--, - qw(Source Version Distribution Urgency Maintainer Date Closes - Changes)); - $i=1; - grep($URGENCIES{$_}=$i++, - qw(low medium high critical emergency)); -} - -sub dpkg { - my ($self, $config) = @_; - - $self->{config}{DPKG} = $config if $config; - - $config = $self->{config}{DPKG} || {}; - my $data = $self->_data_range( $config ) or return undef; - - my %f; - foreach my $field (qw( Urgency Source Version - Distribution Maintainer Date )) { - $f{$field} = $data->[0]{$field}; - } - - $f{Changes} = get_dpkg_changes( $data->[0] ); - $f{Closes} = [ @{$data->[0]{Closes}} ]; - - my $first = 1; my $urg_comment = ''; - foreach my $entry (@$data) { - $first = 0, next if $first; - - my $oldurg = $f{Urgency} || ''; - my $oldurgn = $URGENCIES{$f{Urgency}} || -1; - my $newurg = $entry->{Urgency_LC} || ''; - my $newurgn = $URGENCIES{$entry->{Urgency_LC}} || -1; - $f{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg; - $urg_comment .= $entry->{Urgency_Comment}; - - $f{Changes} .= "\n .".get_dpkg_changes( $entry ); - push @{$f{Closes}}, @{$entry->{Closes}}; - } - - $f{Closes} = join " ", sort { $a <=> $b } @{$f{Closes}}; - $f{Urgency} .= $urg_comment; - - return %f if wantarray; - return \%f; -} - -sub dpkg_str { - return data2rfc822( scalar dpkg(@_), \%FIELDIMPS ); -} - -=pod - -=head3 rfc822 - -(and B) - -C returns an array of hashes (in list context) or a reference -to this array (in scalar context) where each hash represents one entry -in the changelog. For the format of such a hash see the description -of the L<"dpkg"> method (while ignoring the remarks about which -values are taken from the first entry). - -C returns a stringified version of this hash which looks -similar to the output of dpkg-parsechangelog but instead of one -stanza the output contains one stanza for each entry. - -Both methods only support the common output options described in -section L<"COMMON OUTPUT OPTIONS">. - -=head3 rfc822_str - -See L. - -=cut - -sub rfc822 { - my ($self, $config) = @_; - - $self->{config}{RFC822} = $config if $config; - - $config = $self->{config}{RFC822} || {}; - my $data = $self->_data_range( $config ) or return undef; - my @out_data; - - foreach my $entry (@$data) { - my %f; - foreach my $field (qw( Urgency Source Version - Distribution Maintainer Date )) { - $f{$field} = $entry->{$field}; - } - - $f{Urgency} .= $entry->{Urgency_Comment}; - $f{Changes} = get_dpkg_changes( $entry ); - $f{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}}; - push @out_data, \%f; - } - - return @out_data if wantarray; - return \@out_data; -} - -sub rfc822_str { - return data2rfc822_mult( scalar rfc822(@_), \%FIELDIMPS ); -} - -sub __version2id { - my $version = shift; - $version =~ s/[^\w.:-]/_/go; - return "version$version"; -} - -=pod - -=head3 xml - -(and B) - -C converts the changelog to some free-form (i.e. there is neither -a DTD or a schema for it) XML. - -The method C is an alias for C. - -Both methods support the common output options described in -section L<"COMMON OUTPUT OPTIONS"> and additionally the following -configuration options (as usual to give -in a hash reference as parameter to the method call): - -=over 4 - -=item outfile - -directly write the output to the file specified - -=back - -=head3 xml_str - -See L. - -=cut - -sub xml { - my ($self, $config) = @_; - - $self->{config}{XML} = $config if $config; - $config = $self->{config}{XML} || {}; - $config->{default_all} = 1 unless exists $config->{all}; - my $data = $self->_data_range( $config ) or return undef; - my %out_data; - $out_data{Entry} = []; - - require XML::Simple; - import XML::Simple qw( :strict ); - - foreach my $entry (@$data) { - my %f; - foreach my $field (qw( Urgency Source Version - Distribution Closes )) { - $f{$field} = $entry->{$field}; - } - foreach my $field (qw( Maintainer Changes )) { - $f{$field} = [ $entry->{$field} ]; - } - - $f{Urgency} .= $entry->{Urgency_Comment}; - $f{Date} = { timestamp => $entry->{Timestamp}, - content => $entry->{Date} }; - push @{$out_data{Entry}}, \%f; - } - - my $xml_str; - my %xml_opts = ( SuppressEmpty => 1, KeyAttr => {}, - RootName => 'Changelog' ); - $xml_str = XMLout( \%out_data, %xml_opts ); - if ($config->{outfile}) { - open my $fh, '>', $config->{outfile} or return undef; - flock $fh, LOCK_EX or return undef; - - print $fh $xml_str; - - close $fh or return undef; - } - - return $xml_str; -} - -sub xml_str { - return xml(@_); -} - -=pod - -=head3 html - -(and B) - -C converts the changelog to a HTML file with some nice features -such as a quick-link bar with direct links to every entry. The HTML -is generated with the help of HTML::Template. If you want to change -the output you should use the default template provided with this module -as a base and read the documentation of HTML::Template to understand -how to edit it. - -The method C is an alias for C. - -Both methods support the common output options described in -section L<"COMMON OUTPUT OPTIONS"> and additionally the following -configuration options (as usual to give -in a hash reference as parameter to the method call): - -=over 4 - -=item outfile - -directly write the output to the file specified - -=item template - -template file to use, defaults to tmpl/default.tmpl, so you -most likely want to override that. -NOTE: The plan is to provide a configuration file for the module -later to be able to use sane defaults here. - -=item style - -path to the CSS stylesheet to use (a default might be specified -in the template and will be honoured, see the default template -for an example) - -=item print_style - -path to the CSS stylesheet to use for printing (see the notes for -C