#!/usr/bin/perl -w
# 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.
#
# 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.

use strict;

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

my %valid_interpreters = (
			  'ash' => '/bin/ash',
			  'awk' => '/usr/bin/awk',
			  'bash' => '/bin/bash',
			  'bltwish' => '/usr/bin/bltwish',
			  'burlap' => '/usr/bin/burlap',
			  'csh' => '/bin/csh',
			  'expect' => '/usr/bin/expect',
			  'gawk' => '/usr/bin/gawk',
			  'gforth' => '/usr/bin/gforth',
			  'gnuplot' => '/usr/bin/gnuplot',
			  'guile' => '/usr/bin/guile',
			  'install-fvwmgenmenu' => '/usr/sbin/install-fvwmgenmenu',
			  'install-menu' => '/usr/sbin/install-menu',
			  'js' => '/usr/bin/js',
			  'kforth' => '/usr/bin/kforth',
			  'ksh' => '/usr/bin/ksh',
			  'magicfilter' => '/usr/sbin/magicfilter',
			  'make' => '/usr/bin/make',
			  'mawk' => '/usr/bin/mawk',
			  'nawk' => '/usr/bin/nawk',
			  'ocaml' => '/usr/bin/ocamlrun',
			  'ocamlrun' => '/usr/bin/ocamlrun',
			  'perl' => '/usr/bin/perl',
			  'perl-5.005' => '/usr/bin/perl-5.005',
			  'perl-5.004' => '/usr/bin/perl-5.004',
			  'pforth' => '/usr/bin/pforth',
			  'php' => '/usr/bin/php4',
			  'pike' => '/usr/bin/pike',
			  'pike7' => '/usr/bin/pike7',
			  'python' => '/usr/bin/python',
			  'python2.0' => '/usr/bin/python2.0',
			  'python2' => '/usr/bin/python2',
			  'rexx' => '/usr/bin/rexx',
			  'regina' => '/usr/bin/regina',
			  'rc' => '/usr/bin/rc',
			  'runhugs1.4' => '/usr/bin/runhugs1.4',
			  'runhugs98' => '/usr/bin/runhugs98',
			  'runhugs' => '/usr/bin/runhugs',
			  'ruby' => '/usr/bin/ruby',
			  'scsh' => '/usr/bin/scsh',
			  'sed' => '/bin/sed',
			  'sh' => '/bin/sh',
			  'suidperl' => '/usr/bin/suidperl',
			  'tclsh' => '/usr/bin/tclsh',
			  'tcsh' => '/usr/bin/tcsh',
			  'tixwish' => '/usr/bin/tixwish',
			  'trs' => '/usr/bin/trs',
			  'wish' => '/usr/bin/wish',
			  'wish8.0' => '/usr/bin/wish8.0',
			  'wish8.3' => '/usr/bin/wish8.3',
			  'yforth' => '/usr/bin/yforth',
			  'zsh' => '/usr/bin/zsh'
			 );

my %interpreter_dependencies = (
				'ash' => 'ash',
				'bltwish' => 'blt',
				'burlap' => 'felt',
				'csh' => 'c-shell',
				'expect' => 'expect',
				'gawk' => 'gawk',
				'gforth' => 'gforth',
				'gnuplot' => 'gnuplot',
				'guile' => 'guile',
				'js' => 'ngs-js',
				'kforth' => 'kforth',
				'ksh' => 'pdksh',
				'magicfilter' => 'magicfilter',
				'make' => 'make',
				'mawk' => 'mawk',
				'ocaml' => 'ocaml',
				'perl-5.005' => 'perl-5.005',
				'perl-5.004' => 'perl-5.004',
				'pforth' => 'pforth',
				'php' => 'php-cgi',
				'pike' => 'pike',
				'pike7' => 'pike7',
				'rc' => 'rc',
				'regina' => 'regina-rexx',
				'rexx' => 'regina-rexx',
				'ruby' => 'ruby',
				'runhugs1.4' => 'hugs',
				'runhugs98' => 'hugs98',
				'scsh' => 'scsh',
				'suidperl' => 'perl-suid',
				'tclsh' => 'tclsh',
				'tcsh' => 'tcsh',
				'tixwish' => 'tix',
				'trs' => 'konwert',
				'yforth' => 'yforth',
				'zsh' => 'zsh'
			       );

my %executable = ();
my %ELF = ();
my %deps = ();
my %scripts = ();

# 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.

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

open(INDEX, "index") or fail("cannot open lintian index file: $!");
while (<INDEX>) {
    next unless (m/^-[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: $!");
while (<FILEINFO>) {
    next unless (m/\bELF\b/);
    m/^(.*?): / 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.
foreach my $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: $!");
while (<SCRIPTS>) {
    chop;

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

    $scripts{$filename} = 1;

    my ($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_]+\@$,);

    # no checks necessary at all for scripts in /usr/share/doc/
    next if $filename =~ m,usr/share/doc/,;

    # either they use an absolute path or they call it as '/usr/bin/env interp'
    tag_error("interpreter-not-absolute", $filename, "#!$interpreter")
	unless ($interpreter =~ m,^/, or defined $calls_env);

    tag_warn("script-not-executable", $filename)
	unless ($executable{$filename} or
		$filename =~ m,usr/(lib|share)/.*\.pm,);

    if (exists $valid_interpreters{$base}) {
	tag_error("wrong-path-for-$base", $filename, "#!$interpreter")
	    unless ($interpreter eq $valid_interpreters{$base} or
		    defined $calls_env);
	
	# Do not complain about dependencies for non-executable scripts.
	if ($executable{$filename}) {
	    if (exists $interpreter_dependencies{$base}) {
		my $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 ($base =~ m/^python2(\.\d)*$/) {
		tag_error("python-script-but-no-python-dep", $filename)
		    unless ($deps{'python2'} or $deps{'python2-base'});
            } elsif ($base eq 'pike') {
                tag_error("pike-script-but-no-pike-dep", $filename)
                    unless ($deps{'pike'} or $deps{'pike7'});
	    } elsif ($base =~ m/^wish(\d+\.\d+)?$/) {
		my $has_deps = 0;
		for my $key (keys(%deps)) {
		    if ($key =~ m/^((tk\d+\.\d+)|(wish(\d+\.\d+)?))$/) {
			# has a tk depends which provides wish,
			# or just depends on wish itself
			$has_deps = 1;
			last;
		    }
		}
		if (not $has_deps) {
		    tag_error("wish-script-but-no-wish-dep", $filename);
		}
	    }
	}
    } elsif ($interpreter =~ m,/usr/local/,) {
	tag_error("interpreter-in-usr-local", $filename, "#!$interpreter");
    } elsif ($executable{'.' . $interpreter}) { # each key is './path/to/exe'
	# 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;

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

    $interpreter =~ m|([^/]*)$|;
    my $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}) {
	    my $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 "internal error: $_[0]\n";
    } elsif ($!) {
	print STDERR "internal error: $!\n";
    } else {
	print STDERR "internal 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";
    }
}
