chiark - git - mdw - dpkg/blob - 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-2015 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 Dpkg::Changelog::Debian parses Debian changelogs as described in
  28 deb-changelog(5).
  29
  30 The parser tries to ignore most cruft like # or /* */ style comments,
  31 CVS comments, vim variables, emacs local variables and stuff from
  32 older changelogs with other formats at the end of the file.
  33 NOTE: most of these are ignored silently currently, there is no
  34 parser error issued for them. This should become configurable in the
  35 future.
  36
  37 =cut
  38
  39 package Dpkg::Changelog::Debian;
  40
  41 use strict;
  42 use warnings;
  43
  44 our $VERSION = '1.00';
  45
  46 use Dpkg::Gettext;
  47 use Dpkg::File;
  48 use Dpkg::Changelog qw(:util);
  49 use Dpkg::Changelog::Entry::Debian qw(match_header match_trailer);
  50
  51 use parent qw(Dpkg::Changelog);
  52
  53 use constant {
  54     FIRST_HEADING => g_('first heading'),
  55     NEXT_OR_EOF => g_('next heading or end of file'),
  56     START_CHANGES => g_('start of change data'),
  57     CHANGES_OR_TRAILER => g_('more change data or trailer'),
  58 };
  59
  60 my $ancient_delimiter_re = qr{
  61     ^
  62     (?: # Ancient GNU style changelog entry with expanded date
  63       (?:
  64         \w+\s+                          # Day of week (abbreviated)
  65         \w+\s+                          # Month name (abbreviated)
  66         \d{1,2}                         # Day of month
  67         \Q \E
  68         \d{1,2}:\d{1,2}:\d{1,2}\s+      # Time
  69         [\w\s]*                         # Timezone
  70         \d{4}                           # Year
  71       )
  72       \s+
  73       (?:.*)                            # Maintainer name
  74       \s+
  75       [<\(]
  76         (?:.*)                          # Maintainer email
  77       [\)>]
  78     | # Old GNU style changelog entry with expanded date
  79       (?:
  80         \w+\s+                          # Day of week (abbreviated)
  81         \w+\s+                          # Month name (abbreviated)
  82         \d{1,2},?\s*                    # Day of month
  83         \d{4}                           # Year
  84       )
  85       \s+
  86       (?:.*)                            # Maintainer name
  87       \s+
  88       [<\(]
  89         (?:.*)                          # Maintainer email
  90       [\)>]
  91     | # Ancient changelog header w/o key=value options
  92       (?:\w[-+0-9a-z.]*)                # Package name
  93       \Q \E
  94       \(
  95         (?:[^\(\) \t]+)                 # Package version
  96       \)
  97       \;?
  98     | # Ancient changelog header
  99       (?:[\w.+-]+)                      # Package name
 100       [- ]
 101       (?:\S+)                           # Package version
 102       \ Debian
 103       \ (?:\S+)                         # Package revision
 104     |
 105       Changes\ from\ version\ (?:.*)\ to\ (?:.*):
 106     |
 107       Changes\ for\ [\w.+-]+-[\w.+-]+:?\s*$
 108     |
 109       Old\ Changelog:\s*$
 110     |
 111       (?:\d+:)?
 112       \w[\w.+~-]*:?
 113       \s*$
 114     )
 115 }xi;
 116
 117 =head1 METHODS
 118
 119 =over 4
 120
 121 =item $c->parse($fh, $description)
 122
 123 Read the filehandle and parse a Debian changelog in it. The data in the
 124 object is reset before parsing new data.
 125
 126 Returns the number of changelog entries that have been parsed with success.
 127
 128 =cut
 129
 130 sub parse {
 131     my ($self, $fh, $file) = @_;
 132     $file = $self->{reportfile} if exists $self->{reportfile};
 133
 134     $self->reset_parse_errors;
 135
 136     $self->{data} = [];
 137     $self->set_unparsed_tail(undef);
 138
 139     my $expect = FIRST_HEADING;
 140     my $entry = Dpkg::Changelog::Entry::Debian->new();
 141     my @blanklines = ();
 142     my $unknowncounter = 1; # to make version unique, e.g. for using as id
 143     local $_;
 144
 145     while (<$fh>) {
 146         chomp;
 147         if (match_header($_)) {
 148             unless ($expect eq FIRST_HEADING || $expect eq NEXT_OR_EOF) {
 149                 $self->parse_error($file, $.,
 150                     sprintf(g_('found start of entry where expected %s'),
 151                     $expect), "$_");
 152             }
 153             unless ($entry->is_empty) {
 154                 push @{$self->{data}}, $entry;
 155                 $entry = Dpkg::Changelog::Entry::Debian->new();
 156                 last if $self->abort_early();
 157             }
 158             $entry->set_part('header', $_);
 159             foreach my $error ($entry->parse_header()) {
 160                 $self->parse_error($file, $., $error, $_);
 161             }
 162             $expect= START_CHANGES;
 163             @blanklines = ();
 164         } elsif (m/^(?:;;\s*)?Local variables:/io) {
 165             last; # skip Emacs variables at end of file
 166         } elsif (m/^vim:/io) {
 167             last; # skip vim variables at end of file
 168         } elsif (m/^\$\w+:.*\$/o) {
 169             next; # skip stuff that look like a CVS keyword
 170         } elsif (m/^\# /o) {
 171             next; # skip comments, even that's not supported
 172         } elsif (m{^/\*.*\*/}o) {
 173             next; # more comments
 174         } elsif (m/$ancient_delimiter_re/) {
 175             # save entries on old changelog format verbatim
 176             # we assume the rest of the file will be in old format once we
 177             # hit it for the first time
 178             $self->set_unparsed_tail("$_\n" . file_slurp($fh));
 179         } elsif (m/^\S/) {
 180             $self->parse_error($file, $., g_('badly formatted heading line'), "$_");
 181         } elsif (match_trailer($_)) {
 182             unless ($expect eq CHANGES_OR_TRAILER) {
 183                 $self->parse_error($file, $.,
 184                     sprintf(g_('found trailer where expected %s'), $expect), "$_");
 185             }
 186             $entry->set_part('trailer', $_);
 187             $entry->extend_part('blank_after_changes', [ @blanklines ]);
 188             @blanklines = ();
 189             foreach my $error ($entry->parse_trailer()) {
 190                 $self->parse_error($file, $., $error, $_);
 191             }
 192             $expect = NEXT_OR_EOF;
 193         } elsif (m/^ \-\-/) {
 194             $self->parse_error($file, $., g_('badly formatted trailer line'), "$_");
 195         } elsif (m/^\s{2,}(?:\S)/) {
 196             unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
 197                 $self->parse_error($file, $., sprintf(g_('found change data' .
 198                     ' where expected %s'), $expect), "$_");
 199                 if ($expect eq NEXT_OR_EOF and not $entry->is_empty) {
 200                     # lets assume we have missed the actual header line
 201                     push @{$self->{data}}, $entry;
 202                     $entry = Dpkg::Changelog::Entry::Debian->new();
 203                     $entry->set_part('header', 'unknown (unknown' . ($unknowncounter++) . ') unknown; urgency=unknown');
 204                 }
 205             }
 206             # Keep raw changes
 207             $entry->extend_part('changes', [ @blanklines, $_ ]);
 208             @blanklines = ();
 209             $expect = CHANGES_OR_TRAILER;
 210         } elsif (!m/\S/) {
 211             if ($expect eq START_CHANGES) {
 212                 $entry->extend_part('blank_after_header', $_);
 213                 next;
 214             } elsif ($expect eq NEXT_OR_EOF) {
 215                 $entry->extend_part('blank_after_trailer', $_);
 216                 next;
 217             } elsif ($expect ne CHANGES_OR_TRAILER) {
 218                 $self->parse_error($file, $.,
 219                     sprintf(g_('found blank line where expected %s'), $expect));
 220             }
 221             push @blanklines, $_;
 222         } else {
 223             $self->parse_error($file, $., g_('unrecognized line'), "$_");
 224             unless ($expect eq START_CHANGES or $expect eq CHANGES_OR_TRAILER) {
 225                 # lets assume change data if we expected it
 226                 $entry->extend_part('changes', [ @blanklines, $_]);
 227                 @blanklines = ();
 228                 $expect = CHANGES_OR_TRAILER;
 229             }
 230         }
 231     }
 232
 233     unless ($expect eq NEXT_OR_EOF) {
 234         $self->parse_error($file, $.,
 235                            sprintf(g_('found end of file where expected %s'),
 236                                    $expect));
 237     }
 238     unless ($entry->is_empty) {
 239         push @{$self->{data}}, $entry;
 240     }
 241
 242     return scalar @{$self->{data}};
 243 }
 244
 245 1;
 246 __END__
 247
 248 =back
 249
 250 =head1 CHANGES
 251
 252 =head2 Version 1.00 (dpkg 1.15.6)
 253
 254 Mark the module as public.
 255
 256 =head1 SEE ALSO
 257
 258 Dpkg::Changelog
 259
 260 =cut