# menus -- lintian check script

# somewhat of a misnomer -- it doesn't only check menus

# Copyright (C) 1998 Christian Schwarz
#
# 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., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

package Lintian::menus;
use strict;
use Tags;
use Util;

my $pkg;

sub run {

$pkg = shift;
my $type = shift;

my %preinst;
my %postinst;
my %prerm;
my %postrm;

my $docbase_file;
my $menu_file;
my $menumethod_file;
my $anymenu_file;

# check preinst script
if ( -f "control/preinst" ) {
    # parse script...
    check_script("preinst",\%preinst);
}

# check postinst script
if ( -f "control/postinst" ) {
    # parse script...
    check_script("postinst",\%postinst);
}

# check prerm script
if ( -f "control/prerm" ) {
    # parse script...
    check_script("prerm",\%prerm);
}

# check postrm script
if ( -f "control/postrm" ) {
    # parse script...
    check_script("postrm",\%postrm);
}

# read package contents
open(IN,"index") or fail("cannot open index file index: $!");
while (<IN>) {
    chomp;
    my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
    $file =~ s,^(\./),,;
    my $temp_file = $file; # save this for the link checks to follow
    $file =~ s/ link to .*//;
    $file =~ s/ -> .*//;

    my $operm = perm2oct($perm);

    if ($perm =~ m,^-,o) { # file checks
	# menu file?
	if ($file =~ m,^usr/lib/menu/\S,o) { # correct permissions?
	    if ($perm =~ m,x,o) {
		tag "executable-in-usr-lib-menu", sprintf("$file %04o",$operm);
	    }

	    next if $file eq 'usr/lib/menu/README';

	    $menu_file = $file;

	    if ($file eq 'usr/lib/menu/menu' and $pkg ne 'menu') {
		tag "bad-menu-file-name", $file;
	    }
	}
	# doc-base file?
	elsif ($file =~ m,^usr/share/doc-base/\S,o) { # correct permissions?
	    if ($perm =~ m,x,o) {
		tag "executable-in-usr-share-docbase", $file, sprintf("%04o",$operm);
	    }

	    $docbase_file = $file;
	}
	#menu-methods file?
	elsif ( $file =~ m,^etc/menu-methods/\S,o ) {
	    #TODO: we should test if the menu-methods file
	    # is made executable in the postinst as recommended by
	    # the menu manual

	    $menumethod_file = $file;
	}
    }
}

# prerm scripts should not call update-menus
if ($prerm{'calls-updatemenus'}) {
    tag "prerm-calls-updatemenus", "";
}

# postrm scripts should not call install-docs
if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
    tag "postrm-calls-installdocs", "";
}

# preinst scripts should not call either update-menus nor installdocs
if ($preinst{'calls-updatemenus'}) {
    tag "preinst-calls-updatemenus", "";
}

if ($preinst{'calls-installdocs'}) {
    tag "preinst-calls-installdocs", "";
}

# don't set the /usr/doc link, the FHS transition is over (2002-10-08)
if (defined $postinst{'sets-link'} && $postinst{'sets-link'} == 1) {
    tag "postinst-should-not-set-usr-doc-link", "";
}

$anymenu_file = $menu_file || $menumethod_file;

# check consistency
# docbase file?
if ($docbase_file) {		# postinst has to call install-docs
    if (not $postinst{'calls-installdocs'}) {
	tag "postinst-does-not-call-installdocs", "$docbase_file";
    }
    # prerm has to call install-docs -r
    if (not $prerm{'calls-installdocs-r'}) {
	tag "prerm-does-not-call-installdocs", "$docbase_file";
    }

    # does postinst also call update-menus?
    if ($postinst{'calls-updatemenus'}) {
	# is there a menu file or menu-methods files?
    	if ($anymenu_file) { 	# postrm has to call update-menus
	    if (not $postrm{'calls-updatemenus'}) {
		tag "postrm-does-not-call-updatemenus", "$anymenu_file" unless $pkg eq 'menu';
	    }
    	} else { #no!
	    tag "postinst-has-useless-call-to-update-menus", "";
	}
    }

    # check the contents of the doc-base file(s)
    opendir DOCBASEDIR, "doc-base" or fail("cannot read doc-base directory.");
    while (my $dbfile = readdir DOCBASEDIR) {
        next if -x "doc-base/$dbfile"; # don't try to parse executables, plus we already warned about it
        open IN, "doc-base/$dbfile" or
            fail("cannot open doc-base file $dbfile for reading.");
        while (<IN>) {
            if (/usr\/doc/) {
                tag "doc-base-file-references-usr-doc", "$dbfile";
            }
        }
        close IN;
    }
    closedir DOCBASEDIR;
}
# no docbase file, but menu file?
elsif ($anymenu_file) { 	# postinst has to call update-menus
    if (not $postinst{'calls-updatemenus'}) {
	tag "postinst-does-not-call-updatemenus", "$anymenu_file";
    }
    # postrm has to call update-menus
    if (not $postrm{'calls-updatemenus'}) {
	tag "postrm-does-not-call-updatemenus", "$anymenu_file";
    }
}
# no menu files and no doc-base files...
else {
    # postinst and postrm should not need to call update-menus
    if ($postinst{'calls-updatemenus'}) {
	tag "postinst-has-useless-call-to-update-menus", "";
    }
    if ($postinst{'calls-installdocs'} or $postinst{'calls-installdocs-r'}) {
	tag "postinst-has-useless-call-to-install-docs", "";
    }
    if ($postrm{'calls-updatemenus'}) {
	tag "postrm-has-useless-call-to-update-menus", "";
    }
    if ($postrm{'calls-installdocs'} or $postrm{'calls-installdocs-r'}) {
	tag "postrm-has-useless-call-to-install-docs", "";
    }
}

}

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

