#! /usr/bin/perl -w
use Symbol 'qualify_to_ref';
no locale;
use bytes;
require 5.006;

($attempts, $internal_errors, $errors, $require_errors) = (0, 0, 0, 0);
($preserve_temporaries, $expand_mode) = (0, 0);

## utilities

sub index2 ($$;$) {
    my($result) = (defined($_[2]) ? index($_[0], $_[1], $_[2]) : index($_[0], $_[1]));
    $result = length $_[0] if $result < 0;
    $result;
}

sub shquote ($) {
    my($t) = @_;
    $t =~ s/\'/\'\"\'\"\'/g;
    "'$t'";
}

sub min (@) {
    my($m) = pop @_;
    foreach my $mm (@_) {
	$m = $mm if $mm < $m;
    }
    $m;
}


## read file

package Testie;

my %_special_filerefs = ('stdin' => 1, 'stdout' => 2, 'stderr' => 2);
%_variables = ();

# return filename
sub filename ($) {
    $_[0]->{'filename'};
}

# return line number text
sub lineno ($$) {
    my($tt, $lineno) = @_;
    my($fn) = $tt->{'filename'};
    $fn = 'line ' if !defined($fn);
    $fn .= ':' if $fn !~ /[ :]$/;
    "$fn$lineno";
}

# return a command at a given line number
sub command_at ($$;$) {
    my($tt, $lineno, $script_type) = @_;
    return undef if !defined($lineno);
    $lineno =~ s/^\s*|\s*$//g;
    if ($lineno =~ /^(.*):(.*)$/) {
	return undef if $1 ne $tt->{'filename'};
	$lineno = $2;
    } elsif ($lineno =~ /^line (.*)$/) {
	$lineno = $2;
    }

    $script_type = 'script' if !defined($script_type);
    my($lineno_arr) = $tt->{$script_type . '_lineno'};
    for ($i = 0; $i < @$lineno_arr; $i++) {
	return $tt->{$script_type}->[$i] if $lineno_arr->[$i] == $lineno;
    }
    undef;
}

# report an error
sub file_err ($$) {
    my($tt, $text) = @_;
    $text .= "\n" if $text !~ /\n$/s;
    print STDERR $tt->lineno($.), ': ', $text;
    $tt->{'err'}++;
}

