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

($attempts, $internal_errors, $errors, $require_errors) = (0, 0, 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'";
}


## 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, $out) = (0, 0, '');
    my($sq, $dq, $bq, $nl, $hh) = (-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;
	
	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, $min1) = (($sq < $dq ? $sq : $dq), ($bq < $nl ? $bq : $nl));
	$min1 = ($min1 < $hh ? $min1 : $hh);
	$min = $min1 if $min > $min1;
	$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 ($hh == $min) {
	    $out .= substr($text, $min + 1, $nl - $min);
	    $lineno++;
	    $pos = $nl + 1;
	} elsif (!$qb && ($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) = @_;
    $tt->file_err("arguments to '\%$script_type' ignored") if $args ne '';
    $tt->file_err("multiple '\%$script_type' sections defined") if $tt->{$script_type};
    my($r, $t) = _read_text($fh);
    my($what) = _shell_split(@{$tt->{$script_type}}, @{$tt->{$script_type . '_lineno'}}, $r, $.);
    $tt->file_err("$what in '\%$script_type'") if $what ne '';
    $t;
}

sub _read_file_section ($$$$) {
    my($fh, $tt, $args, $secname) = @_;
    $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 length
    my($length);
    if (@args && $args[0] =~ /^\+(\d+)$/) {
	$length = $1;
	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';
    }

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

    # 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) = substr($secname, 0, 1) . ":" . $fn;
	if (exists $tt->{$hashkey}) {
	    $tt->file_err("file '$fn' already defined");
	} elsif ($fn !~ m/^[A-Za-z_.0-9]+$/) {
	    $tt->file_err("fileref error: '$fn' contains illegal characters");
	} else {
	    push @{$tt->{$secname}}, $fn;
	}

	$tt->{$hashkey} = $file_data;
    }

    # 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 'stdin' || $command eq 'input') {
		$t = _read_file_section($fh, $tt, $args, 'file');
	    } elsif ($command eq 'file') {
		$t = _read_file_section($fh, $tt, $args, 'file');
	    } elsif ($command eq 'stdout' || $command eq 'output') {
		$t = _read_file_section($fh, $tt, $args, 'expect');
	    } elsif ($command eq 'stderr') {
		$t = _read_file_section($fh, $tt, $args, 'expect');
	    } elsif ($command eq 'expect') {
		$t = _read_file_section($fh, $tt, $args, 'expect');
	    } elsif ($command eq 'expectx') {
		$t = _read_file_section($fh, $tt, $args, 'expectx');
	    } elsif ($command eq 'expectv' || $command eq 'expect_verbatim'
		     || $command eq 'verbatim') {
		$t = _read_file_section($fh, $tt, $args, 'expectv');
	    } elsif ($command eq 'ignore') {
		$t = _read_file_section($fh, $tt, $args, 'ignore');
	    } 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"}) || exists($tt->{"e:$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"};
	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) = <<'EOD';
testie_failed () {
    echo >&2; echo testie_failure:$1 >&2
    exit 1
}
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";
	my(@c, @d);
	_shell_split(@c, @d, $text, 0, $code);
	die if @c != 1;
	chomp $c[0];
	next if $c[0] =~ /^\s*$/s;
	if ($c[0] =~ /\&\s*$/) {
	    $t .= $c[0] . "\n";
	} else {
	    $t .= $c[0] . " || testie_failed \$?\n";
	}
    }

    $t;
}