# translate permission strings like `-rwxrwxrwx' into an octal number
sub perm2oct {
    my ($t) = @_;

    my $o = 0;

    $t =~ /^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/o;

    $o += 04000 if $3 eq 's';	# set-uid
    $o += 02000 if $6 eq 's';	# set-gid
    $o += 01000 if $9 eq 't';	# sticky bit
    $o += 00400 if $1 ne '-';	# owner read
    $o += 00200 if $2 ne '-';	# owner write
    $o += 00100 if $3 ne '-';	# owner execute
    $o += 00040 if $4 ne '-';	# owner read
    $o += 00020 if $5 ne '-';	# owner write
    $o += 00010 if $6 ne '-';	# owner execute
    $o += 00004 if $7 ne '-';	# owner read
    $o += 00002 if $8 ne '-';	# owner write
    $o += 00001 if $9 ne '-';	# owner execute

    return $o;
}

sub check_script {
    my ($script,$pres) = @_;
    my ($no_check_menu,$no_check_installdocs,$no_check_wmmenu,$calls_wmmenu);
    my $interp;

    open(IN,"control/$script") or
	fail("cannot open maintainer script control/$script for reading: $!");
    $interp = <IN>;
    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';
	}
	tag "unknown-interpreter", $script, $interp;
    }

    while (<IN>) {
	# skip comments
	s/\#.*$//o;

	##
	# either update-menus or wm-menu-config will satisfy
	# the checks that the menu file installed is properly used
	##

	# does the script check whether update-menus exists?
	if (/-x\s+\S*update-menus/o or /(which|command)(\s+\S+)?\s+update-menus/o) {
	    # yes, it does.
	    $pres->{'checks-for-updatemenus'} = 1;
	}

	# does the script call update-menus?
	# TODO this regex-magic should be moved to some lib for checking
	# whether a certain word is likely called as command... --Jeroen
	if (/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/bin\/)?update-menus(?:\s|[;&|<>]|$)/) {
	    # yes, it does.
	    $pres->{'calls-updatemenus'} = 1;

	    # checked first?
	    if (not $pres->{'checks-for-updatemenus'} and $pkg ne 'menu') {
		tag "maintainer-script-does-not-check-for-existence-of-updatemenus", "$script:$." unless $no_check_menu++;
	    }
	}

	# does the script check whether wm-menu-config exists?
	if (s/-x\s+\S*wm-menu-config//o or /which\s+wm-menu-config/o
	    or s/command\s+.*?wm-menu-config//o) {
	    # yes, it does.
	    $pres->{'checks-for-wmmenuconfig'} = 1;
	}

	# does the script call wm-menu-config?
	if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?wm-menu-config(?:\s|[;&|<>]|$)/) {
	    # yes, it does.
	    $pres->{'calls-wmmenuconfig'} = 1;
	    tag "maintainer-script-calls-deprecated-wm-menu-config", "$script:$." unless $calls_wmmenu++;

	    # checked first?
	    if (not $pres->{'checks-for-wmmenuconfig'} and $pkg ne 'menu') {
		tag "maintainer-script-does-not-check-for-existence-of-wm-menu-config", "$script:$." unless $no_check_wmmenu++;
	    }
	}

	# does the script set a link in /usr/doc?
	# does the script remove a link in /usr/doc?
	if ($interp eq 'sh') {
	    if (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) {
		$pres->{'sets-link'} = 1;
	    }
	    if (m,rm\s+(-\w+\s+)?\"?/usr/doc/\S+, ) {
		$pres->{'removes-link'} = 1;
	    }
	} elsif ($interp eq 'perl') {
	    if (m|symlink\s*\(?\s*[\"\']\.\./share/doc/\.+?[\"\']\s*,|) {
		$pres->{'sets-link'} = 1;
	    } elsif (m,ln\s+(-\w+)?\s+\"?\.\./share/doc/\S+, ) {
		$pres->{'sets-link'} = 1;
	    }
	} else {
	    # just fall through for now
	}

	# does the script check whether install-docs exists?
	if (s/-x\s+\S*install-docs//o or /which\s+install-docs/o
	    or s/command\s+.*?install-docs//o) {
	    # yes, it does.
	    $pres->{'checks-for-installdocs'} = 1;
	}

	# does the script call install-docs?
	if (m/(?:^\s*|[;&|]\s*|(?:then|do)\s+)(?:\/usr\/sbin\/)?install-docs(?:\s|[;&|<>]|$)/) {
	    # yes, it does.  Does it remove or add a doc?
	    if (m/install-docs\s+(-r|--remove)\s/) {
		$pres->{'calls-installdocs-r'} = 1;
	    } else {
		$pres->{'calls-installdocs'} = 1;
	    }
	    # checked first?
	    if (not $pres->{'checks-for-installdocs'}) {
		tag "maintainer-script-does-not-check-for-existence-of-installdocs", "$script" unless $no_check_installdocs++;
	    }
	}
    }
    close IN;
}

1;

# vim: syntax=perl
