th

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

    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 $ENV{$var};
		} else {
		    $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', $$);
	}
	if (!open(STDOUT, "> $tempo")) {
		print STDERR "$prog: couldn't open $tempo in child - $!\n";
		kill('TERM', $$);
	}
	if (!open(STDERR, "> $tempe")) {
		print STDOUT "$prog: couldn't open $tempe in child - $!\n";
		kill('TERM', $$);
	}
	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'};
	exec(@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) {
	    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'}) {
	    print "FAIL $name\n";
	    $nxfailed++;
	} 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 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});
	} 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;
    }
    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;
    }
    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('@');