src/check.pl

# $MirOS: src/bin/mksh/check.pl,v 1.31 2012/04/06 12:22:14 tg Exp $
# $OpenBSD: th,v 1.13 2006/05/18 21:27:23 miod Exp $
#-
# Copyright (c) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011, 2012
#	Thorsten Glaser <tg@mirbsd.org>
#
# Provided that these terms and disclaimer and all copyright notices
# are retained or reproduced in an accompanying document, permission
# is granted to deal in this work without restriction, including un-
# limited rights to use, publicly perform, distribute, sell, modify,
# merge, give away, or sublicence.
#
# This work is provided "AS IS" and WITHOUT WARRANTY of any kind, to
# the utmost extent permitted by applicable law, neither express nor
# implied; without malicious intent or gross negligence. In no event
# may a licensor, author or contributor be held liable for indirect,
# direct, other damage, loss, or other issues arising in any way out
# of dealing in the work, even if advised of the possibility of such
# damage or existence of a defect, except proven that it results out
# of said person's immediate fault when using the work as intended.
#-
# Example test:
#		name: a-test
#		description:
#			a test to show how tests are done
#		arguments: !-x!-f!
#		stdin:
#			echo -n *
#			false
#		expected-stdout: !
#			*
#		expected-stderr:
#			+ echo -n *
#			+ false
#		expected-exit: 1
#		---
#	This runs the test-program (eg, mksh) with the arguments -x and -f,
#	standard input is a file containing "echo hi*\nfalse\n". The program
#	is expected to produce "hi*" (no trailing newline) on standard output,
#	"+ echo hi*\n+false\n" on standard error, and an exit code of 1.
#
#
# Format of test files:
# - blank lines and lines starting with # are ignored
# - a test file contains a series of tests
# - a test is a series of tag:value pairs ended with a "---" line
#   (leading/trailing spaces are stripped from the first line of value)
# - test tags are:
#	Tag			Flag	Description
#	-----			----	-----------
#	name			r	The name of the test; should be unique
#	description		m	What test does
#	arguments		M	Arguments to pass to the program;
#					default is no arguments.
#	script			m	Value is written to a file which
#					is passed as an argument to the program
#					(after the arguments arguments)
#	stdin			m	Value is written to a file which is
#					used as standard-input for the program;
#					default is to use /dev/null.
#	perl-setup		m	Value is a perl script which is executed
#					just before the test is run. Try to
#					avoid using this...
#	perl-cleanup		m	Value is a perl script which is executed
#					just after the test is run. Try to
#					avoid using this...
#	env-setup		M	Value is a list of NAME=VALUE elements
#					which are put in the environment before
#					the test is run. If the =VALUE is
#					missing, NAME is removed from the
#					environment. Programs are run with
#					the following minimal environment:
#					    HOME, LD_LIBRARY_PATH, LOCPATH,
#					    LOGNAME, PATH, SHELL, UNIXMODE,
#					    USER
#					(values taken from the environment of
#					the test harness).
#					CYGWIN is set to nodosfilewarning.
#					ENV is set to /nonexistant.
#					__progname is set to the -p argument.
#					__perlname is set to $^X (perlexe).
#	file-setup		mps	Used to create files, directories
#					and symlinks. First word is either
#					file, dir or symlink; second word is
#					permissions; this is followed by a
#					quoted word that is the name of the
#					file; the end-quote should be followed
#					by a newline, then the file data
#					(if any). The first word may be
#					preceded by a ! to strip the trailing
#					newline in a symlink.
#	file-result		mps	Used to verify a file, symlink or
#					directory is created correctly.
#					The first word is either
#					file, dir or symlink; second word is
#					expected permissions; third word
#					is user-id; fourth is group-id;
#					fifth is "exact" or "pattern"
#					indicating whether the file contents
#					which follow is to be matched exactly
#					or if it is a regular expression.
#					The fifth argument is the quoted name
#					of the file that should be created.
#					The end-quote should be followed
#					by a newline, then the file data
#					(if any). The first word may be
#					preceded by a ! to strip the trailing
#					newline in the file contents.
#					The permissions, user and group fields
#					may be * meaning accept any value.
#	time-limit			Time limit - the program is sent a
#					SIGKILL N seconds. Default is no
#					limit.
#	expected-fail			'yes' if the test is expected to fail.
#	expected-exit			expected exit code. Can be a number,
#					or a C expression using the variables
#					e, s and w (exit code, termination
#					signal, and status code).
#	expected-stdout		m	What the test should generate on stdout;
#					default is to expect no output.
#	expected-stdout-pattern	m	A perl pattern which matches the
#					expected output.
#	expected-stderr		m	What the test should generate on stderr;
#					default is to expect no output.
#	expected-stderr-pattern	m	A perl pattern which matches the
#					expected standard error.
#	category		m	Specify a comma separated list of
#					'categories' of program that the test
#					is to be run for. A category can be
#					negated by prefixing the name with a !.
#					The idea is that some tests in a
#					test suite may apply to a particular
#					program version and shouldn't be run
#					on other versions. The category(s) of
#					the program being tested can be
#					specified on the command line.
#					One category os:XXX is predefined
#					(XXX is the operating system name,
#					eg, linux, dec_osf).
#	need-ctty			'yes' if the test needs a ctty, run
#					with -C regress:no-ctty to disable.
# Flag meanings:
#	r	tag is required (eg, a test must have a name tag).
#	m	value can be multiple lines. Lines must be prefixed with
#		a tab. If the value part of the initial tag:value line is
#			- empty: the initial blank line is stripped.
#			- a lone !: the last newline in the value is stripped;
#	M	value can be multiple lines (prefixed by a tab) and consists
#		of multiple fields, delimited by a field separator character.
#		The value must start and end with the f-s-c.
#	p	tag takes parameters (used with m).
#	s	tag can be used several times.

