# scripts -- lintian check script -*- perl -*-
#
# This is probably the right file to add a check for the use of
# set -e in bash and sh scripts.
#
# Copyright (C) 1998 Richard Braakman
# Copyright (C) 2002 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::scripts;
use strict;
use Dep;
use Tags;
use Util;

sub run {

# 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',
			  'dash' => '/bin/dash',
			  'expect' => '/usr/bin/expect',
			  'expectk' => '/usr/bin/expectk',
			  'fish' => '/usr/bin/fish',
			  'gawk' => '/usr/bin/gawk',
			  'gbx' => '/usr/bin/gbx',
			  'gbx2' => '/usr/bin/gbx2',
			  'gforth' => '/usr/bin/gforth',
			  'gnuplot' => '/usr/bin/gnuplot',
			  'gosh' => '/usr/bin/gosh',
			  'guile' => '/usr/bin/guile',
			  'install-menu' => '/usr/bin/install-menu',
			  'js' => '/usr/bin/js',
			  'kforth' => '/usr/bin/kforth',
			  'ksh' => '/bin/ksh',
			  'lefty' => '/usr/bin/lefty',
			  'lua50' => '/usr/bin/lua50',
			  'magicfilter' => '/usr/sbin/magicfilter',
			  'make' => '/usr/bin/make',
			  'mawk' => '/usr/bin/mawk',
			  'nawk' => '/usr/bin/nawk',
			  'ocaml' => '/usr/bin/ocamlrun',
			  'ocamlrun' => '/usr/bin/ocamlrun',
			  'parrot' => '/usr/bin/parrot',
			  '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/php',
			  'php3' => '/usr/bin/php3',
			  'php4' => '/usr/bin/php4',
			  'php5' => '/usr/bin/php5',
			  'pike' => '/usr/bin/pike',
			  'pike7' => '/usr/bin/pike7',
			  'python' => '/usr/bin/python',
			  'python1.5' => '/usr/bin/python1.5',
			  'python2.1' => '/usr/bin/python2.1',
			  'python2.2' => '/usr/bin/python2.2',
			  'python2.3' => '/usr/bin/python2.3',
			  'python2.4' => '/usr/bin/python2.4',
			  'python2.5' => '/usr/bin/python2.5',
			  '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',
			  'ruby1.6' => '/usr/bin/ruby1.6',
			  'ruby1.8' => '/usr/bin/ruby1.8',
			  'scsh' => '/usr/bin/scsh',
			  'sed' => '/bin/sed',
			  'sh' => '/bin/sh',
			  'slsh' => '/usr/bin/slsh',
			  'speedy' => '/usr/bin/speedy',
			  'tcl' => '/usr/bin/tcl',
			  'tclsh' => '/usr/bin/tclsh',
			  'tclsh8.3' => '/usr/bin/tclsh8.3',
			  'tclsh8.4' => '/usr/bin/tclsh8.4',
			  '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',
			  'wish8.4' => '/usr/bin/wish8.4',
			  'yforth' => '/usr/bin/yforth',
			  'zsh' => '/bin/zsh'
			 );

my %interpreter_dependencies = (
				'ash' => 'ash',
				'bltwish' => 'blt',
				'burlap' => 'felt',
				'csh' => 'c-shell | tcsh',
				'dash' => 'dash',
				'expect' => 'expect',
				'expectk' => 'expectk',
				'fish' => 'fish',
				'gawk' => 'gawk',
				'gbx' => 'gambas-runtime',
				'gbx2' => 'gambas2-runtime',
				'gforth' => 'gforth',
				'gnuplot' => 'gnuplot',
				'gosh' => 'gauche',
				'guile' => 'guile',
				'js' => 'ngs-js',
				'kforth' => 'kforth',
				'ksh' => 'pdksh',
				'lefty' => 'graphviz',
				'lua50' => 'lua50',
				'magicfilter' => 'magicfilter',
				'make' => 'make | build-essential',
				'mawk' => 'mawk',
				'ocaml' => 'ocaml',
				'parrot' => 'parrot',
				'perl-5.005' => 'perl-5.005',
				'perl-5.004' => 'perl-5.004',
				'pforth' => 'pforth',
				'php' => 'php4-cli | php5-cli',
				'php3' => 'php3-cgi',
				'php4' => 'php4-cli',
				'php5' => 'php5-cli',
				'pike' => 'pike',
				'pike7' => 'pike7',
				'rc' => 'rc',
				'regina' => 'regina-rexx',
				'rexx' => 'regina-rexx',
				'runhugs1.4' => 'hugs',
				'runhugs98' => 'hugs98',
				'scsh' => 'scsh',
				'slsh' => 'slsh',
				'speedy' => 'speedy-cgi-perl',
				'tcl' => 'tclx8.3',
				'tcsh' => 'tcsh',
				'tixwish' => 'tix',
				'trs' => 'konwert',
				'yforth' => 'yforth',
				'zsh' => 'zsh'
			       );

