#!/usr/bin/perl -w
# control-files -- lintian check script

# Copyright (C) 1998 by Christian Schwarz and 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;

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

my %ctrl =
    (
     'config', 0755,
     'control', 0644,
     'conffiles', 0644,
     'md5sums', 0644,
     'postinst', 0755,
     'preinst', 0755,
     'postrm', 0755,
     'prerm', 0755,
     'shlibs', 0644,
     'templates', 0644,
    );

my %maintainer_scripts = map { $_ => 1 } qw(preinst postinst prerm postrm config);

# process control-index file
open(IN,"control-index") or fail("cannot open control-index file: $!");
while (<IN>) {
    chop;

    my ($perm,$owner,$size,$date,$time,$file) = split(' ', $_, 6);
    my ($warned_tmp, $warned_killall, $interp, $bashisms, $cat_string);
    my $operm;

    next if $file eq './';

    $file =~ s,^(\./),,;
    $file =~ s/ link to .*//;
    $file =~ s/ -> .*//;

    next if $file eq './';

    # valid control file?
    unless (exists $ctrl{$file}) {
	print "E: $pkg $type: unknown-control-file $file\n";
	next;
    }

    # skip `control' control file (that's an exception: dpkg doesn't care and
    # this file isn't installed on the systems anyways)
    next if $file eq 'control';

    $operm = perm2oct($perm);

    # correct permissions?
    unless ($operm == $ctrl{$file}) {
	printf "E: $pkg $type: control-file-has-bad-permissions $file %04o != %04o\n",$operm,$ctrl{$file};
    }

    # correct owner?
    unless ($owner eq 'root/root') {
	printf "E: $pkg $type: control-file-has-bad-owner $file $owner != root/root\n";
    }

    # maintainer script?
    next unless exists $maintainer_scripts{$file};

    # scan file
    open(C,"control/$file")
	or fail("cannot open maintainer script control/$file for reading: $!");

    $interp = <C>;
    if ($interp =~ m,^\#\!\s*/bin/(a|ba|k|pdk)?sh,) {
        $interp = 'sh';
	$cat_string = "";
	$bashisms = 1 if not defined($1) or (defined($1) and $1 ne "ba");
    } 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/) {
		next; # nothing to do here
	    }
	    $interp = '';
	}
    }

    while (<C>) {
	next if m,^\s*\#,; # skip comment lines
	s/\#.*$//;         # eat comments
	chomp();
	if (m,\W(/var)?/tmp\b, and not m/\bmktemp\b/ and not m/\btempfile\b/ and not m/\bmkdir\b/) {
	    print "W: $pkg $type: possibly-insecure-handling-of-tmp-files-in-maintainer-script $file:$.\n"
		unless $warned_tmp;
	    $warned_tmp = 1;
	}
	elsif (m/\bkillall\b/) {
	    print "W: $pkg $type: killall-is-dangerous $file:$.\n"
		unless $warned_killall;
	    $warned_killall = 1;
	}
	elsif (m/\bdpkg\s+--print-architecture\b/) {
	    print "W: $pkg $type: dpkg-print-architecture-in-maintainer-script $file:$.\n";
	}
	elsif (m/\bmknod\b/ and not m/\sp\s/) {
	    print "W: $pkg $type: mknod-in-maintainer-script $file:$.\n";
	}
	elsif ($interp eq "sh") {
	    if (m/(?:^|\s+)cat\s+\<\<\s*(\w+)/) {
		$cat_string = $1;
	    }
	    elsif ($cat_string ne "" and m/^$cat_string/) {
		$cat_string = "";
	    }
	    # if cat_string is set, we are in a HERE document and need not
	    # check for things
	    if ($cat_string eq "" and $bashisms) {
		my $found = 0;
		my $match = '';
		my @bashism_regexs = (
		  'function \w+\(\s*\)',       # function is useless
				               # should be '.', not 'source'
		  '(?:^|\s+)source\s+(?:\.\/|\/|\$)[^\s]+',
		  '(\[|test|-o|-a)\s*[^\s]+\s+==\s', # should be 'b = a'
		  '\s\|\&',                    # pipelining is not POSIX
		  '\$\[\w+\]',                 # arith not allowed
		  '\$\{\w+\:\d+(?::\d+)?\}',   # ${foo:3[:1]}
		  '\$\{\w+(/.+?){1,2}\}',      # ${parm/?/pat[/str]}
		  '[^\\\]\{([^\s]+?,)+[^\\\}\s]+\}',     # brace expansion
		  '(?:^|\s+)\w+\[\d+\]=',      # bash arrays, H[0]
		  '\$\{\#?\w+\[[0-9\*\@]+\]\}',   # bash arrays, ${name[0|*|@]}
		  '(?:^|\s+)(read\s*(?:;|$))'  # read without variable
		);

		for my $re (@bashism_regexs) {
		    if (m/($re)/) {
			$found = 1;
			$match = $1;
			last;
		    }
		}
		# since this test is ugly, I have to do it by itself
		# detect source (.) trying to pass args to the command it runs
		if (not $found and m/^\s*(\.\s+[^\s]+\s+([^\s]+))/) {
		    if ($2 eq 'and' || $2 eq '&&' ||
			$2 eq 'or' || $2 eq '||') {
			# everything is ok
			;
		    } else {
			$found = 1;
			$match = $1;
		    }
		}
		unless ($found == 0) {
		    print "W: $pkg $type: possible-bashism-in-maintainer-script $file:$. \'$match\'\n";
		}
	    }
	}
	if (m,\bsuidregister\b,) {
	    print "E: $pkg $type: suidregister-used-in-maintainer-script $file\n";
	}
	if ($file eq 'postrm') {
	    if (m,update\-alternatives \-\-remove,) {
		print "W: $pkg $type: update-alternatives-remove-called-in-postrm\n";
	    }
	}
    }

    close(C);
}

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;
}

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

    my $o = 0;

    $t =~ m/^.(.)(.)(.)(.)(.)(.)(.)(.)(.)/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;
}
