th

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

    } 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:$.: unrecognized line\n";
	    return undef;
	}
	($field, $val) = ($1, $2);
	$sfield = $field;
	$flags = $test_fields{$field};
	if (!defined $flags) {
	    print STDERR "$prog:$file:$.: unrecognized 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 paramter 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 paramter 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{'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;
}