]> git.deb.at Git - deb/packages.git/blob - lib/Parse/DebianChangelog.pm
Merge commit 'origin/master' into debian-master
[deb/packages.git] / lib / Parse / DebianChangelog.pm
1 #
2 # Parse::DebianChangelog
3 #
4 # Copyright 1996 Ian Jackson
5 # Copyright 2005 Frank Lichtenheld <frank@lichtenheld.de>
6 #
7 #    This program is free software; you can redistribute it and/or modify
8 #    it under the terms of the GNU General Public License as published by
9 #    the Free Software Foundation; either version 2 of the License, or
10 #    (at your option) any later version.
11 #
12 #    This program is distributed in the hope that it will be useful,
13 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
14 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 #    GNU General Public License for more details.
16 #
17 #    You should have received a copy of the GNU General Public License
18 #    along with this program; if not, write to the Free Software
19 #    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
20 #
21
22 =head1 NAME
23
24 Parse::DebianChangelog - parse Debian changelogs and output them in other formats
25
26 =head1 SYNOPSIS
27
28     use Parse::DebianChangelog;
29
30     my $chglog = Parse::DebianChangelog->init( { infile => 'debian/changelog',
31                                                  HTML => { outfile => 'changelog.html' } );
32     $chglog->html;
33
34     # the following is semantically equivalent
35     my $chglog = Parse::DebianChangelog->init();
36     $chglog->parse( { infile => 'debian/changelog' } );
37     $chglog->html( { outfile => 'changelog.html' } );
38
39     my $changes = $chglog->dpkg_str( { since => '1.0-1' } );
40     print $changes;
41
42 =head1 DESCRIPTION
43
44 Parse::DebianChangelog parses Debian changelogs as described in the Debian
45 policy (version 3.6.2.1 at the time of this writing). See section
46 L<"SEE ALSO"> for locations where to find this definition.
47
48 The parser tries to ignore most cruft like # or /* */ style comments,
49 CVS comments, vim variables, emacs local variables and stuff from
50 older changelogs with other formats at the end of the file.
51 NOTE: most of these are ignored silently currently, there is no
52 parser error issued for them. This should become configurable in the
53 future.
54
55 Beside giving access to the details of the parsed file via the
56 L<"data"> method, Parse::DebianChangelog also supports converting these
57 changelogs to various other formats. These are currently:
58
59 =over 4
60
61 =item dpkg
62
63 Format as known from L<dpkg-parsechangelog(1)>. All requested entries
64 (see L<"METHODS"> for an explanation what this means) are returned in
65 the usual Debian control format, merged in one stanza, ready to be used
66 in a F<.changes> file.
67
68 =item rfc822
69
70 Similar to the C<dpkg> format, but the requested entries are returned
71 as one stanza each, i.e. they are not merged. This is probably the format
72 to use if you want a machine-usable representation of the changelog.
73
74 =item xml
75
76 Just a simple XML dump of the changelog data. Without any schema or
77 DTD currently, just some made up XML. The actual format might still
78 change. Comments and Improvements welcome.
79
80 =item html
81
82 The changelog is converted to a somewhat nice looking HTML file with
83 some nice features as a quick-link bar with direct links to every entry.
84 NOTE: This is not very configurable yet and was specifically designed
85 to be used on L<http://packages.debian.org/>. This is planned to be
86 changed until version 1.0.
87
88 =back
89
90 =head2 METHODS
91
92 =cut
93
94 package Parse::DebianChangelog;
95
96 use strict;
97 use warnings;
98
99 use Fcntl qw( :flock );
100 use English;
101 use Locale::gettext;
102 use Date::Parse;
103 use Parse::DebianChangelog::Util qw( :all );
104 use Parse::DebianChangelog::Entry;
105
106 our $VERSION = '1.1.1';
107
108 =pod
109
110 =head3 init
111
112 Creates a new object instance. Takes a reference to a hash as
113 optional argument, which is interpreted as configuration options.
114 There are currently no supported general configuration options, but
115 see the other methods for more specific configuration options which
116 can also specified to C<init>.
117
118 If C<infile> or C<instring> are specified (see L<parse>), C<parse()>
119 is called from C<init>. If a fatal error is encountered during parsing
120 (e.g. the file can't be opened), C<init> will not return a
121 valid object but C<undef>!
122
123 =cut
124
125 sub init {
126     my $classname = shift;
127     my $config = shift || {};
128     my $self = {};
129     bless( $self, $classname );
130
131     $config->{verbose} = 1 if $config->{debug};
132     $self->{config} = $config;
133
134     $self->init_filters;
135     $self->reset_parse_errors;
136
137     if ($self->{config}{infile} || $self->{config}{instring}) {
138         defined($self->parse) or return undef;
139     }
140
141     return $self;
142 }
143
144 =pod
145
146 =head3 reset_parse_errors
147
148 Can be used to delete all information about errors ocurred during
149 previous L<parse> runs. Note that C<parse()> also calls this method.
150
151 =cut
152
153 sub reset_parse_errors {
154     my ($self) = @_;
155
156     $self->{errors}{parser} = [];
157 }
158
159 sub _do_parse_error {
160     my ($self, $file, $line_nr, $error, $line) = @_;
161     shift;
162
163     push @{$self->{errors}{parser}}, [ @_ ];
164
165     $file = substr $file, 0, 20;
166     unless ($self->{config}{quiet}) {
167         if ($line) {
168             warn "WARN: $file(l$NR): $error\nLINE: $line\n";
169         } else {
170             warn "WARN: $file(l$NR): $error\n";
171         }
172     }
173 }
174
175 =pod
176
177 =head3 get_parse_errors
178
179 Returns all error messages from the last L<parse> run.
180 If called in scalar context returns a human readable
181 string representation. If called in list context returns
182 an array of arrays. Each of these arrays contains
183
184 =over 4
185
186 =item 1.
187
188 the filename of the parsed file or C<String> if a string was
189 parsed directly
190
191 =item 2.
192
193 the line number where the error occurred
194
195 =item 3.
196
197 an error description
198
199 =item 4.
200
201 the original line
202
203 =back
204
205 NOTE: This format isn't stable yet and may change in later versions
206 of this module.
207
208 =cut
209
210 sub get_parse_errors {
211     my ($self) = @_;
212
213     if (wantarray) {
214         return @{$self->{errors}{parser}};
215     } else {
216         my $res = "";
217         foreach my $e (@{$self->{errors}{parser}}) {
218             if ($e->[3]) {
219                 $res .= __g( "WARN: %s(l%s): %s\nLINE: %s\n", @$e );
220             } else {
221                 $res .= __g( "WARN: %s(l%s): %s\n", @$e );
222             }
223         }
224         return $res;
225     }
226 }
227
228 sub _do_fatal_error {
229     my ($self, @msg) = @_;
230
231     $self->{errors}{fatal} = "@msg";
232     warn __g( "FATAL: %s", "@msg")."\n" unless $self->{config}{quiet};
233 }
234
235 =pod
236
237 =head3 get_error
238
239 Get the last non-parser error (e.g. the file to parse couldn't be opened).
240
241 =cut
242
243 sub get_error {
244     my ($self) = @_;
245
246     return $self->{errors}{fatal};
247 }
248
249 =pod
250
251 =head3 parse
252
253 Parses either the file named in configuration item C<infile> or the string
254 saved in configuration item C<instring>.
255 Accepts a hash ref as optional argument which can contain configuration
256 items.
257
258 Returns C<undef> in case of error (e.g. "file not found", B<not> parse
259 errors) and the object if successful. If C<undef> was returned, you
260 can get the reason for the failure by calling the L<get_error> method.
261
262 =cut
263
264 sub __g {
265     my $string = shift;
266     return sprintf( dgettext( 'Parse-DebianChangelog', $string ), @_ );
267 }
268
269 sub parse {
270     my ($self, $config) = @_;
271
272     foreach my $c (keys %$config) {
273         $self->{config}{$c} = $config->{$c};
274     }
275
276     my ($fh, $file);
277     if ($file = $self->{config}{infile}) {
278         open $fh, '<', $file or do {
279             $self->_do_fatal_error( __g( "can't open file %s: %s",
280                                          $file, $! ));
281             return undef;
282         };
283         flock $fh, LOCK_SH or do {
284             $self->_do_fatal_error( __g( "can't lock file %s: %s",
285                                          $file, $! ));
286             return undef;
287         };
288     } elsif (my $string = $self->{config}{instring}) {
289         eval { require IO::String };
290         if ($@) {
291             $self->_do_fatal_error( __g( "can't load IO::String: %s",
292                                          $@ ));
293             return undef;
294         }
295         $fh = IO::String->new( $string );
296         $file = 'String';
297     } else {
298         $self->_do_fatal_error( __g( 'no changelog file specified' ));
299         return undef;
300     }
301
302     $self->reset_parse_errors;
303
304     $self->{data} = [];
305
306 # based on /usr/lib/dpkg/parsechangelog/debian
307     my $expect='first heading';
308     my $entry = Parse::DebianChangelog::Entry->init();
309     my $blanklines = 0;
310     my $unknowncounter = 1; # to make version unique, e.g. for using as id
311
312     while (<$fh>) {
313         s/\s*\n$//;
314 #       printf(STDERR "%-39.39s %-39.39s\n",$expect,$_);
315         if (m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)((\s+[-0-9a-z]+)+)\;/i) {
316             unless ($expect eq 'first heading'
317                     || $expect eq 'next heading or eof') {
318                 $entry->{ERROR} = [ $file, $NR,
319                                   __g( "found start of entry where expected %s",
320                                        $expect ), "$_" ];
321                 $self->_do_parse_error(@{$entry->{ERROR}});
322             }
323             unless ($entry->is_empty) {
324                 $entry->{'Closes'} = find_closes( $entry->{Changes} );
325 #                   print STDERR, Dumper($entry);
326                 push @{$self->{data}}, $entry;
327                 $entry = Parse::DebianChangelog::Entry->init();
328             }
329             {
330                 $entry->{'Source'} = "$1";
331                 $entry->{'Version'} = "$2";
332                 $entry->{'Header'} = "$_";
333                 ($entry->{'Distribution'} = "$3") =~ s/^\s+//;
334                 $entry->{'Changes'} = $entry->{'Urgency_Comment'} = '';
335                 $entry->{'Urgency'} = $entry->{'Urgency_LC'} = 'unknown';
336             }
337             (my $rhs = $POSTMATCH) =~ s/^\s+//;
338             my %kvdone;
339 #           print STDERR "RHS: $rhs\n";
340             for my $kv (split(/\s*,\s*/,$rhs)) {
341                 $kv =~ m/^([-0-9a-z]+)\=\s*(.*\S)$/i ||
342                     $self->_do_parse_error($file, $NR,
343                                            __g( "bad key-value after \`;': \`%s'", $kv ));
344                 my $k = ucfirst $1;
345                 my $v = $2;
346                 $kvdone{$k}++ && $self->_do_parse_error($file, $NR,
347                                                        __g( "repeated key-value %s", $k ));
348                 if ($k eq 'Urgency') {
349                     $v =~ m/^([-0-9a-z]+)((\s+.*)?)$/i ||
350                         $self->_do_parse_error($file, $NR,
351                                               __g( "badly formatted urgency value" ),
352                                               $v);
353                     $entry->{'Urgency'} = "$1";
354                     $entry->{'Urgency_LC'} = lc("$1");
355                     $entry->{'Urgency_Comment'} = "$2";
356                 } elsif ($k =~ m/^X[BCS]+-/i) {
357                     # Extensions - XB for putting in Binary,
358                     # XC for putting in Control, XS for putting in Source
359                     $entry->{$k}= $v;
360                 } else {
361                     $self->_do_parse_error($file, $NR,
362                                           __g( "unknown key-value key %s - copying to XS-%s", $k, $k ));
363                     $entry->{ExtraFields}{"XS-$k"} = $v;
364                 }
365             }
366             $expect= 'start of change data';
367             $blanklines = 0;
368         } elsif (m/^(;;\s*)?Local variables:/io) {
369             last; # skip Emacs variables at end of file
370         } elsif (m/^vim:/io) {
371             last; # skip vim variables at end of file
372         } elsif (m/^\$\w+:.*\$/o) {
373             next; # skip stuff that look like a CVS keyword
374         } elsif (m/^\# /o) {
375             next; # skip comments, even that's not supported
376         } elsif (m,^/\*.*\*/,o) {
377             next; # more comments
378         } 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
379                  || m/^(\w+\s+\w+\s+\d{1,2},?\s*\d{4})\s+(.*)\s+(<|\()(.*)(\)|>)/o
380                  || m/^(\w[-+0-9a-z.]*) \(([^\(\) \t]+)\)\;?/io
381                  || m/^([\w.+-]+)(-| )(\S+) Debian (\S+)/io
382                  || m/^Changes from version (.*) to (.*):/io
383                  || m/^Changes for [\w.+-]+-[\w.+-]+:?$/io
384                  || m/^Old Changelog:$/io
385                  || m/^(?:\d+:)?\w[\w.+~-]*:?$/o) {
386             # save entries on old changelog format verbatim
387             # we assume the rest of the file will be in old format once we
388             # hit it for the first time
389             $self->{oldformat} = "$_\n";
390             $self->{oldformat} .= join "", <$fh>;
391         } elsif (m/^\S/) {
392             $self->_do_parse_error($file, $NR,
393                                   __g( "badly formatted heading line" ), "$_");
394         } 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) {
395             $expect eq 'more change data or trailer' ||
396                 $self->_do_parse_error($file, $NR,
397                                        __g( "found trailer where expected %s",
398                                             $expect ), "$_");
399             if ($3 ne '  ') {
400                 $self->_do_parse_error($file, $NR,
401                                        __g( "badly formatted trailer line" ),
402                                        "$_");
403             }
404             $entry->{'Trailer'} = $_;
405             $entry->{'Maintainer'} = "$1 <$2>" unless $entry->{'Maintainer'};
406             unless($entry->{'Date'} && defined $entry->{'Timestamp'}) {
407                 $entry->{'Date'} = "$4";
408                 $entry->{'Timestamp'} = str2time($4);
409                 unless (defined $entry->{'Timestamp'}) {
410                     $self->_do_parse_error( $file, $NR,
411                                             __g( "couldn't parse date %s",
412                                                  "$4" ) );
413                 }
414             }
415             $expect = 'next heading or eof';
416         } elsif (m/^ \-\-/) {
417             $entry->{ERROR} = [ $file, $NR,
418                               __g( "badly formatted trailer line" ), "$_" ];
419             $self->_do_parse_error(@{$entry->{ERROR}});
420 #           $expect = 'next heading or eof'
421 #               if $expect eq 'more change data or trailer';
422         } elsif (m/^\s{2,}(\S)/) {
423             $expect eq 'start of change data'
424                 || $expect eq 'more change data or trailer'
425                 || do {
426                     $self->_do_parse_error($file, $NR,
427                             __g( "found change data where expected %s",
428                                  $expect ), "$_");
429                     if (($expect eq 'next heading or eof')
430                         && !$entry->is_empty) {
431                         # lets assume we have missed the actual header line
432                         $entry->{'Closes'} = find_closes( $entry->{Changes} );
433 #                   print STDERR, Dumper($entry);
434                         push @{$self->{data}}, $entry;
435                         $entry = Parse::DebianChangelog::Entry->init();
436                         $entry->{Source} =
437                             $entry->{Distribution} = $entry->{Urgency} =
438                             $entry->{Urgency_LC} = 'unknown';
439                         $entry->{Version} = 'unknown'.($unknowncounter++);
440                         $entry->{Urgency_Comment} = '';
441                         $entry->{ERROR} = [ $file, $NR,
442                                             __g( "found change data where expected %s",
443                                                  $expect ), "$_" ];
444                     }
445                 };
446             $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n";
447             if (!$entry->{'Items'} || ($1 eq '*')) {
448                 $entry->{'Items'} ||= [];
449                 push @{$entry->{'Items'}}, "$_\n";
450             } else {
451                 $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n";
452             }
453             $blanklines = 0;
454             $expect = 'more change data or trailer';
455         } elsif (!m/\S/) {
456             next if $expect eq 'start of change data'
457                 || $expect eq 'next heading or eof';
458             $expect eq 'more change data or trailer'
459                 || $self->_do_parse_error($file, $NR,
460                                          __g( "found blank line where expected %s",
461                                               $expect ));
462             $blanklines++;
463         } else {
464             $self->_do_parse_error($file, $NR, __g( "unrecognised line" ),
465                                    "$_");
466             ($expect eq 'start of change data'
467                 || $expect eq 'more change data or trailer')
468                 && do {
469                     # lets assume change data if we expected it
470                     $entry->{'Changes'} .= (" \n" x $blanklines)." $_\n";
471                     if (!$entry->{'Items'}) {
472                         $entry->{'Items'} ||= [];
473                         push @{$entry->{'Items'}}, "$_\n";
474                     } else {
475                         $entry->{'Items'}[-1] .= (" \n" x $blanklines)." $_\n";
476                     }
477                     $blanklines = 0;
478                     $expect = 'more change data or trailer';
479                     $entry->{ERROR} = [ $file, $NR, __g( "unrecognised line" ),
480                                         "$_" ];
481                 };
482         }
483     }
484
485     $expect eq 'next heading or eof'
486         || do {
487             $entry->{ERROR} = [ $file, $NR,
488                                 __g( "found eof where expected %s",
489                                      $expect ) ];
490             $self->_do_parse_error( @{$entry->{ERROR}} );
491         };
492     unless ($entry->is_empty) {
493         $entry->{'Closes'} = find_closes( $entry->{Changes} );
494         push @{$self->{data}}, $entry;
495     }
496
497     if ($self->{config}{infile}) {
498         close $fh or do {
499             $self->_do_fatal_error( __g( "can't close file %s: %s",
500                                          $file, $! ));
501             return undef;
502         };
503     }
504
505 #    use Data::Dumper;
506 #    print Dumper( $self );
507
508     return $self;
509 }
510
511 =pod
512
513 =head3 data
514
515 C<data> returns an array (if called in list context) or a reference
516 to an array of Parse::DebianChangelog::Entry objects which each
517 represent one entry of the changelog.
518
519 This is currently merely a placeholder to enable users to get to the
520 raw data, expect changes to this API in the near future.
521
522 This method supports the common output options described in
523 section L<"COMMON OUTPUT OPTIONS">.
524
525 =cut
526
527 sub data {
528     my ($self, $config) = @_;
529
530     my $data = $self->{data};
531     if ($config) {
532         $self->{config}{DATA} = $config if $config;
533         $data = $self->_data_range( $config ) or return undef;
534     }
535     return @$data if wantarray;
536     return $data;
537 }
538
539 sub __sanity_check_range {
540     my ( $data, $from, $to, $since, $until, $start, $end ) = @_;
541
542     if (($$start || $$end) && ($$from || $$since || $$to || $$until)) {
543         warn( __g( "you can't combine 'count' or 'offset' with any other range option" ) ."\n");
544         $$from = $$since = $$to = $$until = '';
545     }
546     if ($$from && $$since) {
547         warn( __g( "you can only specify one of 'from' and 'since'" ) ."\n");
548         $$from = '';
549     }
550     if ($$to && $$until) {
551         warn( __g( "you can only specify one of 'to' and 'until'" ) ."\n");
552         $$to = '';
553     }
554     if ($$since && ($data->[0]{Version} eq $$since)) {
555         warn( __g( "'since' option specifies most recent version" ) ."\n");
556         $$since = '';
557     }
558     if ($$until && ($data->[$#{$data}]{Version} eq $$until)) {
559         warn( __g( "'until' option specifies oldest version" ) ."\n");
560         $$until = '';
561     }
562     $$start = 0 if $$start < 0;
563     return if $$start > $#$data;
564     $$end = $#$data if $$end > $#$data;
565     return if $$end < 0;
566     $$end = $$start if $$end < $$start;
567     #TODO: compare versions
568     return 1;
569 }
570
571 sub _data_range {
572     my ($self, $config) = @_;
573
574     my $data = $self->data or return undef;
575
576     return [ @$data ] if $config->{all};
577
578     my $since = $config->{since} || '';
579     my $until = $config->{until} || '';
580     my $from = $config->{from} || '';
581     my $to = $config->{to} || '';
582     my $count = $config->{count} || 0;
583     my $offset = $config->{offset} || 0;
584
585     return if $offset and not $count;
586     if ($offset > 0) {
587         $offset -= ($count < 0);
588     } elsif ($offset < 0) {
589         $offset = $#$data + ($count > 0) + $offset;
590     } else {
591         $offset = $#$data if $count < 0;
592     }
593     my $start = my $end = $offset;
594     $start += $count+1 if $count < 0;
595     $end += $count-1 if $count > 0;
596
597     return unless __sanity_check_range( $data, \$from, \$to,
598                                         \$since, \$until,
599                                         \$start, \$end );
600
601
602     unless ($from or $to or $since or $until or $start or $end) {
603         return [ @$data ] if $config->{default_all} and not $count;
604         return [ $data->[0] ];
605     }
606
607     return [ @{$data}[$start .. $end] ] if $start or $end;
608
609     my @result;
610
611     my $include = 1;
612     $include = 0 if $to or $until;
613     foreach (@$data) {
614         my $v = $_->{Version};
615         $include = 1 if $v eq $to;
616         last if $v eq $since;
617
618         push @result, $_ if $include;
619
620         $include = 1 if $v eq $until;
621         last if $v eq $from;
622     }
623
624     return \@result;
625 }
626
627 =pod
628
629 =head3 dpkg
630
631 (and B<dpkg_str>)
632
633 C<dpkg> returns a hash (in list context) or a hash reference
634 (in scalar context) where the keys are field names and the values are
635 field values. The following fields are given:
636
637 =over 4
638
639 =item Source
640
641 package name (in the first entry)
642
643 =item Version
644
645 packages' version (from first entry)
646
647 =item Distribution
648
649 target distribution (from first entry)
650
651 =item Urgency
652
653 urgency (highest of all printed entries)
654
655 =item Maintainer
656
657 person that created the (first) entry
658
659 =item Date
660
661 date of the (first) entry
662
663 =item Closes
664
665 bugs closed by the entry/entries, sorted by bug number
666
667 =item Changes
668
669 content of the the entry/entries
670
671 =back
672
673 C<dpkg_str> returns a stringified version of this hash which should look
674 exactly like the output of L<dpkg-parsechangelog(1)>. The fields are
675 ordered like in the list above.
676
677 Both methods only support the common output options described in
678 section L<"COMMON OUTPUT OPTIONS">.
679
680 =head3 dpkg_str
681
682 See L<dpkg>.
683
684 =cut
685
686 our ( %FIELDIMPS, %URGENCIES );
687 BEGIN {
688     my $i=100;
689     grep($FIELDIMPS{$_}=$i--,
690          qw(Source Version Distribution Urgency Maintainer Date Closes
691             Changes));
692     $i=1;
693     grep($URGENCIES{$_}=$i++,
694          qw(low medium high critical emergency));
695 }
696
697 sub dpkg {
698     my ($self, $config) = @_;
699
700     $self->{config}{DPKG} = $config if $config;
701
702     $config = $self->{config}{DPKG} || {};
703     my $data = $self->_data_range( $config ) or return undef;
704
705     my %f;
706     foreach my $field (qw( Urgency Source Version
707                            Distribution Maintainer Date )) {
708         $f{$field} = $data->[0]{$field};
709     }
710
711     $f{Changes} = get_dpkg_changes( $data->[0] );
712     $f{Closes} = [ @{$data->[0]{Closes}} ];
713
714     my $first = 1; my $urg_comment = '';
715     foreach my $entry (@$data) {
716         $first = 0, next if $first;
717
718         my $oldurg = $f{Urgency} || '';
719         my $oldurgn = $URGENCIES{$f{Urgency}} || -1;
720         my $newurg = $entry->{Urgency_LC} || '';
721         my $newurgn = $URGENCIES{$entry->{Urgency_LC}} || -1;
722         $f{Urgency} = ($newurgn > $oldurgn) ? $newurg : $oldurg;
723         $urg_comment .= $entry->{Urgency_Comment};
724
725         $f{Changes} .= "\n .".get_dpkg_changes( $entry );
726         push @{$f{Closes}}, @{$entry->{Closes}};
727     }
728
729     $f{Closes} = join " ", sort { $a <=> $b } @{$f{Closes}};
730     $f{Urgency} .= $urg_comment;
731
732     return %f if wantarray;
733     return \%f;
734 }
735
736 sub dpkg_str {
737     return data2rfc822( scalar dpkg(@_), \%FIELDIMPS );
738 }
739
740 =pod
741
742 =head3 rfc822
743
744 (and B<rfc822_str>)
745
746 C<rfc822> returns an array of hashes (in list context) or a reference
747 to this array (in scalar context) where each hash represents one entry
748 in the changelog. For the format of such a hash see the description
749 of the L<"dpkg"> method (while ignoring the remarks about which
750 values are taken from the first entry).
751
752 C<rfc822_str> returns a stringified version of this hash which looks
753 similar to the output of dpkg-parsechangelog but instead of one
754 stanza the output contains one stanza for each entry.
755
756 Both methods only support the common output options described in
757 section L<"COMMON OUTPUT OPTIONS">.
758
759 =head3 rfc822_str
760
761 See L<rfc822>.
762
763 =cut
764
765 sub rfc822 {
766     my ($self, $config) = @_;
767
768     $self->{config}{RFC822} = $config if $config;
769
770     $config = $self->{config}{RFC822} || {};
771     my $data = $self->_data_range( $config ) or return undef;
772     my @out_data;
773
774     foreach my $entry (@$data) {
775         my %f;
776         foreach my $field (qw( Urgency Source Version
777                            Distribution Maintainer Date )) {
778             $f{$field} = $entry->{$field};
779         }
780
781         $f{Urgency} .= $entry->{Urgency_Comment};
782         $f{Changes} = get_dpkg_changes( $entry );
783         $f{Closes} = join " ", sort { $a <=> $b } @{$entry->{Closes}};
784         push @out_data, \%f;
785     }
786
787     return @out_data if wantarray;
788     return \@out_data;
789 }
790
791 sub rfc822_str {
792     return data2rfc822_mult( scalar rfc822(@_), \%FIELDIMPS );
793 }
794
795 sub __version2id {
796     my $version = shift;
797     $version =~ s/[^\w.:-]/_/go;
798     return "version$version";
799 }
800
801 =pod
802
803 =head3 xml
804
805 (and B<xml_str>)
806
807 C<xml> converts the changelog to some free-form (i.e. there is neither
808 a DTD or a schema for it) XML.
809
810 The method C<xml_str> is an alias for C<xml>.
811
812 Both methods support the common output options described in
813 section L<"COMMON OUTPUT OPTIONS"> and additionally the following
814 configuration options (as usual to give
815 in a hash reference as parameter to the method call):
816
817 =over 4
818
819 =item outfile
820
821 directly write the output to the file specified
822
823 =back
824
825 =head3 xml_str
826
827 See L<xml>.
828
829 =cut
830
831 sub xml {
832     my ($self, $config) = @_;
833
834     $self->{config}{XML} = $config if $config;
835     $config = $self->{config}{XML} || {};
836     $config->{default_all} = 1 unless exists $config->{all};
837     my $data = $self->_data_range( $config ) or return undef;
838     my %out_data;
839     $out_data{Entry} = [];
840
841     require XML::Simple;
842     import XML::Simple qw( :strict );
843
844     foreach my $entry (@$data) {
845         my %f;
846         foreach my $field (qw( Urgency Source Version
847                                Distribution Closes )) {
848             $f{$field} = $entry->{$field};
849         }
850         foreach my $field (qw( Maintainer Changes )) {
851             $f{$field} = [ $entry->{$field} ];
852         }
853
854         $f{Urgency} .= $entry->{Urgency_Comment};
855         $f{Date} = { timestamp => $entry->{Timestamp},
856                      content => $entry->{Date} };
857         push @{$out_data{Entry}}, \%f;
858     }
859
860     my $xml_str;
861     my %xml_opts = ( SuppressEmpty => 1, KeyAttr => {},
862                      RootName => 'Changelog' );
863     $xml_str = XMLout( \%out_data, %xml_opts );
864     if ($config->{outfile}) {
865         open my $fh, '>', $config->{outfile} or return undef;
866         flock $fh, LOCK_EX or return undef;
867
868         print $fh $xml_str;
869
870         close $fh or return undef;
871     }
872
873     return $xml_str;
874 }
875
876 sub xml_str {
877     return xml(@_);
878 }
879
880 =pod
881
882 =head3 html
883
884 (and B<html_str>)
885
886 C<html> converts the changelog to a HTML file with some nice features
887 such as a quick-link bar with direct links to every entry. The HTML
888 is generated with the help of HTML::Template. If you want to change
889 the output you should use the default template provided with this module
890 as a base and read the documentation of HTML::Template to understand
891 how to edit it.
892
893 The method C<html_str> is an alias for C<html>.
894
895 Both methods support the common output options described in
896 section L<"COMMON OUTPUT OPTIONS"> and additionally the following
897 configuration options (as usual to give
898 in a hash reference as parameter to the method call):
899
900 =over 4
901
902 =item outfile
903
904 directly write the output to the file specified
905
906 =item template
907
908 template file to use, defaults to tmpl/default.tmpl, so you
909 most likely want to override that.
910 NOTE: The plan is to provide a configuration file for the module
911 later to be able to use sane defaults here.
912
913 =item style
914
915 path to the CSS stylesheet to use (a default might be specified
916 in the template and will be honoured, see the default template
917 for an example)
918
919 =item print_style
920
921 path to the CSS stylesheet to use for printing (see the notes for
922 C<style> about default values)
923
924 =back
925
926 =head3 html_str
927
928 See L<html>.
929
930 =cut
931
932 sub html {
933     my ($self, $config) = @_;
934
935     $self->{config}{HTML} = $config if $config;
936     $config = $self->{config}{HTML} || {};
937     $config->{default_all} = 1 unless exists $config->{all};
938     my $data = $self->_data_range( $config ) or return undef;
939
940     require CGI;
941     import CGI qw( -no_xhtml -no_debug );
942     require HTML::Template;
943
944     my $template = HTML::Template->new(filename => $config->{template}
945                                        || 'tmpl/default.tmpl',
946                                        die_on_bad_params => 0);
947     $template->param( MODULE_NAME => ref($self),
948                       MODULE_VERSION => $VERSION,
949                       GENERATED_DATE => gmtime()." UTC",
950                       SOURCE_NEWEST => $data->[0]{Source},
951                       VERSION_NEWEST => $data->[0]{Version},
952                       MAINTAINER_NEWEST => $data->[0]{Maintainer},
953                       );
954
955     $template->param( CSS_FILE_SCREEN => $config->{style} )
956         if $config->{style};
957     $template->param( CSS_FILE_PRINT => $config->{print_style} )
958         if $config->{print_style};
959
960     my $cgi = new CGI;
961     $cgi->autoEscape(0);
962
963     my %navigation;
964     my $last_year;
965     foreach my $entry (@$data) {
966         my $year = $last_year; # try to deal gracefully with unparsable dates
967         if (defined $entry->{Timestamp}) {
968             $year = (gmtime($entry->{Timestamp}))[5] + 1900;
969             $last_year = $year;
970         }
971
972         $year ||= (($entry->{Date} =~ /\s(\d{4})\s/) ? $1 : (gmtime)[5] + 1900);
973
974         $navigation{$year}{NAV_VERSIONS} ||= [];
975         $navigation{$year}{NAV_YEAR} ||= $year;
976
977         $entry->{Maintainer} ||= 'unknown';
978         $entry->{Date} ||= 'unknown';
979         push @{$navigation{$year}{NAV_VERSIONS}},
980                { NAV_VERSION_ID => __version2id($entry->{Version}),
981                  NAV_VERSION => $entry->{Version},
982                  NAV_MAINTAINER => $entry->{Maintainer},
983                  NAV_DATE => $entry->{Date} };
984     }
985     my @nav_years;
986     foreach my $y (reverse sort keys %navigation) {
987         push @nav_years, $navigation{$y};
988     }
989     $template->param( OLDFORMAT => (($self->{oldformat}||'') ne ''),
990                       NAV_YEARS => \@nav_years );
991
992
993     my %years;
994     $last_year = undef;
995     foreach my $entry (@$data) {
996         my $year = $last_year; # try to deal gracefully with unparsable dates
997         if (defined $entry->{Timestamp}) {
998             $year = (gmtime($entry->{Timestamp}))[5] + 1900;
999         }
1000         $year ||= (($entry->{Date} =~ /\s(\d{4})\s/) ? $1 : (gmtime)[5] + 1900);
1001
1002         if (!$last_year || ($year < $last_year)) {
1003             $last_year = $year;
1004         }
1005
1006         $years{$last_year}{CONTENT_VERSIONS} ||= [];
1007         $years{$last_year}{CONTENT_YEAR} ||= $last_year;
1008
1009         my $text = $self->apply_filters( 'html::changes',
1010                                          $entry->{Changes}, $cgi );
1011
1012         (my $maint_name = $entry->{Maintainer} ) =~ s|<([a-zA-Z0-9_\+\-\.]+\@([a-zA-Z0-9][\w\.+\-]+\.[a-zA-Z]{2,}))>||o;
1013         my $maint_mail = $1;
1014
1015         my $parse_error;
1016         $parse_error = $cgi->p( { -class=>'parse_error' },
1017                                 "(There has been a parse error in the entry above, if some values don't make sense please check the original changelog)" )
1018             if $entry->{ERROR};
1019
1020         push @{$years{$last_year}{CONTENT_VERSIONS}}, {
1021             CONTENT_VERSION => $entry->{Version},
1022             CONTENT_VERSION_ID => __version2id($entry->{Version}),
1023             CONTENT_URGENCY => $entry->{Urgency}.$entry->{Urgency_Comment},
1024             CONTENT_URGENCY_NORM => $entry->{Urgency_LC},
1025             CONTENT_DISTRIBUTION => $entry->{Distribution},
1026             CONTENT_DISTRIBUTION_NORM => lc($entry->{Distribution}),
1027             CONTENT_SOURCE => $entry->{Source},
1028             CONTENT_CHANGES => $text,
1029             CONTENT_CHANGES_UNFILTERED => $entry->{Changes},
1030             CONTENT_DATE => $entry->{Date},
1031             CONTENT_MAINTAINER_NAME => $maint_name,
1032             CONTENT_MAINTAINER_EMAIL => $maint_mail,
1033             CONTENT_PARSE_ERROR => $parse_error,
1034         };
1035     }
1036     my @content_years;
1037     foreach my $y (reverse sort keys %years) {
1038         push @content_years, $years{$y};
1039     }
1040     $template->param( OLDFORMAT_CHANGES => $self->{oldformat},
1041                       CONTENT_YEARS => \@content_years );
1042
1043     my $html_str = $template->output;
1044
1045     if ($config->{outfile}) {
1046         open my $fh, '>', $config->{outfile} or return undef;
1047         flock $fh, LOCK_EX or return undef;
1048
1049         print $fh $html_str;
1050
1051         close $fh or return undef;
1052     }
1053
1054     return $html_str;
1055 }
1056
1057 sub html_str {
1058     return html(@_);
1059 }
1060
1061
1062 =pod
1063
1064 =head3 init_filters
1065
1066 not yet documented
1067
1068 =cut
1069
1070 sub init_filters {
1071     my ($self) = @_;
1072
1073     require Parse::DebianChangelog::ChangesFilters;
1074
1075     $self->{filters} = {};
1076
1077     $self->{filters}{'html::changes'} =
1078         [ @Parse::DebianChangelog::ChangesFilters::all_filters ];
1079 }
1080
1081 =pod
1082
1083 =head3 apply_filters
1084
1085 not yet documented
1086
1087 =cut
1088
1089 sub apply_filters {
1090     my ($self, $filter_class, $text, $data) = @_;
1091
1092     foreach my $f (@{$self->{filters}{$filter_class}}) {
1093         $text = &$f( $text, $data );
1094     }
1095     return $text;
1096 }
1097
1098 =pod
1099
1100 =head3 add_filter, delete_filter, replace_filter
1101
1102 not yet documented
1103
1104 =cut
1105
1106 sub add_filter {
1107     my ($self, $filter_class, $filter, $pos) = @_;
1108
1109     $self->{filters}{$filter_class} ||= [];
1110     unless ($pos) {
1111         push @{$self->{filters}{$filter_class}}, $filter;
1112     } elsif ($pos == 1) {
1113         unshift @{$self->{filters}{$filter_class}}, $filter;
1114     } elsif ($pos > 1) {
1115         my $length = @{$self->{filters}{$filter_class}};
1116         $self->{filters}{$filter_class} =
1117             [ @{$self->{filters}{$filter_class}[0 .. ($pos-2)]}, $filter,
1118               @{$self->{filters}{$filter_class}[($pos-1) .. ($length-1)]} ];
1119     }
1120
1121     return $self;
1122 }
1123
1124 sub delete_filter {
1125     my ($self, $filter_class, $filter) = @_;
1126
1127     my $pos;
1128     unless (ref $filter) {
1129         $pos = $filter;
1130
1131         return delete $self->{filters}{$filter_class}[$pos];
1132     }
1133
1134     $self->{filters}{$filter_class} ||= [];
1135     my @deleted;
1136     for my $i (0 .. $#{$self->{filters}{$filter_class}}) {
1137         push @deleted, delete $self->{filters}{$filter_class}[$i]
1138             if $self->{filters}{$filter_class}[$i] == $filter;
1139     }
1140
1141     return @deleted;
1142 }
1143
1144 sub replace_filter {
1145     my ($self, $filter_class, $filter, @new_filters) = @_;
1146
1147     my @pos;
1148     unless (ref $filter) {
1149         $pos[0] = $filter;
1150     } else {
1151         $self->{filters}{$filter_class} ||= [];
1152         for my $i (0 .. $#{$self->{filters}{$filter_class}}) {
1153             push @pos, $i
1154                 if $self->{filters}{$filter_class}[$i] == $filter;
1155         }
1156     }
1157
1158     foreach my $p (@pos) {
1159         $self->delete_filter( $filter_class, $p );
1160
1161         foreach my $f (@new_filters) {
1162             $self->add_filter( $filter_class, $f, $p++);
1163         }
1164     }
1165
1166     return $self;
1167 }
1168
1169 1;
1170 __END__
1171
1172 =head1 COMMON OUTPUT OPTIONS
1173
1174 The following options are supported by all output methods,
1175 all take a version number as value:
1176
1177 =over 4
1178
1179 =item since
1180
1181 Causes changelog information from all versions strictly
1182 later than B<version> to be used.
1183
1184 (works exactly like the C<-v> option of dpkg-parsechangelog).
1185
1186 =item until
1187
1188 Causes changelog information from all versions strictly
1189 earlier than B<version> to be used.
1190
1191 =item from
1192
1193 Similar to C<since> but also includes the information for the
1194 specified B<version> itself.
1195
1196 =item to
1197
1198 Similar to C<until> but also includes the information for the
1199 specified B<version> itself.
1200
1201 =back
1202
1203 The following options also supported by all output methods but
1204 don't take version numbers as values:
1205
1206 =over 4
1207
1208 =item all
1209
1210 If set to a true value, all entries of the changelog are returned,
1211 this overrides all other options. While the XML and HTML formats
1212 default to all == true, this does of course not overwrite other
1213 options unless it is set explicitly with the call.
1214
1215 =item count
1216
1217 Expects a signed integer as value. Returns C<value> entries from the
1218 top of the changelog if set to a positive integer, and C<abs(value)>
1219 entries from the tail if set to a negative integer.
1220
1221 =item offset
1222
1223 Expects a signed integer as value. Changes the starting point for
1224 C<count>, either counted from the top (positive integer) or from
1225 the tail (negative integer). C<offset> has no effect if C<count>
1226 wasn't given as well.
1227
1228 =back
1229
1230 Some examples for the above options. Imagine an example changelog with
1231 entries for the versions 1.2, 1.3, 2.0, 2.1, 2.2, 3.0 and 3.1.
1232
1233             Call                               Included entries
1234  C<E<lt>formatE<gt>({ since =E<gt> '2.0' })>  3.1, 3.0, 2.2
1235  C<E<lt>formatE<gt>({ until =E<gt> '2.0' })>  1.3, 1.2
1236  C<E<lt>formatE<gt>({ from =E<gt> '2.0' })>   3.1, 3.0, 2.2, 2.1, 2.0
1237  C<E<lt>formatE<gt>({ to =E<gt> '2.0' })>     2.0, 1.3, 1.2
1238  C<E<lt>formatE<gt>({ count =E<gt> 2 }>>      3.1, 3.0
1239  C<E<lt>formatE<gt>({ count =E<gt> -2 }>>     1.3, 1.2
1240  C<E<lt>formatE<gt>({ count =E<gt> 3,
1241                       offset=E<gt> 2 }>>      2.2, 2.1, 2.0
1242  C<E<lt>formatE<gt>({ count =E<gt> 2,
1243                       offset=E<gt> -3 }>>     2.0, 1.3
1244  C<E<lt>formatE<gt>({ count =E<gt> -2,
1245                       offset=E<gt> 3 }>>      3.0, 2.2
1246  C<E<lt>formatE<gt>({ count =E<gt> -2,
1247                       offset=E<gt> -3 }>>     2.2, 2.1
1248
1249 Any combination of one option of C<since> and C<from> and one of
1250 C<until> and C<to> returns the intersection of the two results
1251 with only one of the options specified.
1252
1253 =head1 SEE ALSO
1254
1255 Parse::DebianChangelog::Entry, Parse::DebianChangelog::ChangesFilters
1256
1257 Description of the Debian changelog format in the Debian policy:
1258 L<http://www.debian.org/doc/debian-policy/ch-source.html#s-dpkgchangelog>.
1259
1260 =head1 AUTHOR
1261
1262 Frank Lichtenheld, E<lt>frank@lichtenheld.deE<gt>
1263
1264 =head1 COPYRIGHT AND LICENSE
1265
1266 Copyright (C) 2005 by Frank Lichtenheld
1267
1268 This program is free software; you can redistribute it and/or modify
1269 it under the terms of the GNU General Public License as published by
1270 the Free Software Foundation; either version 2 of the License, or
1271 (at your option) any later version.
1272
1273 This program is distributed in the hope that it will be useful,
1274 but WITHOUT ANY WARRANTY; without even the implied warranty of
1275 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1276 GNU General Public License for more details.
1277
1278 You should have received a copy of the GNU General Public License
1279 along with this program; if not, write to the Free Software
1280 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
1281
1282 =cut