scripts/Dpkg/Changelog/Debian.pm

   1 # Copyright © 1996 Ian Jackson
   2 # Copyright © 2005 Frank Lichtenheld <frank@lichtenheld.de>
   3 # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
   4 # Copyright © 2012-2017 Guillem Jover <guillem@debian.org>
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  18
  19 =encoding utf8
  20
  21 =head1 NAME
  22
  23 Dpkg::Changelog::Debian - parse Debian changelogs
  24
  25 =head1 DESCRIPTION
  26
  27 This class represents a Debian changelog file as an array of changelog
  28 entries (L<Dpkg::Changelog::Entry::Debian>).
  29 It implements the generic interface L<Dpkg::Changelog>.
  30 Only methods specific to this implementation are described below,
  31 the rest are inherited.
  32
  33 Dpkg::Changelog::Debian parses Debian changelogs as described in
  34 L<deb-changelog(5)>.
  35
  36 The parser tries to ignore most cruft like # or /* */ style comments,
  37 RCS keywords, Vim modelines, Emacs local variables and stuff from
  38 older changelogs with other formats at the end of the file.
  39 NOTE: most of these are ignored silently currently, there is no
  40 parser error issued for them. This should become configurable in the
  41 future.
  42
  43 =cut
  44
  45 package Dpkg::Changelog::Debian 1.00;
  46
  47 use strict;
  48 use warnings;
  49
  50 use Dpkg::Gettext;
  51 use Dpkg::File;
  52 use Dpkg::Changelog;
  53 use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer);
  54
  55 use parent qw(Dpkg::Changelog);
  56
  57 use constant {
  58     FIRST_HEADING => g_('first heading'),
  59     NEXT_OR_EOF => g_('next heading or end of file'),
  60     START_CHANGES => g_('start of change data'),
  61     CHANGES_OR_TRAILER => g_('more change data or trailer'),
  62 };
  63
  64 my $ancient_delimiter_re = qr{
  65     ^
  66     (?: # Ancient GNU style changelog entry with expanded date
  67       (?:
  68         \w+\s+                          # Day of week (abbreviated)
  69         \w+\s+                          # Month name (abbreviated)
  70         \d{1,2}                         # Day of month
  71         \Q \E
  72         \d{1,2}:\d{1,2}:\d{1,2}\s+      # Time
  73         [\w\s]*                         # Timezone
  74         \d{4}                           # Year
  75       )
  76       \s+
  77       (?:.*)                            # Maintainer name
  78       \s+
  79       [<\(]
  80         (?:.*)                          # Maintainer email
  81       [\)>]
  82     | # Old GNU style changelog entry with expanded date
  83       (?:
  84         \w+\s+                          # Day of week (abbreviated)
  85         \w+\s+                          # Month name (abbreviated)
  86         \d{1,2},?\s*                    # Day of month
  87         \d{4}                           # Year
  88       )
  89       \s+
  90       (?:.*)                            # Maintainer name
  91       \s+
  92       [<\(]
  93         (?:.*)                          # Maintainer email
  94       [\)>]
  95     | # Ancient changelog header w/o key=value options
  96       (?:\w[-+0-9a-z.]*)                # Package name
  97       \Q \E
  98       \(
  99         (?:[^\(\) \t]+)                 # Package version
 100       \)
 101       \;?
 102     | # Ancient changelog header
 103       (?:[\w.+-]+)                      # Package name
 104       [- ]
 105       (?:\S+)                           # Package version
 106       \ Debian
 107       \ (?:\S+)                         # Package revision
 108     |
 109       Changes\ from\ version\ (?:.*)\ to\ (?:.*):
 110     |
 111       Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$
 112     |
 113       Old\ Changelog:\s*$
 114     |
 115       (?:\d+:)?
 116       \w[\w.+~-]*:?
 117       \s*$
 118     )
 119 }xi;
 120
 121 =head1 METHODS
 122
 123 =over 4
 124
 125 =item $count = $c->parse($fh, $description)
 126
 127 Read the filehandle and parse a Debian changelog in it, to store the entries
 128 as an array of L<Dpkg::Changelog::Entry::Debian> objects.
 129 Any previous entries in the object are reset before parsing new data.
 130
 131 Returns the number of changelog entries that have been parsed with success.
 132
 133 =cut
 134
 135 sub parse {
 136     my ($self, $fh, $file) = @_;
 137     $file = $self->{reportfile} if exists $self->{reportfile};
 138
 139     $self->reset_parse_errors;
 140
 141     $self->{data} = [];
 142     $self->set_unparsed_tail(undef);
 143
 144     my $expect = FIRST_HEADING;
 145     my $entry = Dpkg::Changelog::Entry::Debian->new();
 146     my @blanklines = ();
 147     # To make version unique, for example for using as id.
 148     my $unknowncounter = 1;
 149     local $_;
 150
 151     while (<$fh>) {
 152         chomp;
 153         if (match_header($_)) {
 154             unless ($expect eq FIRST_HEADING || $expect eq NEXT_OR_EOF) {
 155                 $self->parse_error($file, $.,
 156                     sprintf(g_('found start of entry where expected %s'),
 157                     $expect), "$_");
 158             }
 159             unless ($entry->is_empty) {
 160                 push @{$self->{data}}, $entry;
 161                 $entry = Dpkg::Changelog::Entry::Debian->new();
 162                 last if $self->abort_early();
 163             }
 164             $entry->set_part('header', $_);
 165             foreach my $error ($entry->parse_header()) {
 166                 $self->parse_error($file, $., $error, $_);
 167             }
 168             $expect = START_CHANGES;
 169             @blanklines = ();
 170         } elsif (m/^(?:;;\s*)?Local variables:/io) {
 171             # Save any trailing Emacs variables at end of file.
 172             $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // ''));
 173             last;
 174         } elsif (m/^vim:/io) {
 175             # Save any trailing Vim modelines at end of file.
 176             $self->set_unparsed_tail("$_\n" . (file_slurp($fh) // ''));
 177             last;
 178         } elsif (m/^\$\w+:.*\$/o) {
 179             next; # skip stuff that look like a RCS keyword
 180         } elsif (m/^\# /o) {
 181             next; # skip comments, even that's not supported
 182         } elsif (m{^/\*.*\*/}o) {
 183             next; # more comments
 184         } elsif (m/$ancient_delimiter_re/) {
 185             # save entries on old changelog format verbatim
 186             # we assume the rest of the file will be in old format once we
 187             # hit it for the first time
 188             $self->set_unparsed_tail("$_\n" . file_slurp($fh));
 189         } elsif (m/^\S/) {
 190             $self->parse_error($file, $., g_('badly formatted heading line'), "$_");
 191         } elsif (match_trailer($_)) {
 192             unless ($expect eq CHANGES_OR_TRAILER) {
 193                 $self->parse_error($file, $.,
 194                     sprintf(g_('found trailer where expected %s'), $expect), "$_");
 195             }
 196             $entry->set_part('trailer', $_);
 197             $entry->extend_part('blank_after_changes', [ @blanklines ]);
 198             @blanklines = ();
 199             foreach my $error ($entry->parse_trailer()) {
 200                 $self->parse_error($file, $., $error, $_);
 201             }
 202             $expect = NEXT_OR_EOF;
 203         } elsif (m/^ \-\-/) {
 204             $self->parse_error($file, $., g_('badly formatted trailer line'), "$_");
 205         } elsif (m/^\s{2,}(?:\S)/) {
 206             unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
 207                 $self->parse_error($file, $., sprintf(g_('found change data' .
 208                     ' where expected %s'), $expect), "$_");
 209                 if ($expect eq NEXT_OR_EOF and not $entry->is_empty) {
 210                     # lets assume we have missed the actual header line
 211                     push @{$self->{data}}, $entry;
 212                     $entry = Dpkg::Changelog::Entry::Debian->new();
 213                     $entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown');
 214                 }
 215             }
 216             # Keep raw changes
 217             $entry->extend_part('changes', [ @blanklines, $_ ]);
 218             @blanklines = ();
 219             $expect = CHANGES_OR_TRAILER;
 220         } elsif (!m/\S/) {
 221             if ($expect eq START_CHANGES) {
 222                 $entry->extend_part('blank_after_header', $_);
 223                 next;
 224             } elsif ($expect eq NEXT_OR_EOF) {
 225                 $entry->extend_part('blank_after_trailer', $_);
 226                 next;
 227             } elsif ($expect ne CHANGES_OR_TRAILER) {
 228                 $self->parse_error($file, $.,
 229                     sprintf(g_('found blank line where expected %s'), $expect));
 230             }
 231             push @blanklines, $_;
 232         } else {
 233             $self->parse_error($file, $., g_('unrecognized line'), "$_");
 234             unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
 235                 # lets assume change data if we expected it
 236                 $entry->extend_part('changes', [ @blanklines, $_]);
 237                 @blanklines = ();
 238                 $expect = CHANGES_OR_TRAILER;
 239             }
 240         }
 241     }
 242
 243     unless ($expect eq NEXT_OR_EOF) {
 244         $self->parse_error($file, $.,
 245                            sprintf(g_('found end of file where expected %s'),
 246                                    $expect));
 247     }
 248     unless ($entry->is_empty) {
 249         push @{$self->{data}}, $entry;
 250     }
 251
 252     return scalar @{$self->{data}};
 253 }
 254
 255 1;
 256
 257 =back
 258
 259 =head1 CHANGES
 260
 261 =head2 Version 1.00 (dpkg 1.15.6)
 262
 263 Mark the module as public.
 264
 265 =head1 SEE ALSO
 266
 267 L<Dpkg::Changelog>.
 268
 269 =cut