# pull EINTR from POSIX.pm or Errno.pm if they exist
# otherwise just skip it
BEGIN {
	$EINTR = 0;
	eval {
		require POSIX;
		$EINTR = POSIX::EINTR();
	};
	if ($@) {
		eval {
			require Errno;
			$EINTR = Errno::EINTR();
		} or do {
			$EINTR = 0;
		};
	}
};

use Getopt::Std;
use Config;

$os = defined $^O ? $^O : 'unknown';

($prog = $0) =~ s#.*/##;

$Usage = <<EOF ;
Usage: $prog [-Pv] [-C cat] [-e e=v] [-p prog] [-s fn] [-t tmo] name ...
	-C c	Specify the comma separated list of categories the program
		belongs to (see category field).
	-e e=v	Set the environment variable e to v for all tests
		(if no =v is given, the current value is used)
		Only one -e option can be given at the moment, sadly.
	-P	program (-p) string has multiple words, and the program is in
		the path (kludge option)
	-p p	Use p as the program to test
	-s s	Read tests from file s; if s is a directory, it is recursively
		scaned for test files (which end in .t).
	-t t	Use t as default time limit for tests (default is unlimited)
	-v	Verbose mode: print reason test failed.
	name	specifies the name of the test(s) to run; if none are
		specified, all tests are run.
EOF

# See comment above for flag meanings
%test_fields = (
	'name',				'r',
	'description',			'm',
	'arguments',			'M',
	'script',			'm',
	'stdin',			'm',
	'perl-setup',			'm',
	'perl-cleanup',			'm',
	'env-setup',			'M',
	'file-setup',			'mps',
	'file-result',			'mps',
	'time-limit',			'',
	'expected-fail',		'',
	'expected-exit',		'',
	'expected-stdout',		'm',
	'expected-stdout-pattern',	'm',
	'expected-stderr',		'm',
	'expected-stderr-pattern',	'm',
	'category',			'm',
	'need-ctty',			'',
	'need-pass',			'',
	);
# Filled in by read_test()
%internal_test_fields = (
	':full-name', 1,		# file:name
	':long-name', 1,		# dir/file:lineno:name
	);

# Categories of the program under test. Provide the current
# os by default.
%categories = (
	"os:$os", '1'
	);

$temps = "/tmp/rts$$";
$tempi = "/tmp/rti$$";
$tempo = "/tmp/rto$$";
$tempe = "/tmp/rte$$";
$tempdir = "/tmp/rtd$$";

$nfailed = 0;
$nifailed = 0;
$nxfailed = 0;
$npassed = 0;
$nxpassed = 0;

%known_tests = ();

if (!getopts('C:e:Pp:s:t:v')) {
    print STDERR $Usage;
    exit 1;
}

die "$prog: no program specified (use -p)\n" if !defined $opt_p;
die "$prog: no test set specified (use -s)\n" if !defined $opt_s;
$test_prog = $opt_p;
$verbose = defined $opt_v && $opt_v;
$test_set = $opt_s;
if (defined $opt_t) {
    die "$prog: bad -t argument (should be number > 0): $opt_t\n"
	if $opt_t !~ /^\d+$/ || $opt_t <= 0;
    $default_time_limit = $opt_t;
}
$program_kludge = defined $opt_P ? $opt_P : 0;

if (defined $opt_C) {
    foreach $c (split(',', $opt_C)) {
	$c =~ s/\s+//;
	die "$prog: categories can't be negated on the command line\n"
	    if ($c =~ /^!/);
	$categories{$c} = 1;
    }
}

# Note which tests are to be run.
%do_test = ();
grep($do_test{$_} = 1, @ARGV);
$all_tests = @ARGV == 0;

# Set up a very minimal environment
%new_env = ();
foreach $env (('HOME', 'LD_LIBRARY_PATH', 'LOCPATH', 'LOGNAME',
  'PATH', 'SHELL', 'UNIXMODE', 'USER')) {
    $new_env{$env} = $ENV{$env} if defined $ENV{$env};
}
$new_env{'CYGWIN'} = 'nodosfilewarning';
$new_env{'ENV'} = '/nonexistant';
if (($os eq 'VMS') || ($Config{perlpath} =~ m/$Config{_exe}$/i)) {
	$new_env{'__perlname'} = $Config{perlpath};
} else {
	$new_env{'__perlname'} = $Config{perlpath} . $Config{_exe};
}
if (defined $opt_e) {
    # XXX need a way to allow many -e arguments...
    if ($opt_e =~ /^([a-zA-Z_]\w*)(|=(.*))$/) {
	$new_env{$1} = $2 eq '' ? $ENV{$1} : $3;
    } else {
	die "$0: bad -e argument: $opt_e\n";
    }
}
%old_env = %ENV;

