git.maemo.org Git - maemian/blob - nokia-lintian/checks/changelog-file

   1 # changelog-file -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 1998 Christian Schwarz
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the terms of the GNU General Public License as published by
   7 # the Free Software Foundation; either version 2 of the License, or
   8 # (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program.  If not, you can find it on the World Wide
  17 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  18 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  19 # MA 02110-1301, USA.
  20
  21 package Lintian::changelog_file;
  22 use strict;
  23 use Spelling;
  24 use Dep;
  25 use Tags;
  26 use Util;
  27
  28 use Encode qw(decode);
  29 use Parse::DebianChangelog;
  30
  31 sub run {
  32
  33 my $pkg = shift;
  34 my $type = shift;
  35 my $found_html=0;
  36 my $found_text=0;
  37 my $native_pkg;
  38 my $foreign_pkg;
  39 my $ppkg = quotemeta($pkg);
  40
  41 my @doc_files;
  42
  43 my %file_info;
  44 my %is_a_symlink;
  45
  46 # Read file info...
  47 open(IN, '<', "file-info")
  48     or fail("cannot find file-info for $type package $pkg");
  49 while (<IN>) {
  50     chop;
  51
  52     m/^(.*?):\s+(.*)$/o or
  53         fail("an error in the file pkg is preventing lintian from checking this package: $_");
  54     my ($file,$info) = ($1,$2);
  55
  56     next unless $file =~ m/doc/o;
  57     $file =~ s,^(\./)?,,;
  58     $file_info{$file} = $info;
  59 }
  60 close(IN);
  61
  62 # Modify the file_info by following symbolic links.
  63 for my $file (keys %file_info) {
  64     if ($file_info{$file} =~ m/^(?:broken )?symbolic link to (.*)/) {
  65         $is_a_symlink{$file} = 1;
  66         # Figure out the link destination.  This algorithm is
  67         # not perfect but should be good enough.  (If it fails,
  68         # all that happens is that an evil symlink causes a bogus warning).
  69         my $newfile;
  70         my $link = $1;
  71         if ($link =~ m/^\//) {
  72             # absolute path; replace
  73             $newfile = $link;
  74         } else {
  75             $newfile = $file;   # relative path; base on $file
  76             $newfile =~ s,/[^/]+$,,; # strip final pathname component
  77             # strip another component for every leading ../ in $link
  78             while ($link =~ m,^\.\./,) {
  79                 $newfile =~ s,/[^/]+$,,;
  80                 $link =~ s,^\.\./,,;
  81             }
  82             # concatenate the results
  83             $newfile .= '/' . $link;
  84         }
  85         if (exists $file_info{$newfile}) {
  86             $file_info{$file} = $file_info{$newfile};
  87         }
  88     }
  89 }
  90
  91 # TODO: better check for incorrect case, /../i and /../ without i is used
  92 # together at random it seems here
  93
  94 # Read package contents...
  95 open(IN, '<', "index") or fail("cannot open index file index: $!");
  96 while (<IN>) {
  97     chop;
  98
  99     s,^(\./),,;
 100     # skip packages which have a /usr/share/doc/$pkg -> foo symlink
 101     if (m, usr/share/doc/$ppkg -> ,) {
 102         return 0;
 103     }
 104
 105     # we are only interested in files or symlinks in /usr/(share/)?doc/$pkg
 106     if (m,usr/(share/)?doc/$ppkg/([^/\s]+), ) {
 107         my $file = $2;
 108         my $file1 = "usr/share/doc/$pkg/$file";
 109
 110         push(@doc_files, $file);
 111
 112         # Check a few things about the NEWS.Debian file.
 113         if ($file =~ /^NEWS.Debian(\.gz)?$/i) {
 114             if (not $file =~ /\.gz$/) {
 115                 tag "debian-news-file-not-compressed", "$file1";
 116             } elsif ($file ne 'NEWS.Debian.gz') {
 117                 tag "wrong-name-for-debian-news-file", "$file1";
 118             }
 119         }
 120
 121         # check if changelog files are compressed with gzip -9
 122         next unless $file =~ m/^changelog(\.html)?(\.gz)?$|changelog.debian(\.gz)?$/i;
 123
 124         if (not $file =~ m/\.gz$/) {
 125             tag "changelog-file-not-compressed", "$file";
 126         } else {
 127             my $max_compressed = 0;
 128             if (exists $file_info{$file1} && defined $file_info{$file1}) {
 129                 if ($file_info{$file1} =~ m/max compression/o) {
 130                     $max_compressed = 1;
 131                 }
 132             }
 133             if (not $max_compressed) {
 134                 unless ($is_a_symlink{$file1}) {
 135                     tag "changelog-not-compressed-with-max-compression", "$file";
 136                 }
 137             }
 138         }
 139
 140         if ($file =~ m/^changelog\.html(\.gz)?$/ ) {
 141             $found_html = 1;
 142         }
 143         if ($file =~ m/^changelog(\.gz)?$/ ) {
 144             $found_text = 1;
 145         }
 146     }
 147
 148     #  next unless m,^(\S+).*usr/share/doc/$ppkg/([^/\s]+)( -> [^/\s]+)?$,o;
 149 }
 150 close(IN);
 151
 152 # ignore packages which don't have a /usr/share/doc/$pkg directory, since
 153 # the copyright check will complain about this
 154 if ($#doc_files < 0) {
 155     return 0;
 156 }
 157
 158 # Check a NEWS.Debian file if we have one.  We should additionally check here
 159 # that the entries don't begin with an asterisk, but that hasn't been done
 160 # yet.  Save the version, distribution, and urgency for later checks against
 161 # the changelog file.
 162 my $news;
 163 if (-f 'NEWS.Debian') {
 164     my $line = file_is_encoded_in_non_utf8('NEWS.Debian', $type, $pkg);
 165     if ($line) {
 166         tag "debian-news-file-uses-obsolete-national-encoding", "at line $line"
 167     }
 168     my $changes = Parse::DebianChangelog->init( { infile => 'NEWS.Debian', quiet => 1 } );
 169     if (my @errors = $changes->get_parse_errors) {
 170         for (@errors) {
 171             tag "syntax-error-in-debian-news-file", "line $_->[1]", "\"$_->[2]\"";
 172         }
 173     }
 174
 175     # Some checks on the most recent entry.
 176     if ($changes->data and defined (($changes->data)[0])) {
 177         ($news) = $changes->data;
 178         if ($news->Distribution && $news->Distribution =~ /unreleased/i) {
 179             tag "debian-news-entry-has-strange-distribution", $news->Distribution;
 180         }
 181         spelling_check('spelling-error-in-news-debian', $news->Changes);
 182     }
 183 }
 184
 185 if ( $found_html && !$found_text ) {
 186     tag "html-changelog-without-text-version", "";
 187 }
 188
 189 # is this a native Debian package?
 190 open(IN, '<', "fields/version")
 191     or fail("cannot open fields/version file for reading: $!");
 192 chop(my $version = <IN>);
 193 close(IN);
 194
 195 $native_pkg  = ($version !~ m/-/);
 196 $foreign_pkg = (!$native_pkg and $version !~ m/-0\./);
 197 # A version of 1.2.3-0.1 could be either, so in that
 198 # case, both vars are false
 199
 200 if ($native_pkg) {
 201     my @foo;
 202     # native Debian package
 203     if (grep m/^changelog(\.gz)?$/,@doc_files) {
 204         # everything is fine
 205     } elsif (@foo = grep m/^changelog\.debian(\.gz)$/i,@doc_files) {
 206         tag "wrong-name-for-changelog-of-native-package", "usr/share/doc/$pkg/$foo[0]";
 207     } else {
 208         tag "changelog-file-missing-in-native-package", "";
 209     }
 210 } else {
 211     # non-native (foreign :) Debian package
 212
 213     # 1. check for upstream changelog
 214     my $found_upstream_text_changelog = 0;
 215     if (grep m/^changelog(\.html)?(\.gz)?$/,@doc_files) {
 216         $found_upstream_text_changelog = 1 unless $1;
 217         # everything is fine
 218     } else {
 219         # search for changelogs with wrong file name
 220         my $found = 0;
 221         for (@doc_files) {
 222             if (m/^change/i and not m/debian/i) {
 223                 tag "wrong-name-for-upstream-changelog", "usr/share/doc/$pkg/$_";
 224                 $found = 1;
 225                 last;
 226             }
 227         }
 228         if (not $found) {
 229             # This tag is disabled for now since a lot of packages fail this
 230             # aspect of policy and I want to clarify policy WRT multi-binary
 231             # packages first.
 232             #tag "no-upstream-changelog", "";
 233         }
 234     }
 235
 236     # 2. check for Debian changelog
 237     if (grep m/^changelog\.Debian(\.gz)?$/,@doc_files) {
 238         # everything is fine
 239     } elsif (my @foo = grep m/^changelog\.debian(\.gz)?$/i,@doc_files) {
 240         tag "wrong-name-for-debian-changelog-file", "usr/share/doc/$pkg/$foo[0]";
 241     } else {
 242         if ($foreign_pkg && $found_upstream_text_changelog) {
 243             tag "debian-changelog-file-missing-or-wrong-name", "";
 244         } elsif ($foreign_pkg) {
 245             tag "debian-changelog-file-missing", "";
 246         }
 247         # TODO: if uncertain whether foreign or native, either changelog.gz or
 248         # changelog.debian.gz should exists though... but no tests catches
 249         # this (extremely rare) border case... Keep in mind this is only
 250         # happening if we have a -0.x version number... So not my priority to
 251         # fix --Jeroen
 252     }
 253 }
 254
 255 # Everything below involves opening and reading the changelog file, so bail
 256 # with a warning at this point if all we have is a symlink.
 257 if (-l 'changelog') {
 258     tag "debian-changelog-file-is-a-symlink", "";
 259     return 0;
 260 }
 261
 262 # Bail at this point if the changelog file doesn't exist.  We will have
 263 # already warned about this.
 264 unless (-f 'changelog') {
 265     return 0;
 266 }
 267
 268 # check that changelog is UTF-8 encoded
 269 my $line = file_is_encoded_in_non_utf8("changelog", $type, $pkg);
 270 if ($line) {
 271     tag "debian-changelog-file-uses-obsolete-national-encoding", "at line $line"
 272 }
 273
 274 my $changes = Parse::DebianChangelog->init( { infile => 'changelog',
 275                                               quiet => 1 } );
 276 if (my @errors = $changes->get_parse_errors) {
 277     foreach (@errors) {
 278         tag "syntax-error-in-debian-changelog", "line $_->[1]", "\"$_->[2]\"";
 279     }
 280 }
 281
 282 my @entries = $changes->data;
 283 if (@entries) {
 284     foreach (@entries) {
 285         if ($_->Maintainer) {
 286             if ($_->Maintainer =~ /<([^>\@]+\@unknown)>/) {
 287                 tag "debian-changelog-file-contains-debmake-default-email-address", $1;
 288             } elsif ($_->Maintainer =~ /<([^>\@]+\@[^>.]*)>/) {
 289                 tag "debian-changelog-file-contains-invalid-email-address", $1;
 290             }
 291         }
 292     }
 293
 294     if (@entries > 1) {
 295         my $first_timestamp = $entries[0]->Timestamp;
 296         my $second_timestamp = $entries[1]->Timestamp;
 297
 298         if ($first_timestamp && $second_timestamp) {
 299             tag "latest-debian-changelog-entry-without-new-date"
 300                 unless (($first_timestamp - $second_timestamp) > 0);
 301         }
 302
 303         my $first_version = $entries[0]->Version;
 304         my $second_version = $entries[1]->Version;
 305         if ($first_version and $second_version) {
 306             tag "latest-debian-changelog-entry-without-new-version"
 307                 unless Dep::versions_gt ($first_version, $second_version)
 308                     or $entries[0]->Changes =~ /backport/i;
 309         }
 310     }
 311
 312     # Some checks should only be done against the most recent changelog entry.
 313     my $entry = $entries[0];
 314     if (@entries == 1 and $entry->Version =~ /-1$/) {
 315         tag 'new-package-should-close-itp-bug'
 316             unless @{ $entry->Closes };
 317     }
 318     my $changes = $entry->Changes;
 319     while ($changes =~ /(closes\s*(?:bug)?\#?\s?\d{6,})[^\w]/ig) {
 320         tag "possible-missing-colon-in-closes", "$1" if $1;
 321     }
 322
 323     # Compare against NEWS.Debian if available.
 324     if ($news and $news->Version and $entry->Version eq $news->Version) {
 325         for my $field (qw/Distribution Urgency/) {
 326             if ($entry->$field ne $news->$field) {
 327                 tag 'changelog-news-debian-mismatch', lc ($field),
 328                     $entry->$field . ' != ' . $news->$field;
 329             }
 330         }
 331     }
 332
 333     # We have to decode into UTF-8 to get the right length for the length
 334     # check.  For some reason, use open ':utf8' isn't sufficient.  If the
 335     # changelog uses a non-UTF-8 encoding, this will mangle it, but it doesn't
 336     # matter for the length check.
 337     #
 338     # Parse::DebianChangelog adds an additional space to the beginning of each
 339     # line, so we have to adjust for that in the length check.
 340     my @lines = split ("\n", decode ('utf-8', $changes));
 341     for my $i (0 .. $#lines) {
 342         if (length ($lines[$i]) > 81 && $lines[$i] !~ /^[\s.o*+-]*\S+$/) {
 343             tag 'debian-changelog-line-too-long', "line " . ($i + 1);
 344         }
 345     }
 346
 347     # Strip out all lines that contain the word spelling to avoid false
 348     # positives on changelog entries for spelling fixes.
 349     $changes =~ s/^.*spelling.*\n//gm;
 350     spelling_check('spelling-error-in-changelog', $changes);
 351 }
 352
 353 # read the changelog itself
 354 #
 355 # emacs only looks at the last "local variables" in a file, and only at
 356 # one within 3000 chars of EOF and on the last page (^L), but that's a bit
 357 # pesky to replicate.  Demanding a match of $prefix and $suffix ought to
 358 # be enough to avoid false positives.
 359 open (IN, '<', "changelog")
 360     or fail("cannot find changelog for $type package $pkg");
 361 my ($prefix, $suffix);
 362 while (<IN>) {
 363
 364     if (/closes:\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*)/io
 365         || /closes:\s*(?:bug)?\#?\s?\d+
 366               (?:,\s*(?:bug)?\#?\s?\d+)*
 367               (?:,\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*))/iox) {
 368         tag "wrong-bug-number-in-closes", "l$.:$1" if $2;
 369     }
 370
 371     if (/^(.*)Local\ variables:(.*)$/i) {
 372         $prefix = $1;
 373         $suffix = $2;
 374     }
 375     # emacs allows whitespace between prefix and variable, hence \s*
 376     if (defined $prefix && defined $suffix
 377         && /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/) {
 378         tag "debian-changelog-file-contains-obsolete-user-emacs-settings";
 379     }
 380 }
 381 close IN;
 382
 383 }
 384
 385 1;
 386
 387 # vim: syntax=perl ts=8 sw=4