+++ /dev/null
-# 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 (<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,/info/,o;
- $file =~ s,^(\./)?,,;
-
- $file_info{$file} = $info;
-}
-close IN;
-
-# Read package contents...
-open (IN, '<', "index") or fail("cannot open index file index: $!");
-while (<IN>) {
- 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 (<INFO>) {
- $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 = <IN>;
- $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 (<IN>) {
- 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
projects / maemian / blobdiff