X-Git-Url: http://vcs.maemo.org/git/?a=blobdiff_plain;f=nokia-lintian%2Fchecks%2Finfofiles;fp=nokia-lintian%2Fchecks%2Finfofiles;h=2be4b22bfad40f45d6767f6fcffe5475e20455e1;hb=1975b83207a518d59ef6b04c7c16233cb353ca86;hp=0000000000000000000000000000000000000000;hpb=208f636c44e0ec2b53c70aaed2399d8e9cf0e741;p=maemian diff --git a/nokia-lintian/checks/infofiles b/nokia-lintian/checks/infofiles new file mode 100644 index 0000000..2be4b22 --- /dev/null +++ b/nokia-lintian/checks/infofiles @@ -0,0 +1,231 @@ +# infofiles -- lintian check script -*- perl -*- + +# Copyright (C) 1998 Christian Schwarz +# Copyright (C) 2001 Josip Rodin +# +# 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::infofiles; +use strict; +use Tags; +use Util; +use File::Basename; + +sub run { + +my $pkg = shift; +my $type = shift; + +my %file_info; + +my %preinst; +my %postinst; +my %prerm; +my %postrm; + +my %missing_section; + +# check maintainer scripts (for install-info invocation) +check_script("preinst", \%preinst) if (-f "control/preinst"); +check_script("postinst", \%postinst) if (-f "control/postinst"); +check_script("prerm", \%prerm) if (-f "control/prerm"); +check_script("postrm", \%postrm) if (-f "control/postrm"); + +# Read file info... +open (IN, '<', "file-info") + or fail("cannot find file-info for $type package $pkg"); +while () { + 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,/info/,o; + $file =~ s,^(\./)?,,; + + $file_info{$file} = $info; +} +close IN; + +# Read package contents... +open (IN, '<', "index") or fail("cannot open index file index: $!"); +while () { + chop; + + my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6); + my $link; + + $file =~ s,^(\./),,; + $file =~ s/ link to .*//; + + if ($perm =~ m/^l/) { + ($file, $link) = split(' -> ', $file); + } + + my ($fname, $path, $suffix) = fileparse($file); + + next unless ($perm =~ m,^[\-l],o) + and ($path =~ m,^usr/share/info/, or $path =~ m,^usr/info/,); + + # Analyze the file names making sure the documents are named properly. + # Note that Emacs 22 added support for images in info files, so we have to + # accept those and ignore them. Just ignore .png files for now. + my @fname_pieces = split /\./, $fname; + my $ext = pop @fname_pieces; + if ($ext eq "gz") { # ok! + if ($perm =~ m,^-,o) { # compressed with maximum compression rate? + my $info = $file_info{$file}; + if ($info !~ m/gzip compressed data/o) { + tag "info-document-not-compressed-with-gzip", "$file"; + } else { + if ($info !~ m/max compression/o) { + tag "info-document-not-compressed-with-max-compression", "$file"; + } + } + } + } elsif ($ext eq 'png') { + next; + } else { + push (@fname_pieces, $ext); + tag "info-document-not-compressed", "$file"; + } + my $infoext = pop @fname_pieces; + unless ($infoext && $infoext =~ /info(-\d)?/) { # it's not foo.info + unless (!@fname_pieces) { # it's not foo{,-{1,2,3,...}} + tag "info-document-has-wrong-extension", "$file"; + } + } + + # If this is the main info file (no numeric extension). make sure it has + # appropriate dir entry information. + if ($fname !~ /-\d+\.gz/ && $file_info{$file} =~ /gzip compressed data/) { + my $pid = open INFO, '-|'; + if (not defined $pid) { + fail("cannot fork: $!"); + } elsif ($pid == 0) { + my %newenv = (LANG => 'C', PATH => $ENV{PATH}); + undef %ENV; + %ENV = %newenv; + exec "zcat \Qunpacked/$file\E 2>&1" + or fail("cannot run zcat: $!"); + } + local $_; + my ($section, $start, $end); + while () { + $section = 1 if /INFO-DIR-SECTION\s+\S/; + } + close INFO; + $missing_section{$file} = 1 unless $section; + } +} +close IN; + +# policy 13.2 says prerm and postinst +if ($postrm{'calls-install-info'}) { + tag "postrm-calls-install-info", ""; +} +if ($preinst{'calls-install-info'}) { + tag "preinst-calls-install-info", ""; +} + +if ($postinst{'calls-install-info'}) { + tag "install-info-not-called-with-quiet-option", "" + unless $postinst{'calls-install-info-quiet'}; +} +if ($prerm{'calls-install-info'}) { + # it must use the --quiet option + tag "install-info-not-called-with-quiet-option", "" + unless $prerm{'calls-install-info-quiet'}; +} + +# Currently we assume all the info pages are fine if any of them are installed +# with an explicit --section option. It would be nice to be stricter. +for my $file (keys %missing_section) { + tag "info-document-missing-dir-section", "$file" + unless ($postinst{'calls-install-info-section'}); +} + +# Ideally we'd check whether all documents installed are removed, +# but for now we assume that if any are removed then they all are +if ($postinst{'calls-install-info'}) { + tag "info-documents-not-removed", "" + unless ($prerm{'calls-install-info-remove'}); +} + +} + +# ----------------------------------- + +sub check_script { + my ($script,$pres) = @_; + my ($no_check_menu,$no_check_installdocs); + my $interp; + + open(IN, '<', "control/$script") or + fail("cannot open maintainer script control/$script for reading: $!"); + $interp = ; + $interp = '' unless defined $interp; + if ($interp =~ m,^\#\!\s*/bin/(a|ba|k|pdk)?sh,) { + $interp = 'sh'; + } elsif ($interp =~ m,^\#\!\s*/usr/bin/perl,) { + $interp = 'perl'; + } else { + if ($interp =~ m,^\#\!\s*(.+),) { + $interp = $1; + } + else { # hmm, doesn't seem to start with #! + # is it a binary? look for ELF header + if ($interp =~ m/^\177ELF/) { + return; # nothing to do here + } + $interp = 'unknown'; + } + } + + my $hold; + while () { + s/\s+#.*$//; + # this wraps a previous line continuation into the current line + if (defined $hold) { + $_ = "$hold $_"; + $hold = undef; + } + # check if install-info is called and if so, is it called properly + if (m/install-info/o) { + if (m,\\$,) { + $hold = substr($_, 0, -1); + next; + } + $pres->{'calls-install-info'} = 1; + my @pieces = split(/\s+/); + for my $piece (@pieces) { + if ($piece eq '--quiet') { + $pres->{'calls-install-info-quiet'} = 1; + } elsif ($piece eq '--section') { + $pres->{'calls-install-info-section'} = 1; + } elsif ($piece eq '--remove' or $piece eq '--remove-exactly') { + $pres->{'calls-install-info-remove'} = 1; + } + } + } + } + close IN; +} + +1; + +# vim: syntax=perl