die "$prog: couldn't make directory $tempdir - $!\n" if !mkdir($tempdir, 0777);

chop($pwd = `pwd 2>/dev/null`);
die "$prog: couldn't get current working directory\n" if $pwd eq '';
die "$prog: couldn't cd to $pwd - $!\n" if !chdir($pwd);

if (!$program_kludge) {
    $test_prog = "$pwd/$test_prog" if substr($test_prog, 0, 1) ne '/';
    die "$prog: $test_prog is not executable - bye\n"
	if (! -x $test_prog && $os ne 'os2');
}

@trap_sigs = ('TERM', 'QUIT', 'INT', 'PIPE', 'HUP');
@SIG{@trap_sigs} = ('cleanup_exit') x @trap_sigs;
$child_kill_ok = 0;
$SIG{'ALRM'} = 'catch_sigalrm';

$| = 1;

if (-d $test_set) {
    $file_prefix_skip = length($test_set) + 1;
    $ret = &process_test_dir($test_set);
} else {
    $file_prefix_skip = 0;
    $ret = &process_test_file($test_set);
}
&cleanup_exit() if !defined $ret;

$tot_failed = $nfailed + $nifailed + $nxfailed;
$tot_passed = $npassed + $nxpassed;
if ($tot_failed || $tot_passed) {
    print "Total failed: $tot_failed";
    print " ($nifailed ignored)" if $nifailed;
    print " ($nxfailed unexpected)" if $nxfailed;
    print " (as expected)" if $nfailed && !$nxfailed && !$nifailed;
    print "\nTotal passed: $tot_passed";
    print " ($nxpassed unexpected)" if $nxpassed;
    print "\n";
}

&cleanup_exit('ok');

sub
cleanup_exit
{
    local($sig, $exitcode) = ('', 1);

    if ($_[0] eq 'ok') {
	unless ($nxfailed) {
		$exitcode = 0;
	} else {
		$exitcode = 1;
	}
    } elsif ($_[0] ne '') {
	$sig = $_[0];
    }

    unlink($tempi, $tempo, $tempe, $temps);
    &scrub_dir($tempdir) if defined $tempdir;
    rmdir($tempdir) if defined $tempdir;

    if ($sig) {
	$SIG{$sig} = 'DEFAULT';
	kill $sig, $$;
	return;
    }
    exit $exitcode;
}

sub
catch_sigalrm
{
    $SIG{'ALRM'} = 'catch_sigalrm';
    kill(9, $child_pid) if $child_kill_ok;
    $child_killed = 1;
}

sub
process_test_dir
{
    local($dir) = @_;
    local($ret, $file);
    local(@todo) = ();

    if (!opendir(DIR, $dir)) {
	print STDERR "$prog: can't open directory $dir - $!\n";
	return undef;
    }
    while (defined ($file = readdir(DIR))) {
	push(@todo, $file) if $file =~ /^[^.].*\.t$/;
    }
    closedir(DIR);

    foreach $file (@todo) {
	$file = "$dir/$file";
	if (-d $file) {
	    $ret = &process_test_dir($file);
	} elsif (-f _) {
	    $ret = &process_test_file($file);
	}
	last if !defined $ret;
    }

    return $ret;
}

sub
process_test_file
{
    local($file) = @_;
    local($ret);

    if (!open(IN, $file)) {
	print STDERR "$prog: can't open $file - $!\n";
	return undef;
    }
    binmode(IN);
    while (1) {
	$ret = &read_test($file, IN, *test);
	last if !defined $ret || !$ret;
	next if !$all_tests && !$do_test{$test{'name'}};
	next if !&category_check(*test);
	$ret = &run_test(*test);
	last if !defined $ret;
    }
    close(IN);

    return $ret;
}

