#!/usr/bin/perl
# scripts -- lintian check script
#
# This is probably the right file to add a check for bashisms.
# And also to check for the use of set -e in bash and sh scripts.
#
# TODO:
#   Smarter handling of packages that provide tclsh and wish?

# Copyright (C) 1998 by Richard Braakman
# 
# 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.

# Don't forget to edit the scripts.desc file if you change these!

%valid_interpreters =
    ('sh' => '/bin/sh',
     'bash' => '/bin/bash',
     'csh' => '/bin/csh',
     'tcsh' => '/usr/bin/tcsh',
     'ksh' => '/usr/bin/ksh',
     'zsh' => '/usr/bin/zsh',
     'ash' => '/bin/ash',
     'sed' => '/bin/sed',
     'perl' => '/usr/bin/perl',
     'suidperl' => '/usr/bin/suidperl',
     'env' => '/usr/bin/env',
     'awk' => '/usr/bin/awk',
     'nawk' => '/usr/bin/nawk',
     'gawk' => '/usr/bin/gawk',
     'mawk' => '/usr/bin/mawk',
     'wish' => '/usr/bin/wish',
     'tclsh' => '/usr/bin/tclsh',
     'rc' => '/usr/bin/rc',
     'python' => '/usr/bin/python',
     'pike' => '/usr/bin/pike',
     'install-menu' => '/usr/sbin/install-menu',
     'rexx' => '/usr/bin/rexx',
     'regina' => '/usr/bin/regina',
     'burlap' => '/usr/bin/burlap',
     'make' => '/usr/bin/make',
     'wish8.0' => '/usr/bin/wish8.0',
     'bltwish' => '/usr/bin/bltwish',
     'install-fvwmgenmenu' => '/usr/sbin/install-fvwmgenmenu',
     'trs' => '/usr/bin/trs',
     'expect' => '/usr/bin/expect',
     'guile' => '/usr/bin/guile',
     'scsh' => '/usr/bin/scsh',
     'js' => '/usr/bin/js',
     );

%interpreter_dependencies =
    ('csh' => 'c-shell',
     'tcsh' => 'tcsh',
     'ksh' => 'pdksh',
     'zsh' => 'zsh',
     'ash' => 'ash',
     'wish' => 'wish',
     'tclsh' => 'tclsh',
     'suidperl' => 'perl-suid',
     'gawk' => 'gawk',
     'mawk' => 'mawk',
     'rc' => 'rc',
     'rexx' => 'regina-rexx',
     'regina' => 'regina-rexx',
     'burlap' => 'felt',
     'pike' => 'pike',
     'make' => 'make',
     'wish8.0' => 'tk8.0',
     'bltwish' => 'blt8.0',
     'trs' => 'konwert',
     'expect' => 'expect',
     'guile' => 'guile',
     'scsh' => 'scsh',
     'js' => 'ngs-js'
    );
# no dependency for install-menu, because the menu package specifically
# says not to depend on it.
# dependency for python is a special case, since both python and python-base
# are ok.  (perhaps check for a versioned dependency on virtual package
# python, and warn?)  (No, a generic check for versioned dependencies on
# virtual packages would be more useful.)

