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