sub
run_test
{
    local(*test) = @_;
    local($name) = $test{':full-name'};

    if (defined $test{'stdin'}) {
	return undef if !&write_file($tempi, $test{'stdin'});
	$ifile = $tempi;
    } else {
	$ifile = '/dev/null';
    }

    if (defined $test{'script'}) {
	return undef if !&write_file($temps, $test{'script'});
    }

    return undef if !&scrub_dir($tempdir);

    if (!chdir($tempdir)) {
	print STDERR "$prog: couldn't cd to $tempdir - $!\n";
	return undef;
    }

    if (defined $test{'file-setup'}) {
	local($i);
	local($type, $perm, $rest, $c, $len, $name);

	for ($i = 0; $i < $test{'file-setup'}; $i++) {
	    $val = $test{"file-setup:$i"};

	    # format is: type perm "name"
	    ($type, $perm, $rest) =
		split(' ', $val, 3);
	    $c = substr($rest, 0, 1);
	    $len = index($rest, $c, 1) - 1;
	    $name = substr($rest, 1, $len);
	    $rest = substr($rest, 2 + $len);
	    $perm = oct($perm) if $perm =~ /^\d+$/;
	    if ($type eq 'file') {
		return undef if !&write_file($name, $rest);
		if (!chmod($perm, $name)) {
		    print STDERR
		  "$prog:$test{':long-name'}: can't chmod $perm $name - $!\n";
		    return undef;
		}
	    } elsif ($type eq 'dir') {
		if (!mkdir($name, $perm)) {
		    print STDERR
		  "$prog:$test{':long-name'}: can't mkdir $perm $name - $!\n";
		    return undef;
		}
	    } elsif ($type eq 'symlink') {
		local($oumask) = umask($perm);
		local($ret) = symlink($rest, $name);
		umask($oumask);
		if (!$ret) {
		    print STDERR
	    "$prog:$test{':long-name'}: couldn't create symlink $name - $!\n";
		    return undef;
		}
	    }
	}
    }

    if (defined $test{'perl-setup'}) {
	eval $test{'perl-setup'};
	if ($@ ne '') {
	    print STDERR "$prog:$test{':long-name'}: error running perl-setup - $@\n";
	    return undef;
	}
    }

    $pid = fork;
    if (!defined $pid) {
	print STDERR "$prog: can't fork - $!\n";
	return undef;
    }
    if (!$pid) {
	@SIG{@trap_sigs} = ('DEFAULT') x @trap_sigs;
	$SIG{'ALRM'} = 'DEFAULT';
	if (defined $test{'env-setup'}) {
	    local($var, $val, $i);

	    foreach $var (split(substr($test{'env-setup'}, 0, 1),
		$test{'env-setup'}))
	    {
		$i = index($var, '=');
		next if $i == 0 || $var eq '';
		if ($i < 0) {
		    delete $new_env{$var};
		} else {
		    $new_env{substr($var, 0, $i)} = substr($var, $i + 1);
		}
	    }
	}
	if (!open(STDIN, "< $ifile")) {
		print STDERR "$prog: couldn't open $ifile in child - $!\n";
		kill('TERM', $$);
	}
	binmode(STDIN);
	if (!open(STDOUT, "> $tempo")) {
		print STDERR "$prog: couldn't open $tempo in child - $!\n";
		kill('TERM', $$);
	}
	binmode(STDOUT);
	if (!open(STDERR, "> $tempe")) {
		print STDOUT "$prog: couldn't open $tempe in child - $!\n";
		kill('TERM', $$);
	}
	binmode(STDERR);
	if ($program_kludge) {
	    @argv = split(' ', $test_prog);
	} else {
	    @argv = ($test_prog);
	}
	if (defined $test{'arguments'}) {
		push(@argv,
		     split(substr($test{'arguments'}, 0, 1),
			   substr($test{'arguments'}, 1)));
	}
	push(@argv, $temps) if defined $test{'script'};

	#XXX realpathise, use which/whence -p, or sth. like that
	#XXX if !$program_kludge, we get by with not doing it for now tho
	$new_env{'__progname'} = $argv[0];

	# The following doesn't work with perl5...  Need to do it explicitly - yuck.
	#%ENV = %new_env;
	foreach $k (keys(%ENV)) {
	    delete $ENV{$k};
	}
	$ENV{$k} = $v while ($k,$v) = each %new_env;

	exec { $argv[0] } @argv;
	print STDERR "$prog: couldn't execute $test_prog - $!\n";
	kill('TERM', $$);
	exit(95);
    }
    $child_pid = $pid;
    $child_killed = 0;
    $child_kill_ok = 1;
    alarm($test{'time-limit'}) if defined $test{'time-limit'};
    while (1) {
	$xpid = waitpid($pid, 0);
	$child_kill_ok = 0;
	if ($xpid < 0) {
	    if ($EINTR) {
		next if $! == $EINTR;
	    }
	    print STDERR "$prog: error waiting for child - $!\n";
	    return undef;
	}
	last;
    }
    $status = $?;
    alarm(0) if defined $test{'time-limit'};

    $failed = 0;
    $why = '';

    if ($child_killed) {
	$failed = 1;
	$why .= "\ttest timed out (limit of $test{'time-limit'} seconds)\n";
    }

    $ret = &eval_exit($test{'long-name'}, $status, $test{'expected-exit'});
    return undef if !defined $ret;
    if (!$ret) {
	local($expl);

	$failed = 1;
	if (($status & 0xff) == 0x7f) {
	    $expl = "stopped";
	} elsif (($status & 0xff)) {
	    $expl = "signal " . ($status & 0x7f);
	} else {
	    $expl = "exit-code " . (($status >> 8) & 0xff);
	}
	$why .=
	"\tunexpected exit status $status ($expl), expected $test{'expected-exit'}\n";
    }

    $tmp = &check_output($test{'long-name'}, $tempo, 'stdout',
		$test{'expected-stdout'}, $test{'expected-stdout-pattern'});
    return undef if !defined $tmp;
    if ($tmp ne '') {
	$failed = 1;
	$why .= $tmp;
    }

    $tmp = &check_output($test{'long-name'}, $tempe, 'stderr',
		$test{'expected-stderr'}, $test{'expected-stderr-pattern'});
    return undef if !defined $tmp;
    if ($tmp ne '') {
	$failed = 1;
	$why .= $tmp;
    }

    $tmp = &check_file_result(*test);
    return undef if !defined $tmp;
    if ($tmp ne '') {
	$failed = 1;
	$why .= $tmp;
    }

    if (defined $test{'perl-cleanup'}) {
	eval $test{'perl-cleanup'};
	if ($@ ne '') {
	    print STDERR "$prog:$test{':long-name'}: error running perl-cleanup - $@\n";
	    return undef;
	}
    }

    if (!chdir($pwd)) {
	print STDERR "$prog: couldn't cd to $pwd - $!\n";
	return undef;
    }

    if ($failed) {
	if (!$test{'expected-fail'}) {
	    if ($test{'need-pass'}) {
		print "FAIL $name\n";
		$nxfailed++;
	    } else {
		print "FAIL $name (ignored)\n";
		$nifailed++;
	    }
	} else {
	    print "fail $name (as expected)\n";
	    $nfailed++;
	}
	$why = "\tDescription"
		. &wrap_lines($test{'description'}, " (missing)\n")
		. $why;
    } elsif ($test{'expected-fail'}) {
	print "PASS $name (unexpectedly)\n";
	$nxpassed++;
    } else {
	print "pass $name\n";
	$npassed++;
    }
    print $why if $verbose;
    return 0;
}