sub output_error ($$;$) {
    my($tt, $fileref_subr, $script_type) = @_;
    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);

    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_expects ($$) {
    my($tt, $fileref_subr) = @_;
    my($fp) = $tt->{'errprefix'};
    local($/) = undef;
    my($expectx) = 0;

    # check expected files
    foreach my $efn (@{$tt->{'expect'}}, '', @{$tt->{'expectx'}}) {
	if ($efn eq '') {
	    $expectx = 1;
	    next;
	}
	
	if (!open(IN, $fileref_subr->($efn))) {
	    print STDERR $fp, $!, "\n";
	    $::errors++;
	    next;
	}
	my($text) = <IN>;
	$text = '' if !defined($text);
	close IN;

	# escape in common case
	next if $text eq $tt->{"e:$efn"};

	# check that files really disagree
	my($exp) = $tt->{"e:$efn"};
	# 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/;
	next if $text eq $exp;

	# ignore explicitly ignored text
	my($ignores) = '';
	$ignores .= $tt->{"i:$efn"} . "\n" if defined($tt->{"i:$efn"});
	$ignores .= $tt->{"i:all"} . "\n" if defined($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{^(\S[^\n]*)}{\$text =~ s<^$1\[ \\t\]*\$><\\377>mg;\n}mg;
	    eval($ignores);
	}

	# 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 '') {
		$tp++ while $tl[$tp] eq '' || $tl[$tp] eq "\377";
		$tp--;
	    }

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

	    # compare lines
	    if ($expectx) {
		last if $tl[$tp] !~ m/\A$el[$ep]\Z/;
	    } elsif ($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++;
	}
	next if $tp >= @tl || $ep >= @el;

	_output_expectation_error($fp, $efn, $tp + 1, $el[$ep], $tl[$tp]);
    }

    # check expectv files
    foreach my $efn (@{$tt->{'expectv'}}) {
	if (!open(IN, $fileref_subr->($efn))) {
	    print STDERR $fp, $!, "\n";
	    $::errors++;
	    next;
	}
	my($text) = <IN>;
	close IN;

	# escape in common case
	next if $text eq $tt->{"e:$efn"};

	# find the first line of difference
	my(@tl) = split(/\n/, $text);
	my(@el) = split(/\n/, $tt->{"e:$efn"});
	my($p) = 0;
	$p++ while ($p < @tl && $p < @el && $tl[$p] eq $el[$p]);
	_output_expectation_error($fp, $efn, $p + 1, $el[$p], $tl[$p]);
    }

    0;
}


package main;

my($dir, @show, $show_stdout, $show_stderr, $any_tests_done);

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

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

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

    # 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;
	
	my($actual_stderr) = script_fn_to_fn('stderr');
	my($exitval) = system("cd $dir; /bin/sh ./+require+ </dev/null >/dev/null 2>$actual_stderr");

	# if it exited with a bad value, quit
	if ($exitval) {
	    return $tt->output_error(\&out_script_fn_to_fn, 'require');
	} 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;

    # 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) = system("cd $dir; /bin/sh ./+script+ <$actual_stdin >$actual_stdout 2>$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);
    }

    # 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");
    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.
  -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 = "/tmp/testie$$";

my(@tests, $verbose, $preserve_temporaries, $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 (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) {
    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. You write simple files, described below,
that incorporate a shell script to be run, and 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, just give it one or more test script filenames. It will
print useful error messages for failed tests. Alternatively, give it the
names of directories, which 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 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'.

=back

=head1 FILE FORMAT

Testie 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 must succeed, with exit status 0,
or the test will fail.

=item %require

Another shell script (in sh syntax) specifying prerequisites that must be
satisfied before the test can run. Every command must succeed, with exit
status 0, for the test to run.

=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. You can use it for longer comments.

=item %file [+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. FILENAME cannot contain slashes.

=item %expectv [+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 file generated by script
with the provided data. They must match exactly or the test fails.

=item %expect [+LENGTH] FILENAME...

An expected output file for the script. FILENAME can be 'stdout', for
standard output, or a filename. 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 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'.

=item %expectx [+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 [+LENGTH]'.

=item %stdout [+LENGTH]

Same as '%expect stdout [+LENGTH]'.

=item %ignore [[+LENGTH] FILENAME]

Lines in script output that should be ignored, and not considered for
%expect and %expectx matches. Each line in the %ignore section should be 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. 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@icir.org>
