vcs.maemo.org Git - maemian/blob - 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 Maemian::infofiles;
  23 use strict;
  24
  25 use lib "$ENV{'MAEMIAN_ROOT'}/checks/";
  26 use common_data;
  27
  28 use Tags;
  29 use Util;
  30 use File::Basename;
  31
  32 sub run {
  33
  34 my $pkg = shift;
  35 my $type = shift;
  36 my $info = shift;
  37
  38 my %preinst;
  39 my %postinst;
  40 my %prerm;
  41 my %postrm;
  42
  43 my %missing_section;
  44
  45 # check maintainer scripts (for install-info invocation)
  46 check_script("preinst", \%preinst) if (-f "control/preinst");
  47 check_script("postinst", \%postinst) if (-f "control/postinst");
  48 check_script("prerm", \%prerm) if (-f "control/prerm");
  49 check_script("postrm", \%postrm) if (-f "control/postrm");
  50
  51 # Read package contents...
  52 foreach my $file (sort keys %{$info->index}) {
  53     my $index_info = $info->index->{$file};
  54     my $file_info = $info->file_info->{$file};
  55     my $link = $index_info->{link} || '';
  56     my ($fname, $path, $suffix) = fileparse($file);
  57
  58     next unless ($index_info->{type} =~ m,^[\-lh],o)
  59             and ($path =~ m,^usr/share/info/, or $path =~ m,^usr/info/,);
  60
  61     # Analyze the file names making sure the documents are named properly.
  62     # Note that Emacs 22 added support for images in info files, so we have to
  63     # accept those and ignore them.  Just ignore .png files for now.
  64     my @fname_pieces = split /\./, $fname;
  65     my $ext = pop @fname_pieces;
  66     if ($ext eq "gz") { # ok!
  67         if ($index_info->{type} =~ m,^[-h],o) { # compressed with maximum compression rate?
  68             if ($file_info !~ m/gzip compressed data/o) {
  69                 tag "info-document-not-compressed-with-gzip", "$file";
  70             } else {
  71                 if ($file_info !~ m/max compression/o) {
  72                     tag "info-document-not-compressed-with-max-compression", "$file";
  73                 }
  74             }
  75         }
  76     } elsif ($ext eq 'png') {
  77         next;
  78     } else {
  79         push (@fname_pieces, $ext);
  80         tag "info-document-not-compressed", "$file";
  81     }
  82     my $infoext = pop @fname_pieces;
  83     unless ($infoext && $infoext =~ /info(-\d)?/) { # it's not foo.info
  84         unless (!@fname_pieces) { # it's not foo{,-{1,2,3,...}}
  85             tag "info-document-has-wrong-extension", "$file";
  86         }
  87     }
  88
  89     # If this is the main info file (no numeric extension). make sure it has
  90     # appropriate dir entry information.
  91     if ($fname !~ /-\d+\.gz/ && $file_info =~ /gzip compressed data/) {
  92         my $pid = open INFO, '-|';
  93         if (not defined $pid) {
  94             fail("cannot fork: $!");
  95         } elsif ($pid == 0) {
  96             my %newenv = (LANG => 'C', PATH => $ENV{PATH});
  97             undef %ENV;
  98             %ENV = %newenv;
  99             exec "zcat \Qunpacked/$file\E 2>&1"
 100                 or fail("cannot run zcat: $!");
 101         }
 102         local $_;
 103         my ($section, $start, $end);
 104         while (<INFO>) {
 105             $section = 1 if /INFO-DIR-SECTION\s+\S/;
 106         }
 107         close INFO;
 108         $missing_section{$file} = 1 unless $section;
 109     }
 110 }
 111
 112 # policy 13.2 says prerm and postinst
 113 if ($postrm{'calls-install-info'}) {
 114     tag "postrm-calls-install-info", "";
 115 }
 116 if ($preinst{'calls-install-info'}) {
 117     tag "preinst-calls-install-info", "";
 118 }
 119
 120 if ($postinst{'calls-install-info'}) {
 121     tag "install-info-not-called-with-quiet-option", ""
 122         unless $postinst{'calls-install-info-quiet'};
 123 }
 124 if ($prerm{'calls-install-info'}) {
 125     # it must use the --quiet option
 126     tag "install-info-not-called-with-quiet-option", ""
 127         unless $prerm{'calls-install-info-quiet'};
 128 }
 129
 130 # Currently we assume all the info pages are fine if any of them are installed
 131 # with an explicit --section option.  It would be nice to be stricter.
 132 for my $file (keys %missing_section) {
 133     tag "info-document-missing-dir-section", "$file"
 134         unless ($postinst{'calls-install-info-section'});
 135 }
 136
 137 # Ideally we'd check whether all documents installed are removed,
 138 # but for now we assume that if any are removed then they all are
 139 if ($postinst{'calls-install-info'}) {
 140     tag "info-documents-not-removed", ""
 141         unless ($prerm{'calls-install-info-remove'});
 142 }
 143
 144 }
 145
 146 # -----------------------------------
 147
 148 sub check_script {
 149     my ($script,$pres) = @_;
 150     my ($no_check_menu,$no_check_installdocs);
 151     my $interp;
 152
 153     open(IN, '<', "control/$script") or
 154         fail("cannot open maintainer script control/$script for reading: $!");
 155     $interp = <IN>;
 156     $interp = '' unless defined $interp;
 157     if ($interp =~ m,^\#\!\s*/bin/$known_shells_regex,) {
 158         $interp = 'sh';
 159     } elsif ($interp =~ m,^\#\!\s*/usr/bin/perl,) {
 160         $interp = 'perl';
 161     } else {
 162         if ($interp =~ m,^\#\!\s*(.+),) {
 163             $interp = $1;
 164         }
 165         else { # hmm, doesn't seem to start with #!
 166             # is it a binary? look for ELF header
 167             if ($interp =~ m/^\177ELF/) {
 168                 return; # nothing to do here
 169             }
 170             $interp = 'unknown';
 171         }
 172     }
 173
 174     my $hold;
 175     while (<IN>) {
 176         s/\s+#.*$//;
 177         # this wraps a previous line continuation into the current line
 178         if (defined $hold) {
 179             $_ = "$hold $_";
 180             $hold = undef;
 181         }
 182         # check if install-info is called and if so, is it called properly
 183         if (m/install-info/o) {
 184             if (m,\\$,) {
 185                 $hold = substr($_, 0, -1);
 186                 next;
 187             }
 188             $pres->{'calls-install-info'} = 1;
 189             my @pieces = split(/\s+/);
 190             for my $piece (@pieces) {
 191                 if ($piece eq '--quiet') {
 192                     $pres->{'calls-install-info-quiet'} = 1;
 193                 } elsif ($piece eq '--section') {
 194                     $pres->{'calls-install-info-section'} = 1;
 195                 } elsif ($piece eq '--remove' or $piece eq '--remove-exactly') {
 196                     $pres->{'calls-install-info-remove'} = 1;
 197                 }
 198             }
 199         }
 200     }
 201     close IN;
 202 }
 203
 204 1;
 205
 206 # vim: syntax=perl