+++ /dev/null
-# changelog-file -- lintian check script -*- perl -*-
-
-# Copyright (C) 1998 Christian Schwarz
-#
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program. If not, you can find it on the World Wide
-# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
-# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
-# MA 02110-1301, USA.
-
-package Lintian::changelog_file;
-use strict;
-use Spelling;
-use Dep;
-use Tags;
-use Util;
-
-use Encode qw(decode);
-use Parse::DebianChangelog;
-
-sub run {
-
-my $pkg = shift;
-my $type = shift;
-my $found_html=0;
-my $found_text=0;
-my $native_pkg;
-my $foreign_pkg;
-my $ppkg = quotemeta($pkg);
-
-my @doc_files;
-
-my %file_info;
-my %is_a_symlink;
-
-# Read file info...
-open(IN, '<', "file-info")
- or fail("cannot find file-info for $type package $pkg");
-while (<IN>) {
- chop;
-
- m/^(.*?):\s+(.*)$/o or
- fail("an error in the file pkg is preventing lintian from checking this package: $_");
- my ($file,$info) = ($1,$2);
-
- next unless $file =~ m/doc/o;
- $file =~ s,^(\./)?,,;
- $file_info{$file} = $info;
-}
-close(IN);
-
-# Modify the file_info by following symbolic links.
-for my $file (keys %file_info) {
- if ($file_info{$file} =~ m/^(?:broken )?symbolic link to (.*)/) {
- $is_a_symlink{$file} = 1;
- # Figure out the link destination. This algorithm is
- # not perfect but should be good enough. (If it fails,
- # all that happens is that an evil symlink causes a bogus warning).
- my $newfile;
- my $link = $1;
- if ($link =~ m/^\//) {
- # absolute path; replace
- $newfile = $link;
- } else {
- $newfile = $file; # relative path; base on $file
- $newfile =~ s,/[^/]+$,,; # strip final pathname component
- # strip another component for every leading ../ in $link
- while ($link =~ m,^\.\./,) {
- $newfile =~ s,/[^/]+$,,;
- $link =~ s,^\.\./,,;
- }
- # concatenate the results
- $newfile .= '/' . $link;
- }
- if (exists $file_info{$newfile}) {
- $file_info{$file} = $file_info{$newfile};
- }
- }
-}
-
-# TODO: better check for incorrect case, /../i and /../ without i is used
-# together at random it seems here
-
-# Read package contents...
-open(IN, '<', "index") or fail("cannot open index file index: $!");
-while (<IN>) {
- chop;
-
- s,^(\./),,;
- # skip packages which have a /usr/share/doc/$pkg -> foo symlink
- if (m, usr/share/doc/$ppkg -> ,) {
- return 0;
- }
-
- # we are only interested in files or symlinks in /usr/(share/)?doc/$pkg
- if (m,usr/(share/)?doc/$ppkg/([^/\s]+), ) {
- my $file = $2;
- my $file1 = "usr/share/doc/$pkg/$file";
-
- push(@doc_files, $file);
-
- # Check a few things about the NEWS.Debian file.
- if ($file =~ /^NEWS.Debian(\.gz)?$/i) {
- if (not $file =~ /\.gz$/) {
- tag "debian-news-file-not-compressed", "$file1";
- } elsif ($file ne 'NEWS.Debian.gz') {
- tag "wrong-name-for-debian-news-file", "$file1";
- }
- }
-
- # check if changelog files are compressed with gzip -9
- next unless $file =~ m/^changelog(\.html)?(\.gz)?$|changelog.debian(\.gz)?$/i;
-
- if (not $file =~ m/\.gz$/) {
- tag "changelog-file-not-compressed", "$file";
- } else {
- my $max_compressed = 0;
- if (exists $file_info{$file1} && defined $file_info{$file1}) {
- if ($file_info{$file1} =~ m/max compression/o) {
- $max_compressed = 1;
- }
- }
- if (not $max_compressed) {
- unless ($is_a_symlink{$file1}) {
- tag "changelog-not-compressed-with-max-compression", "$file";
- }
- }
- }
-
- if ($file =~ m/^changelog\.html(\.gz)?$/ ) {
- $found_html = 1;
- }
- if ($file =~ m/^changelog(\.gz)?$/ ) {
- $found_text = 1;
- }
- }
-
- # next unless m,^(\S+).*usr/share/doc/$ppkg/([^/\s]+)( -> [^/\s]+)?$,o;
-}
-close(IN);
-
-# ignore packages which don't have a /usr/share/doc/$pkg directory, since
-# the copyright check will complain about this
-if ($#doc_files < 0) {
- return 0;
-}
-
-# Check a NEWS.Debian file if we have one. We should additionally check here
-# that the entries don't begin with an asterisk, but that hasn't been done
-# yet. Save the version, distribution, and urgency for later checks against
-# the changelog file.
-my $news;
-if (-f 'NEWS.Debian') {
- my $line = file_is_encoded_in_non_utf8('NEWS.Debian', $type, $pkg);
- if ($line) {
- tag "debian-news-file-uses-obsolete-national-encoding", "at line $line"
- }
- my $changes = Parse::DebianChangelog->init( { infile => 'NEWS.Debian', quiet => 1 } );
- if (my @errors = $changes->get_parse_errors) {
- for (@errors) {
- tag "syntax-error-in-debian-news-file", "line $_->[1]", "\"$_->[2]\"";
- }
- }
-
- # Some checks on the most recent entry.
- if ($changes->data and defined (($changes->data)[0])) {
- ($news) = $changes->data;
- if ($news->Distribution && $news->Distribution =~ /unreleased/i) {
- tag "debian-news-entry-has-strange-distribution", $news->Distribution;
- }
- spelling_check('spelling-error-in-news-debian', $news->Changes);
- }
-}
-
-if ( $found_html && !$found_text ) {
- tag "html-changelog-without-text-version", "";
-}
-
-# is this a native Debian package?
-open(IN, '<', "fields/version")
- or fail("cannot open fields/version file for reading: $!");
-chop(my $version = <IN>);
-close(IN);
-
-$native_pkg = ($version !~ m/-/);
-$foreign_pkg = (!$native_pkg and $version !~ m/-0\./);
-# A version of 1.2.3-0.1 could be either, so in that
-# case, both vars are false
-
-if ($native_pkg) {
- my @foo;
- # native Debian package
- if (grep m/^changelog(\.gz)?$/,@doc_files) {
- # everything is fine
- } elsif (@foo = grep m/^changelog\.debian(\.gz)$/i,@doc_files) {
- tag "wrong-name-for-changelog-of-native-package", "usr/share/doc/$pkg/$foo[0]";
- } else {
- tag "changelog-file-missing-in-native-package", "";
- }
-} else {
- # non-native (foreign :) Debian package
-
- # 1. check for upstream changelog
- my $found_upstream_text_changelog = 0;
- if (grep m/^changelog(\.html)?(\.gz)?$/,@doc_files) {
- $found_upstream_text_changelog = 1 unless $1;
- # everything is fine
- } else {
- # search for changelogs with wrong file name
- my $found = 0;
- for (@doc_files) {
- if (m/^change/i and not m/debian/i) {
- tag "wrong-name-for-upstream-changelog", "usr/share/doc/$pkg/$_";
- $found = 1;
- last;
- }
- }
- if (not $found) {
- # This tag is disabled for now since a lot of packages fail this
- # aspect of policy and I want to clarify policy WRT multi-binary
- # packages first.
- #tag "no-upstream-changelog", "";
- }
- }
-
- # 2. check for Debian changelog
- if (grep m/^changelog\.Debian(\.gz)?$/,@doc_files) {
- # everything is fine
- } elsif (my @foo = grep m/^changelog\.debian(\.gz)?$/i,@doc_files) {
- tag "wrong-name-for-debian-changelog-file", "usr/share/doc/$pkg/$foo[0]";
- } else {
- if ($foreign_pkg && $found_upstream_text_changelog) {
- tag "debian-changelog-file-missing-or-wrong-name", "";
- } elsif ($foreign_pkg) {
- tag "debian-changelog-file-missing", "";
- }
- # TODO: if uncertain whether foreign or native, either changelog.gz or
- # changelog.debian.gz should exists though... but no tests catches
- # this (extremely rare) border case... Keep in mind this is only
- # happening if we have a -0.x version number... So not my priority to
- # fix --Jeroen
- }
-}
-
-# Everything below involves opening and reading the changelog file, so bail
-# with a warning at this point if all we have is a symlink.
-if (-l 'changelog') {
- tag "debian-changelog-file-is-a-symlink", "";
- return 0;
-}
-
-# Bail at this point if the changelog file doesn't exist. We will have
-# already warned about this.
-unless (-f 'changelog') {
- return 0;
-}
-
-# check that changelog is UTF-8 encoded
-my $line = file_is_encoded_in_non_utf8("changelog", $type, $pkg);
-if ($line) {
- tag "debian-changelog-file-uses-obsolete-national-encoding", "at line $line"
-}
-
-my $changes = Parse::DebianChangelog->init( { infile => 'changelog',
- quiet => 1 } );
-if (my @errors = $changes->get_parse_errors) {
- foreach (@errors) {
- tag "syntax-error-in-debian-changelog", "line $_->[1]", "\"$_->[2]\"";
- }
-}
-
-my @entries = $changes->data;
-if (@entries) {
- foreach (@entries) {
- if ($_->Maintainer) {
- if ($_->Maintainer =~ /<([^>\@]+\@unknown)>/) {
- tag "debian-changelog-file-contains-debmake-default-email-address", $1;
- } elsif ($_->Maintainer =~ /<([^>\@]+\@[^>.]*)>/) {
- tag "debian-changelog-file-contains-invalid-email-address", $1;
- }
- }
- }
-
- if (@entries > 1) {
- my $first_timestamp = $entries[0]->Timestamp;
- my $second_timestamp = $entries[1]->Timestamp;
-
- if ($first_timestamp && $second_timestamp) {
- tag "latest-debian-changelog-entry-without-new-date"
- unless (($first_timestamp - $second_timestamp) > 0);
- }
-
- my $first_version = $entries[0]->Version;
- my $second_version = $entries[1]->Version;
- if ($first_version and $second_version) {
- tag "latest-debian-changelog-entry-without-new-version"
- unless Dep::versions_gt ($first_version, $second_version)
- or $entries[0]->Changes =~ /backport/i;
- }
- }
-
- # Some checks should only be done against the most recent changelog entry.
- my $entry = $entries[0];
- if (@entries == 1 and $entry->Version =~ /-1$/) {
- tag 'new-package-should-close-itp-bug'
- unless @{ $entry->Closes };
- }
- my $changes = $entry->Changes;
- while ($changes =~ /(closes\s*(?:bug)?\#?\s?\d{6,})[^\w]/ig) {
- tag "possible-missing-colon-in-closes", "$1" if $1;
- }
-
- # Compare against NEWS.Debian if available.
- if ($news and $news->Version and $entry->Version eq $news->Version) {
- for my $field (qw/Distribution Urgency/) {
- if ($entry->$field ne $news->$field) {
- tag 'changelog-news-debian-mismatch', lc ($field),
- $entry->$field . ' != ' . $news->$field;
- }
- }
- }
-
- # We have to decode into UTF-8 to get the right length for the length
- # check. For some reason, use open ':utf8' isn't sufficient. If the
- # changelog uses a non-UTF-8 encoding, this will mangle it, but it doesn't
- # matter for the length check.
- #
- # Parse::DebianChangelog adds an additional space to the beginning of each
- # line, so we have to adjust for that in the length check.
- my @lines = split ("\n", decode ('utf-8', $changes));
- for my $i (0 .. $#lines) {
- if (length ($lines[$i]) > 81 && $lines[$i] !~ /^[\s.o*+-]*\S+$/) {
- tag 'debian-changelog-line-too-long', "line " . ($i + 1);
- }
- }
-
- # Strip out all lines that contain the word spelling to avoid false
- # positives on changelog entries for spelling fixes.
- $changes =~ s/^.*spelling.*\n//gm;
- spelling_check('spelling-error-in-changelog', $changes);
-}
-
-# read the changelog itself
-#
-# emacs only looks at the last "local variables" in a file, and only at
-# one within 3000 chars of EOF and on the last page (^L), but that's a bit
-# pesky to replicate. Demanding a match of $prefix and $suffix ought to
-# be enough to avoid false positives.
-open (IN, '<', "changelog")
- or fail("cannot find changelog for $type package $pkg");
-my ($prefix, $suffix);
-while (<IN>) {
-
- if (/closes:\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*)/io
- || /closes:\s*(?:bug)?\#?\s?\d+
- (?:,\s*(?:bug)?\#?\s?\d+)*
- (?:,\s*(((?:bug)?\#?\s?\d*)[[:alpha:]]\w*))/iox) {
- tag "wrong-bug-number-in-closes", "l$.:$1" if $2;
- }
-
- if (/^(.*)Local\ variables:(.*)$/i) {
- $prefix = $1;
- $suffix = $2;
- }
- # emacs allows whitespace between prefix and variable, hence \s*
- if (defined $prefix && defined $suffix
- && /^\Q$prefix\E\s*add-log-mailing-address:.*\Q$suffix\E$/) {
- tag "debian-changelog-file-contains-obsolete-user-emacs-settings";
- }
-}
-close IN;
-
-}
-
-1;
-
-# vim: syntax=perl ts=8 sw=4
projects / maemian / blobdiff