# Appearance of one of these regexes in a maintainer script means that there
# must be a dependency (or pre-dependency) on the given package.  The tag
# reported is maintainer-script-needs-depends-on-%s, so be sure to update
# scripts.desc when adding a new rule.
my @depends_needed = (
	[ adduser => '\badduser\b' ],
	[ 'gconf2 (>= 2.10.1-2)' => '\bgconf-schemas\b' ],
	[ 'netbase | update-inetd' => '\bupdate-inetd\b' ],
	[ ucf => '\bucf\s' ],
);

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

# no dependency for install-menu, because the menu package specifically
# says not to depend on it.

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 .*//;
    my $is_suid = m/^-[rw-]*s/;
    $executable{(split(' ', $_, 6))[5]} = 1;
    $suid{(split(' ', $_, 6))[5]} = $is_suid;
}
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>) {
    m/^(.*?): (.*)/ or fail("bad line in file-info: $_");
    my $file = $1;
    $ELF{$file} = 1 if $2 =~ /^[^,]*\bELF\b/o;
}
close(FILEINFO);

my $all_deps = '';
foreach my $depfield ('suggests', 'recommends', 'depends', 'pre-depends',
		   'provides') {
    $deps{$depfield} = '';
    if (open(IN, "fields/$depfield")) {
	$_ = join('', <IN>);
	close(IN);
        chomp;
        $deps{$depfield} = $_;
        $all_deps .= ', ' if $all_deps;
        $all_deps .= $_;
    }
    $deps{$depfield} = Dep::parse($deps{$depfield});
}
$all_deps .= ', ' if $all_deps;
$all_deps .= $pkg;
$deps{all} = Dep::parse($all_deps);

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;

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

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

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

    my $is_absolute = ($interpreter =~ m,^/, or defined $calls_env);

    # Skip files that have the #! line, but are not executable and do not have
    # an absolute path and are not in a bin/ directory (/usr/bin, /bin etc)
    # They are probably not scripts after all.
    next if ($filename !~ m,(bin/|etc/init.d/), and !$executable{$filename}
             and !$is_absolute);

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

    # either they use an absolute path or they call it as '/usr/bin/env interp'
    tag_error("interpreter-not-absolute", $filename, "#!$interpreter")
	       unless $is_absolute;
    tag_warn("script-not-executable", $filename)
	unless ($executable{$filename} or
		$filename =~ m,usr/(lib|share)/.*\.pm, or
		$filename =~ m,\.in$, or
		$filename =~ m,etc/menu-methods, or
		$filename =~ m,etc/X11/Xsession.d,);

    if (exists $valid_interpreters{$base}) {
	unless ($interpreter eq $valid_interpreters{$base} or
		defined $calls_env) {
	    # save us from some copy and paste
	    if ($base =~ /^(ruby|python)(?:\d\.\d)?$/) {
		tag_error("wrong-path-for-$1", $filename, "#!$interpreter");
	    } else {
		tag_error("wrong-path-for-interpreter",
			  "#!$interpreter != $valid_interpreters{$base}",
			  "($filename)");
	    }
	}

	# Do not complain about dependencies for non-executable scripts.
	if ($executable{$filename}) {
	    if (exists $interpreter_dependencies{$base}) {
		my @deps = split(/,/,$interpreter_dependencies{$base});
		if ($base eq 'php') {
		    tag_error("php-script-but-no-php-cli-dep", $filename)
			unless Dep::implies($deps{all}, Dep::parse($interpreter_dependencies{$base}));
		} elsif ($base =~ /^(php\d?|(m|g)awk)/) {
		    tag_error("$base-script-but-no-$deps[0]-dep", $filename)
			unless Dep::implies($deps{all}, Dep::parse($interpreter_dependencies{$base}));
		} else {
		    tag_error("missing-dep-for-interpreter",
			      "$base => $deps[0]", "($filename)")
			unless Dep::implies($deps{all}, Dep::parse($interpreter_dependencies{$base}));
		}
	    } elsif ($base =~ /^python(\d.\d)?$/) {
		my $ver = $1 ? $1 : "";
		tag_error("python-script-but-no-python-dep", $filename)
                    unless Dep::implies($deps{all}, Dep::parse("python$ver | python${ver}-minimal"));
	    } elsif ($base =~ /^ruby(\d.\d)?$/) {
		my $ver = $1 ? $1 : "";
		tag_error("ruby-script-but-no-ruby-dep", $filename)
                    unless Dep::implies($deps{all}, Dep::parse("ruby$ver"));
	    } elsif ($base eq 'perl' && $suid{$filename}) {
		tag_error("suid-perl-script-but-no-perl-suid-dep", $filename)
                    unless Dep::implies($deps{all}, Dep::parse('perl-suid'));
	    } elsif ($base =~ m/^tclsh(\d+\.\d+)?$/) {
		my $ver = $1 ? $1 : "";
		if ($ver) {
		    tag_error("tclsh-script-but-no-tclsh-dep", "$filename $base")
			unless Dep::implies($deps{all}, Dep::parse("tcl$ver"));
		} else {
		    tag_error("tclsh-script-but-no-tclsh-dep", "$filename $base")
			unless Dep::implies($deps{all}, Dep::parse("tcl8.3 | tcl8.4 | tclsh"));
		}
	    } elsif ($base =~ m/^wish(\d+\.\d+)?$/) {
		my $ver = $1 ? $1 : "";
		if ($ver) {
		    tag_error("wish-script-but-no-wish-dep", "$filename $base")
			unless Dep::implies($deps{all}, Dep::parse("tk$ver"));
		} else {
		    tag_error("wish-script-but-no-wish-dep", "$filename $base")
			unless Dep::implies($deps{all}, Dep::parse("tk8.3 | tk8.4 | wish"));
		}
	    }
	}
    } 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.
    } elsif ($base eq 'suidperl') {
	tag_error("calls-suidperl-directly", $filename);
    } else {
	tag_warn("unusual-interpreter", $filename, "#!$interpreter");
    }

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

    # Don't syntax-check scripts in /usr/src that end in .dpatch.  bash -n
    # doesn't stop checking at exit 0 and goes on to blow up on the patch
    # itself.
    if ($base =~ /^(?:(?:b|d)?a|k|z)?sh$/) {
	if (-x "$interpreter" && ! script_is_evil_and_wrong("unpacked/$filename")) {
	    if ($filename !~ m,^./usr/src/.*\.dpatch$,) {
		if (check_script_syntax($interpreter, "unpacked/$filename")) {
		    tag_error("shell-script-fails-syntax-check", $filename);
		}
	    }
	}
	next;
    }
}
close(SCRIPTS);

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

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 $file = $2;
    my $filename = "control/$file";

    $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});
	tag $file eq 'config'?
	    "forbidden-config-interpreter":"unusual-control-interpreter",
	    "#!$interpreter"
	    unless ($base eq 'sh'
		    or $base eq 'bash'
		    or $base eq 'perl');
	
	if (exists $interpreter_dependencies{$base}) {
	    tag_error("interpreter-without-predep", $filename,
		      "#!$interpreter")
		unless Dep::implies($deps{'pre-depends'}, Dep::parse($interpreter_dependencies{$base}));
	} elsif ($base eq 'python') {
	    tag_error("interpreter-without-predep", $filename,
		      "#!$interpreter")
		unless Dep::implies($deps{'pre-depends'}, Dep::parse('python | python-base'));
	}
    } elsif ($interpreter =~ m|/usr/local/|) {
	tag_error("interpreter-in-usr-local", $filename, "#!$interpreter");
    } else {
	tag_warn("unusual-interpreter", $filename, "#!$interpreter");
	next; # no use doing further checks if it's not a known interpreter
    }

    # perhaps we should warn about *csh even if they're somehow screwed,
    # but that's not really important...
    tag_warn("csh-considered-harmful", $filename)
	if ($base eq 'csh' or $base eq 'tcsh');

    my $shellscript = $base =~ /^((b|d)?a|t?c|(pd)?k)?sh$/ ? 1 : 0;

    my $checkbashisms;
    if ($shellscript) {
        # perhaps just do it when $base eq "sh" instead?
	$checkbashisms = $base eq "sh" ? 1 : 0;
	if (-x $valid_interpreters{$base}) {
	    if (check_script_syntax($interpreter, $filename)) {
		tag_error("maintainer-shell-script-fails-syntax-check", $file);
	    }
	}
    }

