/usr/share/lintian/collection/changelog-file is in lintian 2.5.10.4.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | #!/usr/bin/perl -w
# changelog-file -- lintian collector script
# Copyright (C) 1998 Richard Braakman
#
# 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.
use strict;
use warnings;
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Util qw(fail gunzip_file);
($#ARGV == 2) or fail('syntax: changelog-file <pkg> <type> <dir>');
my ($pkg, $type, $dir) = @ARGV;
unlink "$dir/changelog" or fail "cannot remove changelog file: $!"
if -e "$dir/changelog" or -l "$dir/changelog";
# Pick the first of these files that exists.
my @changelogs = ("$dir/unpacked/usr/share/doc/$pkg/changelog.Debian.gz",
"$dir/unpacked/usr/share/doc/$pkg/changelog.Debian",
"$dir/unpacked/usr/share/doc/$pkg/changelog.debian.gz",
"$dir/unpacked/usr/share/doc/$pkg/changelog.debian",
"$dir/unpacked/usr/share/doc/$pkg/changelog.gz",
"$dir/unpacked/usr/share/doc/$pkg/changelog",
"$dir/unpacked/usr/doc/$pkg/changelog.Debian.gz",
"$dir/unpacked/usr/doc/$pkg/changelog.Debian",
"$dir/unpacked/usr/doc/$pkg/changelog.debian.gz",
"$dir/unpacked/usr/doc/$pkg/changelog.debian",
"$dir/unpacked/usr/doc/$pkg/changelog.gz",
"$dir/unpacked/usr/doc/$pkg/changelog");
my $chl;
for (@changelogs) {
if (-l $_ || -f $_) {
$chl = $_;
last;
}
}
# If the changelog file we found was a symlink, we have to be careful. It
# could be a symlink to some file outside of the laboratory and we don't want
# to end up reading that file by mistake. Relative links within the same
# directory or to a subdirectory we accept; anything else is replaced by an
# intentinally broken symlink so that checks can do the right thing.
if (defined ($chl) && -l $chl) {
my $link = readlink $chl or fail("cannot readlink $chl: $!");
if ($link =~ /\.\./ || ($link =~ m%/% && $link !~ m%^[^/]+(?:/+[^/]+)*\z%)) {
symlink ("$dir/file-is-in-another-package", "$dir/changelog")
or fail("cannot create changelog symlink: $!");
undef $chl;
} elsif (! -f $chl) {
undef $chl;
}
}
# If the changelog was a broken symlink, it will be undefined and we'll now
# treat it the same as if we didn't find a changelog and do nothing. If it
# was a symlink, copy the file, since otherwise the relative symlinks are
# going to break things.
if (not defined $chl) {
# no changelog found
} elsif ($chl =~ /\.gz$/) {
gunzip_file ($chl, "$dir/changelog");
} elsif (-f $chl && -l $chl) {
local $_;
open (CHL, '<', $chl) or fail("cannot open $chl: $!");
open (COPY, '>', "$dir/changelog") or fail "cannot create changelog: $!";
print COPY while <CHL>;
close CHL;
close (COPY) or fail("cannot write changelog: $!");
} else {
link ($chl, "$dir/changelog")
or fail("cannot link $chl to changelog: $!");
}
if ($chl && $chl !~ m/changelog\.debian/i) {
# Either this is a native package OR a non-native package where the
# debian changelog is missing. checks/changelog is not too happy
# with the latter case, so check looks like a Debian changelog.
open my $fd, '<', "$dir/changelog" or fail "Opening changelog: $!";
my $ok = 0;
while ( my $line = <$fd> ) {
next if $line =~ m/^\s*+$/o;
# look for something like
# lintian (2.5.3) UNRELEASED; urgency=low
if ($line =~ m/^\S+\s*\([^\)]+\)\s*(?:UNRELEASED|(?:[^ \t;]+\s*)+)\;/o) {
$ok = 1;
}
last;
}
close $fd;
# Remove it if it not the Debian changelog.
unlink "$dir/changelog" unless $ok;
}
# Extract NEWS.Debian files as well, with similar precautious. Ignore any
# symlinks to other packages here; in that case, we just won't check the file.
unlink "$dir/NEWS.Debian" or fail "cannot unlink NEWS.Debian: $!"
if -e "$dir/NEWS.Debian" or -l "$dir/NEWS.Debian";
my $news = "$dir/unpacked/usr/share/doc/$pkg/NEWS.Debian.gz";
if (-f $news) {
if (-l $news) {
my $link = readlink $news or fail("cannot readlink $chl: $!");
if ($link =~ /\.\./ || ($link =~ m%/% && $link !~ m%^[^/]+(?:/+[^/]+)*\z%)) {
undef $news;
} elsif (! -f $news) {
undef $news;
}
}
if ($news) {
gunzip_file ($news, "$dir/NEWS.Debian");
}
}
# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
|