sub
category_check
{
    local(*test) = @_;
    local($c);

    return 0 if ($test{'need-ctty'} && defined $categories{'regress:no-ctty'});
    return 1 if (!defined $test{'category'});
    local($ok) = 0;
    foreach $c (split(',', $test{'category'})) {
	$c =~ s/\s+//;
	if ($c =~ /^!/) {
	    $c = $';
	    return 0 if (defined $categories{$c});
	    $ok = 1;
	} else {
	    $ok = 1 if (defined $categories{$c});
	}
    }
    return $ok;
}

sub
scrub_dir
{
    local($dir) = @_;
    local(@todo) = ();
    local($file);

    if (!opendir(DIR, $dir)) {
	print STDERR "$prog: couldn't open directory $dir - $!\n";
	return undef;
    }
    while (defined ($file = readdir(DIR))) {
	push(@todo, $file) if $file ne '.' && $file ne '..';
    }
    closedir(DIR);
    foreach $file (@todo) {
	$file = "$dir/$file";
	if (-d $file) {
	    return undef if !&scrub_dir($file);
	    if (!rmdir($file)) {
		print STDERR "$prog: couldn't rmdir $file - $!\n";
		return undef;
	    }
	} else {
	    if (!unlink($file)) {
		print STDERR "$prog: couldn't unlink $file - $!\n";
		return undef;
	    }
	}
    }
    return 1;
}

sub
write_file
{
    local($file, $str) = @_;

    if (!open(TEMP, "> $file")) {
	print STDERR "$prog: can't open $file - $!\n";
	return undef;
    }
    binmode(TEMP);
    print TEMP $str;
    if (!close(TEMP)) {
	print STDERR "$prog: error writing $file - $!\n";
	return undef;
    }
    return 1;
}

sub
check_output
{
    local($name, $file, $what, $expect, $expect_pat) = @_;
    local($got) = '';
    local($why) = '';
    local($ret);

    if (!open(TEMP, "< $file")) {
	print STDERR "$prog:$name($what): couldn't open $file after running program - $!\n";
	return undef;
    }
    binmode(TEMP);
    while (<TEMP>) {
	$got .= $_;
    }
    close(TEMP);
    return compare_output($name, $what, $expect, $expect_pat, $got);
}

sub
compare_output
{
    local($name, $what, $expect, $expect_pat, $got) = @_;
    local($why) = '';

    if (defined $expect_pat) {
	$_ = $got;
	$ret = eval "$expect_pat";
	if ($@ ne '') {
	    print STDERR "$prog:$name($what): error evaluating $what pattern: $expect_pat - $@\n";
	    return undef;
	}
	if (!$ret) {
	    $why = "\tunexpected $what - wanted pattern";
	    $why .= &wrap_lines($expect_pat);
	    $why .= "\tgot";
	    $why .= &wrap_lines($got);
	}
    } else {
	$expect = '' if !defined $expect;
	if ($got ne $expect) {
	    $why .= "\tunexpected $what - " . &first_diff($expect, $got) . "\n";
	    $why .= "\twanted";
	    $why .= &wrap_lines($expect);
	    $why .= "\tgot";
	    $why .= &wrap_lines($got);
	}
    }
    return $why;
}

sub
wrap_lines
{
    local($str, $empty) = @_;
    local($nonl) = substr($str, -1, 1) ne "\n";

    return (defined $empty ? $empty : " nothing\n") if $str eq '';
    substr($str, 0, 0) = ":\n";
    $str =~ s/\n/\n\t\t/g;
    if ($nonl) {
	$str .= "\n\t[incomplete last line]\n";
    } else {
	chop($str);
	chop($str);
    }
    return $str;
}