# the control-files check already has an unknown-control-file error
# so there's no need for anything like this here:
# my %maintainer_scripts = map { $_ => 1 } qw(preinst postinst prerm postrm config);
# print "E: something" unless exists $maintainer_scripts{$file}

    # now scan the file contents themselves
    open C, '<', "$filename"
	or fail("cannot open maintainer script $filename for reading: $!");

    my %warned;
    my ($saw_init, $saw_invoke);
    my $cat_string = "";

    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/ and not m/\bmkstemp\b/) {
	    tag "possibly-insecure-handling-of-tmp-files-in-maintainer-script", "$file:$."
		unless $warned{tmp};
	    $warned{tmp} = 1;
	}
	if (m/^\s*killall(?:\s|$)/) {
	    tag "killall-is-dangerous", "$file:$."
		unless $warned{killall};
	    $warned{killall} = 1;
	}
	if (m/^\s*mknod(?:\s|$)/ and not m/\sp\s/) {
	    tag "mknod-in-maintainer-script", "$file:$.";
	}

	# Collect information about init script invocations to catch running
	# init scripts directory rather than through invoke-rc.d.  Since the
	# script is allowed to run the init script directly if invoke-rc.d
	# doesn't exist, only tag direct invocations where invoke-rc.d is
	# never used in the same script.  Lots of false negatives, but
	# hopefully not many false positives.
	if (m%^\s*/etc/init.d/(\S+)\s+[\"\']?(\S+)[\"\']?%) {
	    $saw_init = $.;
	}
	if (m%^\s*invoke-rc.d\s+%) {
	    $saw_invoke = $.;
	}

	if ($shellscript) {
	    if (m/^\s*cat\s*\<\<\s*(\w+)/) {
		$cat_string = $1;
	    }
	    elsif ($cat_string ne "" and m/^$cat_string/) {
		$cat_string = "";
	    }
	    my $within_another_shell = 0;
	    if (m,(^|\s+)((/usr)?/bin/)?((b|d)?a|k|z|t?c)sh\s+-c\s*.+,) {
		$within_another_shell = 1;
	    }
	    #Don't use chown foo.bar:
	    if (m{(chown\s+[-_A-Za-z0-9]+\.[-_A-Za-z0-9]+)\s+}) {
	    	tag "deprecated-chown-usage", "$file:$. \'$1\'";
	    }
	    # if cat_string is set, we are in a HERE document and need not
	    # check for things
	    if ($cat_string eq "" and $checkbashisms and !$within_another_shell) {
		my $found = 0;
		my $found_strict = 0;
		my $match = '';
		my @bashism_string_regexs = (
		  '\$\[\w+\]',		       # arith not allowed
		  '\$\{\w+\:\d+(?::\d+)?\}',   # ${foo:3[:1]}
		  '\$\{\w+(/.+?){1,2}\}',      # ${parm/?/pat[/str]}
		  '\$\{\#?\w+\[[0-9\*\@]+\]\}',# bash arrays, ${name[0|*|@]}
		);
		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
		  '[^\\\]\{([^\s]+?,)+[^\\\}\s]+\}', # brace expansion
		  '(?:^|\s+)\w+\[\d+\]=',      # bash arrays, H[0]
		  '(?:^|\s+)read\s*(?:;|$)',   # read without variable
		  '(?:^|\s+)kill\s+-[^sl]\w*', # kill -[0-9] or -[A-Z]
		  '(?:^|\s+)trap\s+["\']?.*["\']?\s+.*[1-9]', # trap with signal numbers
		  '\&>',		       # cshism
		  '\[\[(?!:)',		       # alternative test command
		);
		my @strict_posix_regexs = (
		  '((?:test|\[)\s+.+\s-[ao])\s',# test/[ -a/-o binary operators
		  '(?:^\s*)local\s',	    # local scoping of variables
					   );

		# 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 =~ /^(\&|\||\d?>|<)/) {
			# everything is ok
			;
		    } else {
			$found = 1;
			$match = $1;
		    }
		}

		# Ignore anything inside single quotes; it could be an
		# argument to grep or the like.
                my $line = $_;
		$line =~ s/([^\\](?:\\\\)*)\'(?:\\.|[^\\\'])+\'/$1''/g;

		for my $re (@bashism_string_regexs) {
		    if ($line =~ m/($re)/) {
			$found = 1;
                        ($match) = m/($re)/;
			last;
		    }
		}

		# We've checked for all the things we still want to notice in
		# double-quoted strings, so now remove those strings as well.
		unless ($found) {
		    $line =~ s/([^\\](?:\\\\)*)\"(?:\\.|[^\\\"])+\"/$1""/g;
		    for my $re (@bashism_regexs) {
			if ($line =~ m/($re)/) {
			    $found = 1;
			    ($match) = m/($re)/;
			    last;
			}
		    }
		}
		unless ($found) {
		    for my $re (@strict_posix_regexs) {
			if ($line =~ m/($re)/) {
			    $found = 1;
			    $found_strict = 1;
			    ($match) = m/($re)/;
			    last;
			}
		    }
		}

		if ($found && $found_strict) {
		    tag "possible-non-posix-code-in-maintainer-script", "$file:$. \'$match\'";
		} elsif ($found) {
		    tag "possible-bashism-in-maintainer-script", "$file:$. \'$match\'";
		}
	    }
	}
	if (m,\bsuidregister\b,) {
	    tag "suidregister-used-in-maintainer-script", "$file";
	}
	if ($file eq 'postrm') {
	    if (m,update\-alternatives \-\-remove,) {
		tag "update-alternatives-remove-called-in-postrm", "";
	    }
	} else {
	    for my $rule (@depends_needed) {
		my ($package, $regex) = @$rule;
		if (/$regex/ && ! $warned{$package}) {
                    my $needed = Dep::parse($package);
                    unless (Dep::implies($deps{depends}, $needed) || Dep::implies($deps{'pre-depends'}, $needed)) {
			my $shortpackage = $package;
			$shortpackage =~ s/[ \(].*//;
			tag "maintainer-script-needs-depends-on-$shortpackage", "$file";
			$warned{$package} = 1;
		    }
		}
	    }
	}
	if (/invoke-rc.d.*\|\| exit 0/) {
	    tag "maintainer-script-hides-init-failure", "$file:$.";
	}
	if (/\bgconftool(-2)?(\s|\Z)/) {
	    tag "gconftool-used-in-maintainer-script", "$file:$.";
	}
    }

    if ($saw_init && ! $saw_invoke) {
	tag "maintainer-script-calls-init-script-directly", "$file:$saw_init";
    }

    close C;

}
close(SCRIPTS);

}

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

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(' ', @_);
	tag "$tag", "$args";
    } else {
	tag "$tag", "";
    }
}

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(' ', @_);
	tag "$tag", "$args";
    } else {
	tag "$tag", "";
    }
}

