th

一个开放源代码的 AT&T 的 Korn Shell 的复制品, 支持大多数 ksh89 的特性。

#!/usr/local/bin/perl

#
# Test harness for pdksh tests.
#
# 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, pdksh) 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:
#					    USER, LOGNAME, HOME, PATH, SHELL
#					(values taken from the environment of
#					the test harness).
#	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
#					preceeded 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
#					preceeded 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).
# 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 seperator 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.
#

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

require 'signal.ph' unless $os eq 'os2';
require 'errno.ph' unless $os eq 'os2';
require 'getopts.pl';

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

$Usage = <<EOF ;
Usage: $prog [-s test-set] [-C category] [-p prog] [-v] [-e e=v] test-name ...
	-p p	Use p as the program to test
	-C c	Specify the comma separated list of categories the program
		belongs to (see category field).
	-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)
	-P	program (-p) string has multiple words, and the program is in
		the path (kludge option)
	-v	Verbose mode: print reason test failed.
	-e e=v	Set the environment variable e to v for all tests
		(if no =v is given, the current value is used)
    test-name(s) 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',
	);
# 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 = (
#	(defined $^O ? "os:$^O" : "os:unknown"), '1'
	"os:$os", '1'
	);

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

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

%known_tests = ();

if (!&Getopts('C:p:Ps:t:ve:')) {
    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 (('USER', 'LOGNAME', 'HOME', 'PATH', 'SHELL')) {
    $new_env{$env} = $ENV{$env} if defined $ENV{$env};
}
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;

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

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 + $nxfailed;
$tot_passed = $npassed + $nxpassed;
if ($tot_failed || $tot_passed) {
    print "Total failed: $tot_failed";
    print " ($nxfailed unexpected)" if $nxfailed;
    print " (as expected)" if $nfailed && !$nxfailed;
    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') {
	$exitcode = 0;
    } 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;
    }
    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'};

    #print "Running test $name...\n" if $verbose;

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