# 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'});
}

}

# -----------------------------------

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') {
		    $pres->{'calls-install-info-remove'} = 1;
		}
	    }
	}
    }
    close IN;
}

1;

# vim: syntax=perl
