vcs.maemo.org Git - maemian/blob - nokia-lintian/checks/infofiles

   1 # infofiles -- lintian check script -*- perl -*-
   2
   3 # Copyright (C) 1998 Christian Schwarz
   4 # Copyright (C) 2001 Josip Rodin
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License
  17 # along with this program.  If not, you can find it on the World Wide
  18 # Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
  19 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  20 # MA 02110-1301, USA.
  21
  22 package Lintian::infofiles;
  23 use strict;
  24 use Tags;
  25 use Util;
  26 use File::Basename;
  27
  28 sub run {
  29
  30 my $pkg = shift;
  31 my $type = shift;
  32
  33 my %file_info;
  34
  35 my %preinst;
  36 my %postinst;
  37 my %prerm;
  38 my %postrm;
  39
  40 my %missing_section;
  41
  42 # check maintainer scripts (for install-info invocation)
  43 check_script("preinst", \%preinst) if (-f "control/preinst");
  44 check_script("postinst", \%postinst) if (-f "control/postinst");
  45 check_script("prerm", \%prerm) if (-f "control/prerm");
  46 check_script("postrm", \%postrm) if (-f "control/postrm");
  47
  48 # Read file info...
  49 open (IN, '<', "file-info")
  50     or fail("cannot find file-info for $type package $pkg");
  51 while (<IN>) {
  52     chop;
  53
  54     m/^(.*?):\s+(.*)$/o or fail("an error in the file pkg is preventing lintian from checking this package: $_");
  55     my ($file,$info) = ($1,$2);
  56
  57     next unless $file =~ m,/info/,o;
  58     $file =~ s,^(\./)?,,;
  59
  60     $file_info{$file} = $info;
  61 }
  62 close IN;
  63
  64 # Read package contents...
  65 open (IN, '<', "index") or fail("cannot open index file index: $!");
  66 while (<IN>) {
  67     chop;
  68
  69     my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
  70     my $link;
  71
  72     $file =~ s,^(\./),,;
  73     $file =~ s/ link to .*//;
  74
  75     if ($perm =~ m/^l/) {
  76         ($file, $link) = split(' -> ', $file);
  77     }
  78
  79     my ($fname, $path, $suffix) = fileparse($file);
  80
  81     next unless ($perm =~ m,^[\-l],o)
  82             and ($path =~ m,^usr/share/info/, or $path =~ m,^usr/info/,);
  83
  84     # Analyze the file names making sure the documents are named properly.
  85     # Note that Emacs 22 added support for images in info files, so we have to
  86     # accept those and ignore them.  Just ignore .png files for now.
  87     my @fname_pieces = split /\./, $fname;
  88     my $ext = pop @fname_pieces;
  89     if ($ext eq "gz") { # ok!
  90         if ($perm =~ m,^-,o) { # compressed with maximum compression rate?
  91             my $info = $file_info{$file};
  92             if ($info !~ m/gzip compressed data/o) {
  93                 tag "info-document-not-compressed-with-gzip", "$file";
  94             } else {
  95                 if ($info !~ m/max compression/o) {
  96                     tag "info-document-not-compressed-with-max-compression", "$file";
  97                 }
  98             }
  99         }
 100     } elsif ($ext eq 'png') {
 101         next;
 102     } else {
 103         push (@fname_pieces, $ext);
 104         tag "info-document-not-compressed", "$file";
 105     }
 106     my $infoext = pop @fname_pieces;
 107     unless ($infoext && $infoext =~ /info(-\d)?/) { # it's not foo.info
 108         unless (!@fname_pieces) { # it's not foo{,-{1,2,3,...}}
 109             tag "info-document-has-wrong-extension", "$file";
 110         }
 111     }
 112
 113     # If this is the main info file (no numeric extension). make sure it has
 114     # appropriate dir entry information.
 115     if ($fname !~ /-\d+\.gz/ && $file_info{$file} =~ /gzip compressed data/) {
 116         my $pid = open INFO, '-|';
 117         if (not defined $pid) {
 118             fail("cannot fork: $!");
 119         } elsif ($pid == 0) {
 120             my %newenv = (LANG => 'C', PATH => $ENV{PATH});
 121             undef %ENV;
 122             %ENV = %newenv;
 123             exec "zcat \Qunpacked/$file\E 2>&1"
 124                 or fail("cannot run zcat: $!");
 125         }
 126         local $_;
 127         my ($section, $start, $end);
 128         while (<INFO>) {
 129             $section = 1 if /INFO-DIR-SECTION\s+\S/;
 130         }
 131         close INFO;
 132         $missing_section{$file} = 1 unless $section;
 133     }
 134 }
 135 close IN;
 136
 137 # policy 13.2 says prerm and postinst
 138 if ($postrm{'calls-install-info'}) {
 139     tag "postrm-calls-install-info", "";
 140 }
 141 if ($preinst{'calls-install-info'}) {
 142     tag "preinst-calls-install-info", "";
 143 }
 144
 145 if ($postinst{'calls-install-info'}) {
 146     tag "install-info-not-called-with-quiet-option", ""
 147         unless $postinst{'calls-install-info-quiet'};
 148 }
 149 if ($prerm{'calls-install-info'}) {
 150     # it must use the --quiet option
 151     tag "install-info-not-called-with-quiet-option", ""
 152         unless $prerm{'calls-install-info-quiet'};
 153 }
 154
 155 # Currently we assume all the info pages are fine if any of them are installed
 156 # with an explicit --section option.  It would be nice to be stricter.
 157 for my $file (keys %missing_section) {
 158     tag "info-document-missing-dir-section", "$file"
 159         unless ($postinst{'calls-install-info-section'});
 160 }
 161
 162 # Ideally we'd check whether all documents installed are removed,
 163 # but for now we assume that if any are removed then they all are
 164 if ($postinst{'calls-install-info'}) {
 165     tag "info-documents-not-removed", ""
 166         unless ($prerm{'calls-install-info-remove'});
 167 }
 168
 169 }
 170
 171 # -----------------------------------
 172
 173 sub check_script {
 174     my ($script,$pres) = @_;
 175     my ($no_check_menu,$no_check_installdocs);
 176     my $interp;
 177
 178     open(IN, '<', "control/$script") or
 179         fail("cannot open maintainer script control/$script for reading: $!");
 180     $interp = <IN>;
 181     $interp = '' unless defined $interp;
 182     if ($interp =~ m,^\#\!\s*/bin/(a|ba|k|pdk)?sh,) {
 183         $interp = 'sh';
 184     } elsif ($interp =~ m,^\#\!\s*/usr/bin/perl,) {
 185         $interp = 'perl';
 186     } else {
 187         if ($interp =~ m,^\#\!\s*(.+),) {
 188             $interp = $1;
 189         }
 190         else { # hmm, doesn't seem to start with #!
 191             # is it a binary? look for ELF header
 192             if ($interp =~ m/^\177ELF/) {
 193                 return; # nothing to do here
 194             }
 195             $interp = 'unknown';
 196         }
 197     }
 198
 199     my $hold;
 200     while (<IN>) {
 201         s/\s+#.*$//;
 202         # this wraps a previous line continuation into the current line
 203         if (defined $hold) {
 204             $_ = "$hold $_";
 205             $hold = undef;
 206         }
 207         # check if install-info is called and if so, is it called properly
 208         if (m/install-info/o) {
 209             if (m,\\$,) {
 210                 $hold = substr($_, 0, -1);
 211                 next;
 212             }
 213             $pres->{'calls-install-info'} = 1;
 214             my @pieces = split(/\s+/);
 215             for my $piece (@pieces) {
 216                 if ($piece eq '--quiet') {
 217                     $pres->{'calls-install-info-quiet'} = 1;
 218                 } elsif ($piece eq '--section') {
 219                     $pres->{'calls-install-info-section'} = 1;
 220                 } elsif ($piece eq '--remove' or $piece eq '--remove-exactly') {
 221                     $pres->{'calls-install-info-remove'} = 1;
 222                 }
 223             }
 224         }
 225     }
 226     close IN;
 227 }
 228
 229 1;
 230
 231 # vim: syntax=perl