# Returns non-zero if the given file is not actually a shell script, 
# just looks like one.
sub script_is_evil_and_wrong {
    my ($filename) = @_;
    my $ret = 0;
    open IN, '<', $filename or fail("cannot open $filename: $!");
    my $i = 0;
    local $_;
    while (<IN>) {
        chomp;
	next if /^#/o;
	next if /^$/o;
        last if (++$i > 20);
        if (/(^\s*|\beval\s*\'|;)exec\s*.+\s*.?\$0.?\s*(--\s*)?(\${1:?\+)?.?\$\@/o) {
            $ret = 1;
            last;
        }
    }
    close IN;
    return $ret;
}

# Given an interpretor and a file, run the interpretor on that file with the
# -n option to check syntax, discarding output and returning the exit status.
sub check_script_syntax {
    my ($interpreter, $script) = @_;
    my $pid = fork;
    if (!defined $pid) {
	fail("cannot fork: $!");
    } elsif ($pid == 0) {
	open STDOUT, '>/dev/null' or fail("cannot reopen stdout: $!");
	open STDERR, '>&STDOUT' or fail("cannot reopen stderr: $!");
	exec $interpreter, '-n', $script
	    or fail("cannot exec $interpreter: $!");
    } else {
	waitpid $pid, 0;
    }
    return $?;
}

1;

# vim: syntax=perl ts=8 sw=4