sub _shell_split (\@\@$$;$) {
    my($arr, $lineno_arr, $text, $lineno, $rewrite_sub) = @_;
    $rewrite_sub = sub { $_[0] } if !defined($rewrite_sub);
    my($qf, $qb, $func, $out) = (0, 0, 0, '');
    my($sq, $dq, $bq, $nl, $hh, $lb, $rb) = (-2, -2, -2, -2, -2, -2, -2);
    my($first, $pos) = (0, 0);
    $lineno -= ($text =~ tr/\n//);
    
    while ($pos < length $text) {
	$sq = ::index2($text, "\'", $pos) if $sq < $pos;
	$dq = ::index2($text, "\"", $pos) if $dq < $pos;
	$bq = ::index2($text, "\`", $pos) if $bq < $pos;
	$nl = ::index2($text, "\n", $pos) if $nl < $pos;
	$hh = ::index2($text, "#", $pos) if $hh < $pos;
	$lb = ::index2($text, "{", $pos) if $lb < $pos;
	$rb = ::index2($text, "}", $pos) if $rb < $pos;
	
	if ($qf == 1) {
	    $qf = 0 if $sq < length $text;
	    $out .= substr($text, $pos, $sq + 1 - $pos);
	    $pos = $sq + 1;
	    next;
	} elsif ($qf == 2) {
	    $qf = 0 if $dq < length $text;
	    $out .= $rewrite_sub->(substr($text, $pos, $dq - $pos), 2) . '"';
	    $pos = $dq + 1;
	    next;
	}

	# find minimum
	my($min) = ::min($sq, $dq, $bq, $nl, $hh, $lb, $rb);
	$out .= $rewrite_sub->(substr($text, $pos, $min - $pos), 0) . substr($text, $min, 1);
	
	if ($sq == $min) {
	    $qf = 1;
	    $pos = $sq + 1;
	} elsif ($dq == $min) {
	    $qf = 2;
	    $pos = $dq + 1;
	} elsif ($bq == $min) {
	    $qb = !$qb;
	    $pos = $bq + 1;
	} elsif ($lb == $min) {
	    $func++;
	    $pos = $lb + 1;
	} elsif ($rb == $min) {
	    $func--;
	    $pos = $rb + 1;
	} elsif ($hh == $min) {
	    $out .= substr($text, $min + 1, $nl - $min);
	    $lineno++;
	    $pos = $nl + 1;
	} elsif (!$qb && !$func && ($nl == $pos || substr($text, $nl - 1, 1) ne "\\")) {
	    push @$arr, $out;
	    push @$lineno_arr, $lineno;
	    $out = '';
	    $lineno += (substr($text, $first, $nl - $first + 1) =~ tr/\n//);
	    $first = $pos = $nl + 1;
	} else {
	    $pos = $nl + 1;
	}
    }

    if ($first < length $text) {
	push @$arr, $out;
	push @$lineno_arr, $lineno;
    }
    
    if ($qf == 1) {
	"unmatched single quote";
    } elsif ($qf == 2) {
	"unmatched double quote";
    } elsif ($qb) {
	"unmatched backquote";
    } else {
	"";
    }
}

sub _read_text ($) {
    my($fh) = @_;
    my($r, $t) = ('');
    while (defined($t = <$fh>)) {
	last if $t =~ /^\%/;
	$t =~ s/^\\\%/\%/;
	$r .= $t;
    }
    ($r, $t);
}

sub _read_text_into ($$$) {
    my($fh, $tt, $section) = @_;
    my($r, $t) = _read_text($fh);
    $tt->{$section} = '' if !defined($tt->{$section});
    $tt->{$section} .= $r;
    $t;
}

sub _read_script_section ($$$$) {
    my($fh, $tt, $args, $script_type) = @_;
    
    my($lineno_type, $quiet_type) = ($script_type . '_lineno', $script_type . '_quietline');
    $tt->{$lineno_type} = [] if !exists $tt->{$lineno_type};
    $tt->{$quiet_type} = {} if !exists $tt->{$quiet_type};
    
    my($quiet);
    if ($script_type eq 'require' & $args eq '-q') {
	$quiet = 1;
    } elsif ($args ne '') {
	$tt->file_err("arguments to '\%$script_type' ignored");
    }
    #$tt->file_err("multiple '\%$script_type' sections defined") if $tt->{$script_type};
    my($r, $t) = _read_text($fh);
    my $count = @{$tt->{$lineno_type}};
    my($what) = _shell_split(@{$tt->{$script_type}}, @{$tt->{$lineno_type}}, $r, $.);
    $tt->file_err("$what in '\%$script_type'") if $what ne '';
    while ($quiet && $count < @{$tt->{$lineno_type}}) {
	my($line) = $tt->{$lineno_type}->[$count++];
	$tt->{$quiet_type}->{$line} = 1;
    }
    $t;
}

sub _read_file_section ($$$$$) {
    my($fh, $tt, $args, $secname, $prefix) = @_;
    $args =~ s/\s+$//;

    # split arguments to get fileref
    my(@args) = split(/\s+/, $args);

    # assert that we understand $secname
    die if $secname ne 'file' && $secname ne 'expect' && $secname ne 'expectv' && $secname ne 'expectx' && $secname ne 'ignore';

    # check for alternates and length
    my($alternate, $delfirst, $regex_opts, $length) = (0, 0, '', undef);
    while (@args) {
	if ($args[0] eq '-a') {
	    $alternate = 1;
	} elsif ($args[0] eq '-d') {
	    $delfirst = 1;
	} elsif ($args[0] eq '-i') {
	    $regex_opts .= "(?i)";
	} elsif ($args[0] =~ /^\+(\d+)$/) {
	    $length = $1;
	} else {
	    last;
	}
	shift @args;
    }

    # make sure there are filerefs
    if (!@args) {
	push @args, "stdin" if $secname eq 'file';
	push @args, "stdout" if $secname eq 'expect' || $secname eq 'expectv' || $secname eq 'expectx';
	push @args, "all" if $secname eq 'ignore';
    }

    # complain about '%file -a'
    if (($secname eq 'file' || $secname eq 'ignore') && $alternate) {
	$tt->file_err("'\%file -a' is illegal");
    } elsif (($secname eq 'file' || $secname eq 'expectv') && $regex_opts) {
	$tt->file_err("'\%file -i' is illegal");
    }
    
    # read contents
    my($t, $file_data);
    if (defined($length)) {
	read $fh, $file_data, $length;
	$tt->file_err("file too short") if length($file_data) != $length;
	$t = <$fh>;
    } else {
	($file_data, $t) = _read_text($fh);
    }

    # modify contents based on flags
    $alternate = 1 if $secname eq 'ignore'; # 'ignore' always behaves like -a
    if ($delfirst) {
	$file_data =~ s{^.}{}mg;
    }
    if ($regex_opts && $secname eq 'expect') {
	$file_data =~ s{\{\{}{\{\{$regex_opts}g;
    } elsif ($regex_opts) {
	$file_data =~ s{^(?=.)}{$regex_opts}mg;
    }
    
    # stick contents where appropriate
    my($fn);
    foreach $fn (@args) {
	if (($fn eq 'stdin' && $secname ne 'file')
	    || (($fn eq 'stdout' || $fn eq 'stderr') && $secname eq 'file')
	    || ($fn eq 'all' && $secname ne 'ignore')) {
	    $tt->file_err("'$fn' not meaningful for '\%$secname'");
	}

	my($hashkey) = $prefix . ":" . $fn;
	if ($fn !~ m/^[A-Za-z_.0-9]+$/) {
	    $tt->file_err("fileref error: '$fn' contains illegal characters");
	} elsif (!exists($tt->{$hashkey})) {
	    push @{$tt->{$secname}}, $fn;
	    $tt->{$hashkey} = [];
	} elsif (!$alternate) {
	    $tt->file_err("'\%$secname $fn' already defined");
	}

	push @{$tt->{$hashkey}}, $file_data;
	$tt->{"F:$fn"} = 1;
    }

    # return next line
    $t;
}

sub _skip_section ($$) {
    my($fh, $tt) = @_;
    my($t);
    while (defined($t = <$fh>)) {
	last if $t =~ /^%/;
    }
    $t;
}

sub read (*;$) {
    my($fh, $fn) = @_;
    $fh = ::qualify_to_ref($fh, caller);
    
    my($tt) = bless { 'filename' => $fn, 'err' => 0, 'errprefix' => $fn . ": " }, Testie;
    
    my($t, $read_command) = (undef, 0);
    $t = <$fh>;
    while (defined($t)) {
	if ($t =~ /^%\s*(\w+)\s*(.*?)\s*$/) {
	    my($command) = lc($1);
	    my($args) = $2;
	    if ($command eq 'script' || $command eq 'test') {
		$t = _read_script_section($fh, $tt, $args, 'script');
	    } elsif ($command eq 'require') {
		$t = _read_script_section($fh, $tt, $args, 'require');
	    } elsif ($command eq 'info') {
		$tt->file_err("arguments to '\%info' ignored") if $args ne '';
		$t = _read_text_into($fh, $tt, 'info');
	    } elsif ($command eq 'desc') {
		$tt->file_err("arguments to '\%desc' ignored") if $args ne '';
		$t = _read_text_into($fh, $tt, 'desc');
	    } elsif ($command eq 'cut') {
		$t = _read_text_into($fh, $tt, 'cut');
	    } elsif ($command eq 'stdin' || $command eq 'input') {
		$t = _read_file_section($fh, $tt, $args, 'file', 'f');
	    } elsif ($command eq 'file') {
		$t = _read_file_section($fh, $tt, $args, 'file', 'f');
	    } elsif ($command eq 'stdout' || $command eq 'output') {
		$t = _read_file_section($fh, $tt, $args, 'expect', 'e');
	    } elsif ($command eq 'stderr') {
		$t = _read_file_section($fh, $tt, $args, 'expect', 'e');
	    } elsif ($command eq 'expect') {
		$t = _read_file_section($fh, $tt, $args, 'expect', 'e');
	    } elsif ($command eq 'expectx') {
		$t = _read_file_section($fh, $tt, $args, 'expectx', 'x');
	    } elsif ($command eq 'expectv' || $command eq 'expect_verbatim'
		     || $command eq 'verbatim') {
		$t = _read_file_section($fh, $tt, $args, 'expectv', 'v');
	    } elsif ($command eq 'ignore') {
		$t = _read_file_section($fh, $tt, $args, 'ignore', 'i');
	    } elsif ($command eq 'eot') {
		$tt->{'continue'} = 1;
		last;
	    } elsif ($command eq 'eof') {
		last;
	    } else {
		$tt->file_err("unrecognized command '$command'");
		$t = _skip_section($fh, $tt);
	    }
	    $read_command = 1;
	} else {
	    if ($t =~ /^%/) {
		$tt->file_err("bad '\%' command");
	    } elsif ($t !~ /^[\#!]/ && $t =~ /\S/) {
		$tt->file_err("warning: garbage ignored") if $read_command;
		$read_command = 0;
	    }
	    $t = <$fh>;
	}
    }

    $tt;
}

sub have_file ($$) {
    my($tt, $fileref) = @_;
    exists($tt->{"F:$fileref"});
}

sub empty ($) {
    my($tt) = @_;
    !exists($tt->{'script'});
}

sub save_files ($&) {
    my($tt, $fileref_subr) = @_;
    foreach my $fn (@{$tt->{'file'}}) {
	my($actual) = $fileref_subr->($fn);
	next if !defined($actual);
	open OUT, ">$actual" || die "$actual: $!\n";
	print OUT $tt->{"f:$fn"}->[0];
	close OUT;
    }
}

sub script_text ($&$) {
    my($tt, $fileref_subr, $script_type) = @_;
    my($subbody, $var, $val) = '';

    # add variables
    while (($var, $val) = each %_variables) {
	$var = quotemeta($var);
	$val = quotemeta($val);
	$subbody .= "\$t =~ s/(^|[^\\\\])\\\$$var\\b/\${1}$val/g;\n";
	$subbody .= "\$t =~ s/(^|[^\\\\])\\\${$var}\\b/\${1}$val/g;\n";
    }
    
    my($code) = eval("sub { my(\$t) = \@_; $subbody\$t; }");

    my($t) = '';
    if (!$::expand_mode) {
	$t .= <<'EOD;';
testie_failed () {
    exitval=$?
    test $exitval = 0 || (echo; echo testie_failure:$exitval) >&2
    exit $exitval
}
trap testie_failed EXIT
EOD;
    }

    my($scriptarr, $linenoarr) = ($tt->{$script_type}, $tt->{$script_type . "_lineno"});
    foreach my $i (0..$#{$tt->{$script_type}}) {
	my($ln, $text) = ($linenoarr->[$i], $scriptarr->[$i]);
	$t .= "echo >&2; echo testie_lineno:$ln >&2\n" if !$::expand_mode;
	my(@c, @d);
	_shell_split(@c, @d, $text, 0, $code);
	die if @c != 1;
	chomp $c[0];
	next if $c[0] =~ /^\s*$/s;
	$c[0] =~ s,^(\s*)\./,$1../, if !$::expand_mode;
	$t .= $c[0] . "\n";
    }

    $t;
}

sub output_error ($$$$) {
    my($tt, $fileref_subr, $script_type, $verbose) = @_;
    my($fp) = $tt->{'errprefix'};
    
    if (!open(ERR, $fileref_subr->('stderr'))) {
	print STDERR $fp, $!, "\n";
	$::internal_errors++;
	return;
    }
    
    my($errortext, $t, $lineno, $failure) = ('');
    while ($t = <ERR>) {
	if ($t =~ /^testie_lineno:(.*)$/) {
	    $lineno = $1;
	    $errortext = '';
	} elsif ($t =~ /^testie_failure:(.*)$/) {
	    $failure = $1;
	} else {
	    $errortext .= $t;
	}
    }
    close ERR;

    my($failure_text);
    if (!defined($failure)) {
	$failure_text = "undefined error";
    } elsif ($failure == 1) {
	$failure_text = "failure";
    } else {
	$failure_text = "error $failure";
    }
    if (defined($script_type) && $script_type eq 'require') {
	$failure_text = "requirement $failure_text";
	$::require_errors++;
    } else {
	$::errors++;
    }

    $errortext =~ s/\s*\Z//;
    
    my($cmd) = $tt->command_at($lineno, $script_type);
    if ($fp =~ /: $/) {
	chop $fp;
    } else {
	$lineno = "line $lineno";
    }
    $lineno = $tt->filename if !defined($cmd);

    # exit early if quiet
    return 1 if $tt->{$script_type . '_quietline'}->{$lineno} && !$verbose;
    
    if ($errortext =~ /^testie_error:/) {
	while ($errortext =~ /^testie_error:([^\n]*)/g) {
	    print STDERR $fp, $lineno, ": ", $1, "\n";
	}
	$errortext =~ s/^testie_error:([^\n]*)//g;
	$errortext =~ s/\s*//;
	print STDERR $fp, $lineno, ": (There were other errors as well.)\n"
	    if $errortext ne '';
    } elsif (!defined($cmd)) {
	print STDERR $fp, $lineno, ": $failure_text at undefined point in script\n";
    } else {
	$cmd =~ s/^\s*|\s*$//g;
	$cmd =~ s/([\000-\037])/'^' . chr(ord($1) + ord('@'))/eg;
	$cmd =~ s/([\177-\377])/"\\" . sprintf("%03o", ord($1))/eg;
	if (length($cmd) > 40) {
	    $cmd = substr($cmd, 0, 40) . "...";
	}
	print STDERR $fp, $lineno, ": $failure_text at '$cmd'\n";
	while ($errortext =~ /([^\n]*)/g) {
	    print STDERR $fp, $lineno, ":   $1\n" if $1 ne '';
	}
    }

    1;
}

sub _output_expectation_error ($$$$$) {
    my($fp, $efn, $lineno, $wanted, $got) = @_;
    
    # output message
    if ($efn eq 'stdout') {
	print STDERR $fp, "standard output has unexpected value starting at line $lineno\n";
    } elsif ($efn eq 'stderr') {
	print STDERR $fp, "standard error has unexpected value starting at line $lineno\n";
    } else {
	print STDERR $fp, "file $efn has unexpected value starting at line $lineno\n";
    }

    # output '$wanted' and '$got' if possible
    $wanted = "<end of file>" if $wanted eq "\376";
    $wanted =~ s/\r?\n?\Z//;
    $got = "<end of file>" if $got eq "\376";
    $got =~ s/\r?\n?\Z//;
    if ($wanted =~ /\A[\t\040-\176]*\Z/ && $got =~ /\A[\t\040-\176]*\Z/) {
	print STDERR $fp, "$efn:$lineno: expected '$wanted'\n", $fp, "$efn:$lineno: but got  '$got'\n";
    }

    # maintain error count
    $::errors++;
}

sub _check_one_expect ($$$) {
    my($tt, $fileref_subr, $efn) = @_;
    my($fp) = $tt->{'errprefix'};
    my($xtp, $xtl, $xel);

    # read file text
    if (!open(IN, $fileref_subr->($efn))) {
	print STDERR $fp, $efn, ": ", $!, "\n";
	$::errors++;
	return 0;
    }
    my($raw_text) = <IN>;
    $raw_text = '' if !defined($raw_text);
    close IN;

    # prepare $ignores
    my($ignores) = '';
    $ignores .= join("\n", @{$tt->{"i:$efn"}}) . "\n" if exists($tt->{"i:$efn"});
    $ignores .= join("\n", @{$tt->{"i:all"}}) . "\n" if exists($tt->{"i:all"});
    # ignore testie messages
    $ignores .= "testie_lineno:.*\ntestie_error:.*\n" if $efn eq 'stderr';
    if ($ignores ne '') {
	$ignores =~ s/([!\#<>])/\\$1/g;
	$ignores =~ s{^([ \t]*\S[^\n]*)}{\$text =~ s<^$1\[ \\t\]*\$><\\377>mg;\n}mg;
    }
    
    # now compare alternates
    my($mode, $expect_marker) = (0, {});
    foreach my $exp (@{$tt->{"v:$efn"}}, $expect_marker, @{$tt->{"e:$efn"}}, $expect_marker, @{$tt->{"x:$efn"}}) {
	# check for change of mode
	if (ref($exp)) {
	    $mode++;
	    next;
	}
	my($text) = $raw_text;

	# escape in common case
	return 0 if $text eq $exp;

	# check that files really disagree (in later modes)
	if ($mode > 0) {
	    # ignore differences in amounts of whitespace
	    $text =~ s/\s+\n/\n/g;
	    $text =~ s/\n\n+\Z/\n/;
	    $text =~ s/\A\n//;
	    $exp =~ s/\s+\n/\n/g;
	    $exp =~ s/\n\n\n+/\n\n/g;
	    $exp =~ s/\n\n+\Z/\n/;
	    return 0 if $text eq $exp;

	    # ignore explicitly ignored text
	    eval($ignores) if $ignores ne '';
	}

	# line-by-line comparison
	my(@tl) = (split(/\n/, $text), "\376");
	my(@el) = (split(/\n/, $exp), "\376");
	my($tp, $ep) = (0, 0);
	while ($tp < @tl && $ep < @el) {
	    
	    # a single blank line in $exp matches multiple blank lines
	    # in $text
	    if ($el[$ep] eq '' && $tl[$tp] eq '' && $mode > 0) {
		$tp++ while $tl[$tp] eq '' || $tl[$tp] eq "\377";
		$tp--;
	    }

	    # skip ignored lines
	    $tp++ while $tl[$tp] eq "\377";

	    # compare lines
	    if ($mode == 2) {
		last if $tl[$tp] !~ m/\A$el[$ep]\Z/;
	    } elsif ($mode == 1 && $el[$ep] =~ /\{\{/) {
		my($t, $re) = ($el[$ep], '');
		while ($t =~ /\A(.*?)\{\{(.*?)\}\}(.*)\Z/) {
		    $re .= quotemeta($1) . $2;
		    $t = $3;
		}
		$re .= quotemeta($t);
		last if $tl[$tp] !~ m/\A$re\Z/;
	    } elsif ($tl[$tp] ne $el[$ep]) {
		last;
	    }
	    
	    $tp++, $ep++;
	}
	return 0 if $tp >= @tl || $ep >= @el;

	($xtp, $xel, $xtl) = ($tp + 1, $el[$ep], $tl[$tp])
	    if !defined($xtp) || $tp + 1 > $xtp;
    }

    # if we get here, none of the attempts matched
    _output_expectation_error($fp, $efn, $xtp, $xel, $xtl);
}
    

sub check_expects ($$) {
    my($tt, $fileref_subr) = @_;
    my($fp) = $tt->{'errprefix'};
    local($/) = undef;
    my($expectx) = 0;
    my($tp, @tl, $ep, @el);

    # check expected files
    my(%done);
    foreach my $efn (@{$tt->{'expect'}}, @{$tt->{'expectx'}}, @{$tt->{'expectv'}}) {
	next if $done{$efn};
	_check_one_expect($tt, $fileref_subr, $efn);
	$done{$efn} = 1;
    }

    0;
}


package main;

my($dir, @show, $show_stdout, $show_stderr, $any_tests_done, $can_setpgrp);
my($SHELL) = "/bin/sh";

sub script_fn_to_fn ($) {
    my($fn) = @_;
    $fn;
}

sub out_script_fn_to_fn ($) {
    my($fn) = @_;
    "$dir/$fn";
}

sub _shell ($$$$$) {
    my($dir, $scriptfn, $stdin, $stdout, $stderr) = @_;
    $scriptfn = "./$scriptfn" if $scriptfn !~ m|^/|;

    # Create a new process group so we can (likely) kill any children
    # processes the script carelessly left behind.  Thanks, Chuck Blake!
    my($child_pid) = fork();
    if (!defined($child_pid)) {
	die "cannot fork: $!\n";
    } elsif ($child_pid == 0) {
	eval { setpgrp() };
	chdir($dir);
	open(STDIN, "<", $stdin) || die "$stdin: $!\n";
	open(STDOUT, ">", $stdout) || die "$stdout: $!\n";
	open(STDERR, ">", $stderr) || die "$stderr: $!\n";
	exec $SHELL, "-e", $scriptfn;
    } else {
	waitpid($child_pid, 0);	# assume it succeeds
	my($result) = $?;
	kill('HUP', -$child_pid); # kill any processes left behind
	$result;
    }
}

sub execute_test ($$$) {
    my($tt, $fn, $verbose) = @_;
    my($f);

    # count attempt
    $::attempts++;

    # print description in superverbose mode
    if ($verbose > 1) {
	return 0 if $tt->empty;
	print STDERR "\n" if $any_tests_done;
	if ($tt->{'desc'}) {
	    my($desc) = $tt->{'desc'};
	    $desc =~ s/^(.*?)\t/$1 . (' ' x (8 - (length($1) % 8)))/egm
		while $desc =~ /\t/;
	    $desc =~ s/^/  /;
	    print STDERR $fn, " Description:\n", $desc;
	}
	print STDERR $fn, " Results:\n";
	$tt->{'errprefix'} = "  ";
    }

    # note that we're running the test in verbose mode
    if ($verbose == 1) {
	print STDERR $tt->{'errprefix'}, "Running...\n";
    }

    # check requirements
    if (exists $tt->{'require'}) {
	open(SCR, ">$dir/+require+") || die "$dir/+require+: $!\n";
	print SCR $tt->script_text(\&script_fn_to_fn, 'require');
	close SCR;

	if (!$expand_mode) {
	    my($exitval) = _shell($dir, '+require+', '/dev/null', '/dev/null', script_fn_to_fn('stderr'));

	    # if it exited with a bad value, quit
	    if ($exitval) {
		return $tt->output_error(\&out_script_fn_to_fn, 'require', $verbose);
	    } elsif ($verbose) {
		print STDERR $tt->{'errprefix'}, "Requirements OK\n";
	    }
	}
    }

    # save the files it names
    $tt->save_files(\&out_script_fn_to_fn);

    # save the script
    open(SCR, ">$dir/+script+") || die "$dir/+script+: $!\n";
    print SCR $tt->script_text(\&script_fn_to_fn, 'script');
    close SCR;

    # exit if expand mode
    return 0 if ($expand_mode);
    
    # run the script
    my($actual_stdin) = ($tt->have_file('stdin') ? script_fn_to_fn('stdin') : "/dev/null");
    my($actual_stdout) = ($show_stdout || $tt->have_file('stdout') ? script_fn_to_fn('stdout') : "/dev/null");
    my($actual_stderr) = script_fn_to_fn('stderr');
    my($exitval) = _shell($dir, '+script+', $actual_stdin, $actual_stdout, $actual_stderr);
    $any_tests_done = 1;

    # echo files
    foreach $f (@show) {
	if (-r out_script_fn_to_fn($f)) {
	    print "$fn: $f\n", "=" x 79, "\n";
	    local($/) = undef;
	    open(X, out_script_fn_to_fn($f));
	    $_ = <X>;
	    close(X);
	    print $_, "=" x 79, "\n";
	} else {
	    print "$fn: $f does not exist\n";
	}
    }

    # if it exited with a bad value, quit
    if ($exitval) {
	return $tt->output_error(\&out_script_fn_to_fn, 'script', $verbose);
    }

    # check files
    my $old_errors = $::errors;
    if ($exitval = $tt->check_expects(\&out_script_fn_to_fn)) {
	return $exitval;
    }

    if ($verbose && !$tt->empty && $old_errors == $::errors) {
	print STDERR $tt->{'errprefix'}, "Success!\n";
    }

    0;
}

sub run_test (;$$) {
    my($fn, $verbose) = @_;

    # read the testie
    my($tt, $display_fn, $close_in);
    if (!defined($fn) || $fn eq '-') {
	if (!open(IN, "<&=STDIN")) {
	    print STDERR "<stdin>: $!\n";
	    return -1;
	}
	$display_fn = "<stdin>";
    } elsif (-d $fn) {
	print STDERR "$fn: is a directory\n";
	return -1;
    } else {
	if (!open(IN, "<", $fn)) {
	    print STDERR "$fn: $!\n";
	    return -1;
	}
	$display_fn = $fn;
	$close_in = 1;
    }

    my($result, $suffix) = (0, '');
    
    while (1) {
	$tt = Testie::read(IN, $display_fn . $suffix);
	my($this_result) = execute_test($tt, $display_fn . $suffix, $verbose);
	$result = $this_result if $this_result;
	last if !$tt->{'continue'};
	if (!($suffix =~ s/^<(\d+)>$/"<" . ($1+1) . ">"/e)) {
	    $suffix = "<2>";
	}
    }

    close IN if $close_in;
    $result;
}

$SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = $SIG{'__DIE__'} = sub {
    system("/bin/rm -rf $dir 2>/dev/null") if !$preserve_temporaries;
    exit(1);
};



sub help () {
    print <<'EOD;';
'Testie' is a simple test harness.

Usage: testie [OPTIONS] [FILE]...

Options:
  VARIABLE=VALUE             Variable settings for test script.
  -V, --verbose              Print information for successful tests.
  -VV, --superverbose        Print %desc information for all tests.
  -s, --show TESTIEFILE      Show contents of TESTIEFILE on completion.
  --preserve-temporaries     Preserve temporary files.
  -e, --expand               Expand test files into current directory.  
  -v, --version              Print version information and exit.
  --help                     Print this message and exit.

Report bugs and suggestions to <kohler@icir.org>.
EOD;
    exit(0);
}

sub usage () {
    print STDERR <<'EOD;';
Usage: testie [-V] [--preserve-temporaries] [FILE]...
Try 'testie --help' for more information.
EOD;
    exit(1);
}

sub print_version () {
    print <<'EOD;';
Testie 1.1
Copyright (c) 2002-2003 International Computer Science Institute
This is free software; see the source for copying conditions.
There is NO warranty, not even for merchantability or fitness for a
particular purpose.
EOD;
    exit(0);
}

sub argcmp ($$$;\$) {
    my($arg, $opt, $min_match, $store) = @_;
    $$store = undef if defined($store);
    return 0 if substr($arg, 0, 2 + $min_match) ne substr($opt, 0, 2 + $min_match);
    my($eq) = index($arg, '=');
    my($last) = ($eq >= 0 ? $eq : length($arg));
    return 0 if $last > length($opt) || substr($arg, 0, $last) ne substr($opt, 0, $last);
    return 0 if !defined($store) && $eq >= 0;
    $$store = substr($arg, $eq + 1) if defined($store) && $eq >= 0;
    1;
}


# directory searching

sub search_dir ($$) {
    my($dir, $aref) = @_;
    $dir =~ s/\/+$//;
    if (!opendir(DIR, $dir)) {
	print STDERR "$dir: $!\n";
	return;
    }
    my(@f) = grep { !/^\.\.?$/ } readdir(DIR);
    closedir(DIR);
    foreach my $f (@f) {
	if (-d "$dir/$f") {
	    &search_dir("$dir/$f", $aref);
	} elsif ($f =~ /\.testie$/) {
	    push @$aref, "$dir/$f";
	}
    }
}


# argument processing

$dir = "testie$$";

my(@tests, $verbose, $arg);
$verbose = 0;

while (@ARGV) {
    $_ = shift @ARGV;
    if (/^([A-Za-z_]\w*)=(.*)$/s) {
	$Testie::_variables{$1} = $2;
    } elsif (/^-$/) {
	push @tests, $_;
    } elsif (!/^-/) {
	if (-d $_) {
	    search_dir($_, \@tests);
	} else {
	    push @tests, $_;
	}
    } elsif (/^-v$/ || argcmp($_, '--version', 4)) {
	print_version;
    } elsif (/^-V$/ || argcmp($_, '--verbose', 4)) {
	$verbose = 1;
    } elsif (/^-VV$/ || argcmp($_, '--superverbose', 2)) {
	$verbose = 2;
    } elsif (/^-e$/ || argcmp($_, '--expand', 1)) {
	$expand_mode = 1;
	$preserve_temporaries = 1;
	$dir = ".";
    } elsif (argcmp($_, '--help', 1)) {
	help;
    } elsif (argcmp($_, '--preserve-temporaries', 1)) {
	$preserve_temporaries = 1;
    } elsif (/^-s$/ || argcmp($_, '--show', 2)) {
	usage if @ARGV == 0;
	push @show, (shift @ARGV);
    } elsif (/^-s(.+)$/) {
	push @show, $1;
    } elsif (argcmp($_, '--show', 2, $arg)) {
	push @show, $arg;
    } else {
	usage;
    }
}

if (-d $dir && !$expand_mode) {
    print STDERR "warning: $dir directory exists; removing it\n";
    system("/bin/rm -rf $dir");
    -d $dir && die "cannot remove $dir directory: $!\n";
}
mkdir $dir || die "cannot create $dir directory: $!\n";

# check @show for stdout/stderr
foreach my $s (@show) {
    $show_stdout = 1 if $s eq 'stdout';
    $show_stderr = 1 if $s eq 'stderr';
}

push @tests, '-' if !@tests;
foreach my $test (@tests) {
    run_test($test, $verbose);
}

system("/bin/rm -rf $dir") if !$preserve_temporaries;
if ($internal_errors > 0) {
    exit(2);
} elsif ($attempts == 0
	 || ($errors == 0 && $require_errors < $attempts)) {
    exit(0);
} else {
    exit(1);
}


=pod

=head1 NAME

testie - simple test harness

=head1 SYNOPSIS

  testie [OPTIONS] [FILE]...

=head1 DESCRIPTION

Testie is a simple test harness. Each testie test file incorporates a shell
script to be run and, optionally, input and expected output files for that
script. Testie runs the script; the test fails if any of the script
commands fail, or if the script generates unexpected output.

To run testie, pass it one or more test filenames. It will print useful
error messages for failed tests. Alternatively, give it directory names;
the directories are recursively searched for 'F<*.testie>' files.

Return status is 0 if all tests succeed, 1 if any test fails, and 2 if a
test fails due to an internal error. Tests whose %require prerequisites
fail do not affect the return status, except that if all tests'
prerequisites fail, the return status is 1 instead of 0.

=head1 OPTIONS

=over 8

=item I<VARIABLE>=I<VALUE>

Provide a setting for I<VARIABLE>. Occurrences in the script of
'C<$VARIABLE>' or 'C<${VARIABLE}>' will be replaced by I<VALUE>. Note that
this is not an environment variable setting. Variable references to unset
variables are left unchanged.

=item -V, --verbose

Print information to standard error about successful tests as well as
unsuccessful tests.

=item -VV, --superverbose

Like --verbose, but use a slightly different format, and additionally print
every test's %desc section before the test results.

=item -v, --version

Print version number information and exit.

=item --help

Print help information and exit.

=item --preserve-temporaries

Preserve the temporary directory created for the test.

=item -s, --show FILE

Echo the contents of FILE on completion. FILE should be one of the
filenames specified by %file or %expect*, or 'stdout' or 'stderr'.

=item -e, --expand

Don't run the given test; instead, expand its files into the current
directory.  The script is stored in a file called '+script+'.

=back

=head1 FILE FORMAT

Testie test files consist of several sections, each introduced by a line
starting with %. There must be, at least, a %script section.

The %file and %expect* sections define input and/or output files by
name. Testie runs its script in a private directory in F</tmp>; any files
mentioned in %file or %expect* are placed in that directory.

=over 8

=item %script

The shell script (in sh syntax) that controls the test. Testie will run
each command in sequence. Every command in the script must succeed, with
exit status 0, or the test will fail. The script's inputs and outputs are
defined with the %file and %expect* sections.

=item %require [-q]

A shell script (in sh syntax) defining prerequisites that must be satisfied
before the test can run. Every command in the script must succeed, with
exit status 0, for the test to run. %require's output is not checked,
however. The C<-q> flag tells testie not to print an error message if a
requirement fails.

=item %desc

A short description of the test.  In --superverbose mode, its contents are
printed before the test results.

=item %info

This section is ignored. It is intended for information about the test.

=item %cut

This section is ignored. It is intended to comment out obsolete parts of
the test.

=item %file [-d] [+LENGTH] FILENAME...

Create an input file for the script. FILENAME can be 'stdin', which sets
the script's standard input. If LENGTH is provided, the file data consists
of the LENGTH bytes following this line. Otherwise, it consists of the data
up to the next section. The C<-d> flag tells testie to delete the
first character of each line in the section; this makes it possible to
include files that have lines that start with %. FILENAME cannot contain
slashes.

=item %expectv [-a] [-d] [+LENGTH] FILENAME...

An expected output file for the script. FILENAME can be 'stdout', for
standard output. If LENGTH is provided, the file data consists of the
LENGTH bytes following this line; otherwise, it consists of the data up to
the next section.

Testie will run the script, then compare the script's output file with the
provided data. They must match exactly or the test fails.

The C<-a> flag marks this expected output as an alternate. Testie will
compare the script's output file with each provided alternate; the test
succeeds if any of the alternates match. The C<-d> flag behaves as in
%file.

=item %expect [-a] [-d] [-i] [+LENGTH] FILENAME...

An expected output file for the script. Arguments are as for %expectv.

Testie will run the script, then compare the file generated by script
with the provided data. The files are compared line-by-line. Testie
ignores trailing whitespace on each line and in the files at large. It also
ignores lines in the script output that match %ignore patterns (see below).
Blank lines in the %expect data match one or more blank lines in the
output. %expect lines can contain Perl regular expressions, enclosed by two
sets of braces; so the %expect line

    foo{{(bar)?}}

matches either 'foo' or 'foobar'. The C<-i> flag makes any regular
expressions case-insensitive.

=item %expectx [-a] [-d] [-i] [+LENGTH] FILENAME...

%expectx is just like %expect, except that every line is treated as a
regular expression (so there is no need for the "{{ }}" escapes).

=item %stdin [+LENGTH]

Same as '%file stdin [ARGS]'.

=item %stdout [-a] [-d] [-i] [+LENGTH]

Same as '%expect stdout'.

=item %stderr [-a] [-d] [-i] [+LENGTH]

Same as '%expect stderr'.

=item %ignore [-d] [-i] [+LENGTH] [FILENAME]

Each line in the %ignore section is a Perl regular expression.  Lines in
the supplied FILENAME that match any of those regular expressions will not
be considered when comparing files with %expect[x] data.  The regular
expression must match the whole line.  FILENAME may be 'all', in which case
the regular expressions will apply to all %expect[x] files.

=item %eot

Marks the end of the current test.  The rest of the file will be parsed for
additional tests.

=item %eof

The rest of the file is ignored.

=back

=head1 EXAMPLE

This simple testie script checks that 'grep -c' works for a simple output
file.

  %script
  grep -c B.
  %stdin
  Bfoo
  B
  %stdout
  1

=head1 AUTHOR

Eddie Kohler, <kohler@cs.ucla.edu>