# $MirOS: src/bin/mksh/check.pl,v 1.49 2017/05/05 21:17:31 tg Exp $

# $OpenBSD: th,v 1.1 2013/12/02 20:39:44 millert Exp $

#-

# Copyright (c) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2011,

#		2012, 2013, 2014, 2015, 2017

#	mirabilos <m@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,

#					    UNIXROOT, 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).

#					@utflocale@ is substituted from -U.

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

# require Config only if it exists

# pull EINTR from POSIX.pm or Errno.pm if they exist

# otherwise just skip it

BEGIN {

	eval {

		require Config;

		import Config;

		1;

	};

	$EINTR = 0;

	eval {

		require POSIX;

		$EINTR = POSIX::EINTR();

	};

	if ($@) {

		eval {

			require Errno;

			$EINTR = Errno::EINTR();

		} or do {

			$EINTR = 0;

		};

	}

};

use Getopt::Std;

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

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

$Usage = <

Usage: $prog [-Pv] [-C cat] [-e e=v] [-p prog] [-s fn] [-T dir] \

       [-t tmo] [-U lcl] 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 dir	Use dir instead of /tmp to hold temporary files

	-t t	Use t as default time limit for tests (default is unlimited)

	-U lcl	Use lcl as UTF-8 locale (e.g. C.UTF-8) instead of the default

	-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'

	);

$nfailed = 0;

$nifailed = 0;

$nxfailed = 0;

$npassed = 0;

$nxpassed = 0;

%known_tests = ();

if (!getopts('C:Ee:Pp:s:T:t:U: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;

$is_ebcdic = defined $opt_E && $opt_E;

$test_set = $opt_s;

$temp_base = $opt_T || "/tmp";

$utflocale = $opt_U || (($os eq "hpux") ? "en_US.utf8" : "en_US.UTF-8");

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 ($is_ebcdic) {

	$categories{'shell:ebcdic-yes'} = 1;

	$categories{'shell:ascii-no'} = 1;

} else {

	$categories{'shell:ebcdic-no'} = 1;

	$categories{'shell:ascii-yes'} = 1;

}

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', 'UNIXROOT', '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};

}

$new_env{'__perlname'} = $^X if ($new_env{'__perlname'} eq '') and -f $^X and -x $^X;

if ($new_env{'__perlname'} eq '') {

	foreach $pathelt (split /:/,$ENV{'PATH'}) {

		chomp($pathelt = `pwd`) if $pathelt eq '';

		my $x = $pathelt . '/' . $^X;

		next unless -f $x and -x $x;

		$new_env{'__perlname'} = $x;

		last;

	}

}

$new_env{'__perlname'} = $^X if ($new_env{'__perlname'} eq '');

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;

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

die "$prog: couldn't cd to $temp_base - $!\n" if !chdir($temp_base);

die "$prog: couldn't get temporary directory base\n" unless -d '.';

$temps = sprintf("chk%d-%d.", $$, time());

$tempi = 0;

until (mkdir(($tempdir = sprintf("%s%03d", $temps, $tempi)), 0700)) {

    die "$prog: couldn't get temporary directory\n" if $tempi++ >= 999;

}

die "$prog: couldn't cd to $tempdir - $!\n" if !chdir($tempdir);

chop($temp_dir = `pwd 2>/dev/null`);

die "$prog: couldn't get temporary directory\n" if $temp_dir 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 '/') &&

      ($os ne 'os2' || substr($test_prog, 1, 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;

# Create temp files

$temps = "${temp_dir}/rts";

$tempi = "${temp_dir}/rti";

$tempo = "${temp_dir}/rto";

$tempe = "${temp_dir}/rte";

$tempdir = "${temp_dir}/rtd";

mkdir($tempdir, 0700) or die "$prog: couldn't mkdir $tempdir - $!\n";

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 " ($nfailed 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;

    rmdir($temp_dir) if defined $temp_dir;

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

    return undef if !&scrub_dir($tempdir);

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

    }

    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 command -v/whence -p/which, 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) {