sub
first_diff
{
    local($exp, $got) = @_;
    local($lineno, $char) = (1, 1);
    local($i, $exp_len, $got_len);
    local($ce, $cg);

    $exp_len = length($exp);
    $got_len = length($got);
    if ($exp_len != $got_len) {
	if ($exp_len < $got_len) {
	    if (substr($got, 0, $exp_len) eq $exp) {
		return "got too much output";
	    }
	} elsif (substr($exp, 0, $got_len) eq $got) {
	    return "got too little output";
	}
    }
    for ($i = 0; $i < $exp_len; $i++) {
	$ce = substr($exp, $i, 1);
	$cg = substr($got, $i, 1);
	last if $ce ne $cg;
	$char++;
	if ($ce eq "\n") {
	    $lineno++;
	    $char = 1;
	}
    }
    return "first difference: line $lineno, char $char (wanted '"
	. &format_char($ce) . "', got '"
	. &format_char($cg) . "'";
}

sub
format_char
{
    local($ch, $s);

    $ch = ord($_[0]);
    if ($ch == 10) {
	return '\n';
    } elsif ($ch == 13) {
	return '\r';
    } elsif ($ch == 8) {
	return '\b';
    } elsif ($ch == 9) {
	return '\t';
    } elsif ($ch > 127) {
	$ch -= 127;
	$s = "M-";
    } else {
	$s = '';
    }
    if ($ch < 32) {
	$s .= '^';
	$ch += ord('@');
    } elsif ($ch == 127) {
	return $s . "^?";
    }
    return $s . sprintf("%c", $ch);
}

sub
eval_exit
{
    local($name, $status, $expect) = @_;
    local($expr);
    local($w, $e, $s) = ($status, ($status >> 8) & 0xff, $status & 0x7f);

    $e = -1000 if $status & 0xff;
    $s = -1000 if $s == 0x7f;
    if (!defined $expect) {
	$expr = '$w == 0';
    } elsif ($expect =~ /^(|-)\d+$/) {
	$expr = "\$e == $expect";
    } else {
	$expr = $expect;
	$expr =~ s/\b([wse])\b/\$$1/g;
	$expr =~ s/\b(SIG[A-Z0-9]+)\b/&$1/g;
    }
    $w = eval $expr;
    if ($@ ne '') {
	print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $expect ($@)\n";
	return undef;
    }
    return $w;
}