($#ARGV == 1) or fail("syntax: field <pkg> <type>");
$pkg = shift;
$type = shift;

open(INDEX, "index") or fail("cannot open lintian index file: $!");
%executable = ();
while (<INDEX>) {
    next unless (/^-[rw-]*[xs]/);
    chop;
    s/ link to .*//;
    $executable{(split(' ', $_, 6))[5]} = 1;
}
close(INDEX);

# Urgle... this is ambiguous, since the sequence ": " can occur in 
# the output of file and also in the filename.
# Fortunately no filenames containing ": " currently occur in Debian packages.
open(FILEINFO, "file-info") or fail("cannot open lintian file-info file: $!");
%ELF = ();
while (<FILEINFO>) {
    next unless (/\bELF\b/);
    /^(.*?): / or fail("bad line in file-info: $_");
    $ELF{$1} = 1;
}
close(FILEINFO);

# If alternatives are used, they are each listed as a separate dependency.
# This is the best thing to do with the tk/tcl interpreters, which
# are often listed with dependencies like tk41|tk42|wish.
# They are also the only interpreters likely to be listed with alternatives.
%deps = ();
foreach $depfield ('suggests', 'recommends', 'depends', 'pre-depends',
		   'provides') {
    if (open(IN, "fields/$depfield")) {
	$_ = join('', <IN>);
	close(IN);
	foreach (split /\s*[,|]\s*/) {
	    # Lop off version number, if any
	    s/(?:\s|\().*//s;
	    $deps{$_} = $depfield;
	}
    }
}
$deps{$pkg} = 'self';  # Do this last because it should override all others.

open(SCRIPTS, "scripts") or fail("cannot open lintian scripts file: $!");
%scripts = ();
while (<SCRIPTS>) {
    chop;

    # This used to be split(' ', $_, 2), but that didn't handle empty
    # interpreter lines correctly.
    /^(\S*) (.*)$/ or fail("bad line in scripts file: $_");
    $interpreter = $1;
    $filename = $2;
    $scripts{$filename} = 1;

    ($base) = $interpreter =~ m,([^/]*)$,;

    if ($interpreter eq "") {
	tag_error("script-without-interpreter", $filename);
	next;
    }

    # allow exception for .in files that have stuff like #!@PERL@
    next if $filename =~ m,\.in$, and $interpreter =~ m,^\@[A-Z_]+\@$,;

    tag_error("interpreter-not-absolute", $filename, "#!$interpreter")
	unless $interpreter =~ m,^/,;

    tag_warn("script-not-executable", $filename)
	unless ($executable{$filename}
		or $filename =~ m|usr/doc/[^/]+/examples/|
		or $filename =~ m|usr/lib/.*\.pm|);

    if (exists $valid_interpreters{$base}) {
	tag_error("wrong-path-for-$base", $filename, "#!$interpreter")
	    unless ($interpreter eq $valid_interpreters{$base});

	# Do not complain about dependencies for non-executable scripts.
	if ($executable{$filename}) {
	    if ($filename =~ m|usr/doc/[^/]+/examples/|) {
		# no dependency is needed for examples
	    } elsif (exists $interpreter_dependencies{$base}) {
		$dep = $interpreter_dependencies{$base};
		tag_error("$base-script-but-no-$dep-dep", $filename)
		    unless ($deps{$dep});
	    } elsif ($base eq 'python') {
		tag_error("python-script-but-no-python-dep", $filename)
		    unless ($deps{'python'} or $deps{'python-base'});
	    }
	}
	    
    } elsif ($interpreter =~ m|/usr/local/|) {
	tag_error("interpreter-in-usr-local", $filename, "#!$interpreter");
    } elsif ($executable{substr($interpreter, 1)}) {
	# Package installs the interpreter itself, so it's probably ok.
	# Don't emit any tag for this.
    } else {
	tag_warn("unusual-interpreter", $filename, "#!$interpreter");
    }

    tag_warn("csh-considered-harmful", $filename)
        if (($base eq 'csh' or $base eq 'tcsh') and $executable{$filename});
}
close(SCRIPTS);

foreach (keys %executable) {
    tag_warn("executable-not-elf-or-script", $_)
	unless $ELF{$_} or $scripts{$_} or $_ =~ m,^usr(/X11R6)?/man/,;
}

open(SCRIPTS, "control-scripts")
    or fail("cannot open lintian control-scripts file: $!");

# Handle control scripts.  This is an edited version of the code for
# normal scripts above, because there were just enough differences to
# make a shared function awkward.

while (<SCRIPTS>) {
    chop;

    /^(\S*) (.*)$/ or fail("bad line in control-scripts file: $_");
    $interpreter = $1;
    $filename = "control/$2";

    $interpreter =~ m|([^/]*)$|;
    $base = $1;

    if ($interpreter eq "") {
	tag_error("script-without-interpreter", $filename);
	next;
    }

    tag_error("interpreter-not-absolute", $filename, "#!$interpreter")
	unless ($interpreter =~ m|^/|);

    if (exists $valid_interpreters{$base}) {
	tag_error("wrong-path-for-$base", $filename, "#!$interpreter")
	    unless ($interpreter eq $valid_interpreters{$base});

	print "I: $pkg $type: unusual-control-interpreter $filename #!$interpreter\n"
	    unless ($base eq 'sh'
		    or $base eq 'bash'
		    or $base eq 'perl');

	if (exists $interpreter_dependencies{$base}) {
	    $dep = $interpreter_dependencies{$base};
	    tag_error("interpreter-without-predep", $filename,
		      "#!$interpreter")
		unless (exists $deps{$dep} and $deps{$dep} eq 'pre-depends');
	} elsif ($base eq 'python') {
	    tag_error("interpreter-without-predep", $filename,
		      "#!$interpreter")
		unless ((exists $deps{'python'} and
			 $deps{'python'} eq 'pre-depends') or
			(exists $deps{'python-base'}
			 and $deps{'python-base'} eq 'pre-depends'));
	}
    } elsif ($interpreter =~ m|/usr/local/|) {
	tag_error("interpreter-in-usr-local", $filename, "#!$interpreter");
    } else {
	tag_warn("unusual-interpreter", $filename, "#!$interpreter");
    }

    tag_warn("csh-considered-harmful", $filename)
        if ($base eq 'csh' or $base eq 'tcsh');
}
close(SCRIPTS);

exit 0;

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

sub fail {
    if ($_[0]) {
	print STDERR "error: $_[0]\n";
    } elsif ($!) {
	print STDERR "error: $!\n";
    } else {
	print STDERR "error.\n";
    }
    exit 1;
}

sub tag_error {
    my $tag = shift;
    if ($#_ >= 0) {
	# We can't have newlines in a tag message, so turn them into \n
	map { s,\n,\\n, } @_;
	my $args = join(' ', @_);
	print "E: $pkg $type: $tag $args\n";
    } else {
	print "E: $pkg $type: $tag\n";
    }
}

sub tag_warn {
    my $tag = shift;
    if ($#_ >= 0) {
	# We can't have newlines in a tag message, so turn them into \n
	map { s,\n,\\n, } @_;
	my $args = join(' ', @_);
	print "W: $pkg $type: $tag $args\n";
    } else {
	print "W: $pkg $type: $tag\n";
    }
}
