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