sub
read_test
{
    local($file, $in, *test) = @_;
    local($field, $val, $flags, $do_chop, $need_redo, $start_lineno);
    local(%cnt, $sfield);

    %test = ();
    %cnt = ();
    while (<$in>) {
	next if /^\s*$/;
	next if /^ *#/;
	last if /^\s*---\s*$/;
	$start_lineno = $. if !defined $start_lineno;
	if (!/^([-\w]+):\s*(|\S|\S.*\S)\s*$/) {
	    print STDERR "$prog:$file:$.: unrecognised line\n";
	    return undef;
	}
	($field, $val) = ($1, $2);
	$sfield = $field;
	$flags = $test_fields{$field};
	if (!defined $flags) {
	    print STDERR "$prog:$file:$.: unrecognised field \"$field\"\n";
	    return undef;
	}
	if ($flags =~ /s/) {
	    local($cnt) = $cnt{$field}++;
	    $test{$field} = $cnt{$field};
	    $cnt = 0 if $cnt eq '';
	    $sfield .= ":$cnt";
	} elsif (defined $test{$field}) {
	    print STDERR "$prog:$file:$.: multiple \"$field\" fields\n";
	    return undef;
	}
	$do_chop = $flags !~ /m/;
	$need_redo = 0;
	if ($val eq '' || $val eq '!' || $flags =~ /p/) {
	    if ($flags =~ /[Mm]/) {
		if ($flags =~ /p/) {
		    if ($val =~ /^!/) {
			$do_chop = 1;
			$val = $';
		    } else {
			$do_chop = 0;
		    }
		    if ($val eq '') {
			print STDERR
		"$prog:$file:$.: no parameters given for field \"$field\"\n";
			return undef;
		    }
		} else {
		    if ($val eq '!') {
			$do_chop = 1;
		    }
		    $val = '';
		}
		while (<$in>) {
		    last if !/^\t/;
		    $val .= $';
		}
		chop $val if $do_chop;
		$do_chop = 1;
		$need_redo = 1;

		# Syntax check on fields that can several instances
		# (can give useful line numbers this way)

		if ($field eq 'file-setup') {
		    local($type, $perm, $rest, $c, $len, $name);

		    # format is: type perm "name"
		    if ($val !~ /^[ \t]*(\S+)[ \t]+(\S+)[ \t]+([^ \t].*)/) {
			print STDERR
		    "$prog:$file:$.: bad parameter line for file-setup field\n";
			return undef;
		    }
		    ($type, $perm, $rest) = ($1, $2, $3);
		    if ($type !~ /^(file|dir|symlink)$/) {
			print STDERR
		    "$prog:$file:$.: bad file type for file-setup: $type\n";
			return undef;
		    }
		    if ($perm !~ /^\d+$/) {
			print STDERR
		    "$prog:$file:$.: bad permissions for file-setup: $type\n";
			return undef;
		    }
		    $c = substr($rest, 0, 1);
		    if (($len = index($rest, $c, 1) - 1) <= 0) {
			print STDERR
    "$prog:$file:$.: missing end quote for file name in file-setup: $rest\n";
			return undef;
		    }
		    $name = substr($rest, 1, $len);
		    if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
			# Note: this is not a security thing - just a sanity
			# check - a test can still use symlinks to get at files
			# outside the test directory.
			print STDERR
"$prog:$file:$.: file name in file-setup is absolute or contains ..: $name\n";
			return undef;
		    }
		}
		if ($field eq 'file-result') {
		    local($type, $perm, $uid, $gid, $matchType,
			  $rest, $c, $len, $name);

		    # format is: type perm uid gid matchType "name"
		    if ($val !~ /^\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S.*)/) {
			print STDERR
		    "$prog:$file:$.: bad parameter line for file-result field\n";
			return undef;
		    }
		    ($type, $perm, $uid, $gid, $matchType, $rest)
			= ($1, $2, $3, $4, $5, $6);
		    if ($type !~ /^(file|dir|symlink)$/) {
			print STDERR
		    "$prog:$file:$.: bad file type for file-result: $type\n";
			return undef;
		    }
		    if ($perm !~ /^\d+$/ && $perm ne '*') {
			print STDERR
		    "$prog:$file:$.: bad permissions for file-result: $perm\n";
			return undef;
		    }
		    if ($uid !~ /^\d+$/ && $uid ne '*') {
			print STDERR
		    "$prog:$file:$.: bad user-id for file-result: $uid\n";
			return undef;
		    }
		    if ($gid !~ /^\d+$/ && $gid ne '*') {
			print STDERR
		    "$prog:$file:$.: bad group-id for file-result: $gid\n";
			return undef;
		    }
		    if ($matchType !~ /^(exact|pattern)$/) {
			print STDERR
		"$prog:$file:$.: bad match type for file-result: $matchType\n";
			return undef;
		    }
		    $c = substr($rest, 0, 1);
		    if (($len = index($rest, $c, 1) - 1) <= 0) {
			print STDERR
    "$prog:$file:$.: missing end quote for file name in file-result: $rest\n";
			return undef;
		    }
		    $name = substr($rest, 1, $len);
		    if ($name =~ /^\// || $name =~ /(^|\/)\.\.(\/|$)/) {
			# Note: this is not a security thing - just a sanity
			# check - a test can still use symlinks to get at files
			# outside the test directory.
			print STDERR
"$prog:$file:$.: file name in file-result is absolute or contains ..: $name\n";
			return undef;
		    }
		}
	    } elsif ($val eq '') {
		print STDERR
		    "$prog:$file:$.: no value given for field \"$field\"\n";
		return undef;
	    }
	}
	$val .= "\n" if !$do_chop;
	$test{$sfield} = $val;
	redo if $need_redo;
    }
    if ($_ eq '') {
	if (%test) {
	    print STDERR
	      "$prog:$file:$start_lineno: end-of-file while reading test\n";
	    return undef;
	}
	return 0;
    }

    while (($field, $val) = each %test_fields) {
	if ($val =~ /r/ && !defined $test{$field}) {
	    print STDERR
	      "$prog:$file:$start_lineno: required field \"$field\" missing\n";
	    return undef;
	}
    }

    $test{':full-name'} = substr($file, $file_prefix_skip) . ":$test{'name'}";
    $test{':long-name'} = "$file:$start_lineno:$test{'name'}";

    # Syntax check on specific fields
    if (defined $test{'expected-fail'}) {
	if ($test{'expected-fail'} !~ /^(yes|no)$/) {
	    print STDERR
	      "$prog:$test{':long-name'}: bad value for expected-fail field\n";
	    return undef;
	}
	$test{'expected-fail'} = $1 eq 'yes';
    } else {
	$test{'expected-fail'} = 0;
    }
    if (defined $test{'need-ctty'}) {
	if ($test{'need-ctty'} !~ /^(yes|no)$/) {
	    print STDERR
	      "$prog:$test{':long-name'}: bad value for need-ctty field\n";
	    return undef;
	}
	$test{'need-ctty'} = $1 eq 'yes';
    } else {
	$test{'need-ctty'} = 0;
    }
    if (defined $test{'need-pass'}) {
	if ($test{'need-pass'} !~ /^(yes|no)$/) {
	    print STDERR
	      "$prog:$test{':long-name'}: bad value for need-pass field\n";
	    return undef;
	}
	$test{'need-pass'} = $1 eq 'yes';
    } else {
	$test{'need-pass'} = 1;
    }
    if (defined $test{'arguments'}) {
	local($firstc) = substr($test{'arguments'}, 0, 1);

	if (substr($test{'arguments'}, -1, 1) ne $firstc) {
	    print STDERR "$prog:$test{':long-name'}: arguments field doesn't start and end with the same character\n";
	    return undef;
	}
    }
    if (defined $test{'env-setup'}) {
	local($firstc) = substr($test{'env-setup'}, 0, 1);

	if (substr($test{'env-setup'}, -1, 1) ne $firstc) {
	    print STDERR "$prog:$test{':long-name'}: env-setup field doesn't start and end with the same character\n";
	    return undef;
	}
    }
    if (defined $test{'expected-exit'}) {
	local($val) = $test{'expected-exit'};

	if ($val =~ /^(|-)\d+$/) {
	    if ($val < 0 || $val > 255) {
		print STDERR "$prog:$test{':long-name'}: expected-exit value $val not in 0..255\n";
		return undef;
	    }
	} elsif ($val !~ /^([\s<>+-=*%\/&|!()]|\b[wse]\b|\bSIG[A-Z0-9]+\b)+$/) {
	    print STDERR "$prog:$test{':long-name'}: bad expected-exit expression: $val\n";
	    return undef;
	}
    } else {
	$test{'expected-exit'} = 0;
    }
    if (defined $test{'expected-stdout'}
	&& defined $test{'expected-stdout-pattern'})
    {
	print STDERR "$prog:$test{':long-name'}: can't use both expected-stdout and expected-stdout-pattern\n";
	return undef;
    }
    if (defined $test{'expected-stderr'}
	&& defined $test{'expected-stderr-pattern'})
    {
	print STDERR "$prog:$test{':long-name'}: can't use both expected-stderr and expected-stderr-pattern\n";
	return undef;
    }
    if (defined $test{'time-limit'}) {
	if ($test{'time-limit'} !~ /^\d+$/ || $test{'time-limit'} == 0) {
	    print STDERR
	      "$prog:$test{':long-name'}: bad value for time-limit field\n";
	    return undef;
	}
    } elsif (defined $default_time_limit) {
	$test{'time-limit'} = $default_time_limit;
    }

    if (defined $known_tests{$test{'name'}}) {
	print STDERR "$prog:$test{':long-name'}: warning: duplicate test name ${test{'name'}}\n";
    }
    $known_tests{$test{'name'}} = 1;

    return 1;
}

sub
tty_msg
{
    local($msg) = @_;

    open(TTY, "> /dev/tty") || return 0;
    print TTY $msg;
    close(TTY);
    return 1;
}

sub
never_called_funcs
{
	return 0;
	&tty_msg("hi\n");
	&never_called_funcs();
	&catch_sigalrm();
	$old_env{'foo'} = 'bar';
	$internal_test_fields{'foo'} = 'bar';
}

sub
check_file_result
{
    local(*test) = @_;

    return '' if (!defined $test{'file-result'});

    local($why) = '';
    local($i);
    local($type, $perm, $uid, $gid, $rest, $c, $len, $name);
    local(@stbuf);

    for ($i = 0; $i < $test{'file-result'}; $i++) {
	$val = $test{"file-result:$i"};

	# format is: type perm "name"
	($type, $perm, $uid, $gid, $matchType, $rest) =
	    split(' ', $val, 6);
	$c = substr($rest, 0, 1);
	$len = index($rest, $c, 1) - 1;
	$name = substr($rest, 1, $len);
	$rest = substr($rest, 2 + $len);
	$perm = oct($perm) if $perm =~ /^\d+$/;

	@stbuf = lstat($name);
	if (!@stbuf) {
	    $why .= "\texpected $type \"$name\" not created\n";
	    next;
	}
	if ($perm ne '*' && ($stbuf[2] & 07777) != $perm) {
	    $why .= "\t$type \"$name\" has unexpected permissions\n";
	    $why .= sprintf("\t\texpected 0%o, found 0%o\n",
		    $perm, $stbuf[2] & 07777);
	}
	if ($uid ne '*' && $stbuf[4] != $uid) {
	    $why .= "\t$type \"$name\" has unexpected user-id\n";
	    $why .= sprintf("\t\texpected %d, found %d\n",
		    $uid, $stbuf[4]);
	}
	if ($gid ne '*' && $stbuf[5] != $gid) {
	    $why .= "\t$type \"$name\" has unexpected group-id\n";
	    $why .= sprintf("\t\texpected %d, found %d\n",
		    $gid, $stbuf[5]);
	}

	if ($type eq 'file') {
	    if (-l _ || ! -f _) {
		$why .= "\t$type \"$name\" is not a regular file\n";
	    } else {
		local $tmp = &check_output($test{'long-name'}, $name,
			    "$type contents in \"$name\"",
			    $matchType eq 'exact' ? $rest : undef
			    $matchType eq 'pattern' ? $rest : undef);
		return undef if (!defined $tmp);
		$why .= $tmp;
	    }
	} elsif ($type eq 'dir') {
	    if ($rest !~ /^\s*$/) {
		print STDERR "$prog:$test{':long-name'}: file-result test for directory $name should not have content specified\n";
		return undef;
	    }
	    if (-l _ || ! -d _) {
		$why .= "\t$type \"$name\" is not a directory\n";
	    }
	} elsif ($type eq 'symlink') {
	    if (!-l _) {
		$why .= "\t$type \"$name\" is not a symlink\n";
	    } else {
		local $content = readlink($name);
		if (!defined $content) {
		    print STDERR "$prog:$test{':long-name'}: file-result test for $type $name failed - could not readlink - $!\n";
		    return undef;
		}
		local $tmp = &compare_output($test{'long-name'},
			    "$type contents in \"$name\"",
			    $matchType eq 'exact' ? $rest : undef
			    $matchType eq 'pattern' ? $rest : undef);
		return undef if (!defined $tmp);
		$why .= $tmp;
	    }
	}
    }

    return $why;
}

sub
HELP_MESSAGE
{
    print STDERR $Usage;
    exit 0;
}