#!/usr/bin/perl

### Copyright notice at the bottom of this file ###

# $Id: tester,v 1.82 2012/01/08 16:34:38 adamm Exp $
#
# $Source: /home/adamm/src/tester/RCS/tester,v $

use strict;
use warnings;
use English qw( -no_match_vars );
use File::Basename qw( basename );
use Getopt::Long;
use Pod::Usage;

use Data::Dumper;
$Data::Dumper::Indent = 1;

my %COMPARE;
my %FAIL;
my $INSIDE     =
    "command"
    . " | compare"
    . " | exit"
    . " | fail"
    . " | report"
    . " | quote s?"
    . " | show"
    . " | status"
    . " | stdout"
    . " | stderr"
    ;
my $WHAT       = "stdout | stderr | exit";
my $OUTSIDE    =
    "COMPARE"
    . " | FAIL"
    . " | PATH"
    . " | QUOTES"
    . " | SHOW"
    . " | STATUS"
    ;
my $PROG       = basename $PROGRAM_NAME;
my @QUOTES     = ( q{"}, q{"} );
my %SHOW       = (
    "stdout" => "stdout: '%s'\n",
    "stderr" => "stderr: '%s'\n",
    "exit"   => "exit: %d\n",
);
my @STATUS     = ( "passed", "failed" );

my $Debug      = "";
my $Error;

sub main {
    my $fail = 0;
    my %options;
    my $pass = 0;
    my $ret;
    my @run;
    my $save;
    my $sep;
    my @tests;

    $save = $SIG{__WARN__};
    $SIG{__WARN__} = \&trap;

    $ret = GetOptions(
	\%options,
	"file|f=s",
	"stop|s",
	"debug|d:s",
	#
	"man"     => sub { pod2usage(-exitstatus => 0, -verbose => 2) },
	"help"    => sub { pod2usage(-exitstatus => 0, -verbose => 2) },
	"version" => sub { printf "%s\n", versionString(); exit 0; },
    );
    if (! $ret) {
	printf STDERR "%s: %s\n\n", $PROG, lcfirst($Error);
	pod2usage(-exitstatus => 2, -verbose => 0);
    }

    $SIG{__WARN__} = $save;

    if (! defined($options{"file"})) {
	printf STDERR "%s: no file specified (-f | --file)\n\n", $PROG;
	pod2usage(-exitstatus => 2, -verbose => 0);
    }

    if (defined $options{"debug"}) {
	if ($options{"debug"}) {
	    $Debug = sprintf ":%s:", $options{"debug"};
	    $Debug =~ s/ , /:/x;
	} else {
	    $Debug = "ALL";
	}
    }
    DEBUG($Debug, "Debug = '%s'\n", $Debug);

    defaultCompare(\%COMPARE);
    DEBUG($Debug, "COMPARE = %s", Dumper(\%COMPARE));

    defaultFail(\%FAIL);
    DEBUG($Debug, "FAIL = %s", Dumper(\%FAIL));

    @tests = ();
    assertGetTests($options{"file"}, \@tests);
    DEBUG($Debug, "\@tests = %s", Dumper(\@tests));

    # Get (or generate) the list of tests to be run
    if (@ARGV) {
	@run = @ARGV;
    } else {
	foreach my $t (@tests) {
	    push @run, $t->{"test"};
	}
    }
    DEBUG($Debug, "\@run = %s", Dumper(\@run));

    $sep = "==>";
    foreach my $test (@run) {
	printf "%s %s\n", $sep, $test;
	incrementPassFail(assertRunTest(\@tests, $test), \$pass, \$fail);
	if ((defined $options{"stop"}) && ($fail > 0)) {
	    printf "\n(remaining tests skipped)\n";
	    last;
	}

	$sep = "\n==>";
    }

    print "--\n";
    printNumPassFail($options{"file"}, $pass, $fail);
    exit !returnPassFail($pass, $fail);
} # main

sub abort {
    my ($status, $prog, @args) = @_;

    if (scalar(@args) > 0) {
	printf STDERR @args;
    }

    if (defined $prog) {
	printf STDERR "%s: aborting\n", $prog;
    }

    exit $status;
} # abort

sub assertGetTests {
    my ($file, $tests) = @_;
    my %compare;
    my %fail;
    my $fh;
    my $inTest;
    my $line;
    my $ok;
    my @quotes;
    my $ret;
    my %show;
    my @status;
    my @tmp;
    my $tx;
    my $what;
    my $word;

    DEBUG($Debug, "opening file '%s'\n", $file);
    if (! open $fh, "<", $file) {
	abort(3, $PROG, "%s: %s: '%s'\n", $PROG, $OS_ERROR, $file);
    }

    %compare = %COMPARE;
    %fail = %FAIL;
    @quotes = @QUOTES;
    %show = %SHOW;
    @status = @STATUS;

    $ok = 1;
    $inTest = $tx = 0;
    while ($line = <$fh>) {
	chomp $line;
	DEBUG($Debug, "> '%s'\n", $line);

	# Ignore blank lines
	if ($line =~ / ^ \s* $ /x) {
	    DEBUG($Debug, "  skipping blank line\n");
	    next;
	}

	# Ignore comment lines
	if ($line =~ / ^ \s* \#/x) {
	    DEBUG($Debug, "  skipping comment\n");
	    next;
	}

	# It duplicates less code and puts less information in multiple
	# places to check "inside v. outside" here rather than at every
	# individual directive
	($word = $line) =~ s/ ^ \s* ( [[:alpha:]]+ ) .* /$1/x;
	DEBUG($Debug, "  word = '%s'\n", $word);
	if (($inTest == 0) && ($word =~ / $INSIDE /x)) {
	    printf STDERR
		"%s: line %d: found '%s' outside test stanza\n",
		$PROG, $NR, $word;
	    $ok = 0;
	    next;
	}

	if (($inTest != 0) && ($word =~ / $OUTSIDE /x)) {
	    printf STDERR
		"%s: line %d: found '%s' inside test stanza\n",
		$PROG, $NR, $word;
	    $ok = 0;
	    next;
	}

	if ($line =~ / ^ COMPARE \s+ ( $WHAT ) \s+ (.*) $ /x) {
	    DEBUG($Debug, "  got COMPARE\n");
	    $ret = parseCompareFail(
		\%compare, $NR, $quotes[0], $line, $quotes[1]
	    );
	    if ($ret > 0) {
		$ok = 0;
	    }

	    next;
	}

	if ($line =~ / ^ FAIL \s+ ( $WHAT ) \s+ (.*) $ /x) {
	    DEBUG($Debug, "  got FAIL\n");
	    $ret = parseCompareFail(
		\%fail, $NR, $quotes[0], $line, $quotes[1]
	    );
	    if ($ret > 0) {
		$ok = 0;
	    }

	    next;
	}

	if ($line =~ / ^ PATH \s+ (.*) $ /x) {
	    DEBUG($Debug, "  got PATH\n");
	    $ENV{"PATH"} = $1;
	    next;
	}

	if ($line =~ / ^ QUOTES \s+ (..) $ /x) {
	    DEBUG($Debug, "  got QUOTES\n");
	    $ret = parseQuotes(\@quotes, $line);
	    if ($ret > 0) {
		$ok = 0;
	    }

	    next;
	}

	if ($line =~ / ^ SHOW \s+ ( $WHAT ) \s+ ( \S.+ ) $ /x) {
	    DEBUG($Debug, "  got SHOW\n");
	    $show{$1} = mungInputString($quotes[0], $2, $quotes[1]);
	    next;
	}

	if ($line =~ / ^ STATUS \s+ .+ $ /x) {
	    DEBUG($Debug, "  got STATUS\n");
	    $ret = parseStatus(\@status, $quotes[0], $line, $quotes[1]);
	    if ($ret > 0) {
		$ok = 0;
	    }

	    next;
	}

	# Start of test
	if ($line =~ / ^ ( [[:alpha:]] [-_[:alpha:][:digit:]]* ) \s+ { $ /x) {
	    DEBUG($Debug, "  got start of test\n");
	    if (getTestByName($tests, $1)) {
		abort(3, $PROG, "%s: duplicate test '%s'\n", $PROG, $1);
	    }

	    $tests->[$tx]{"test"} = $1;
	    $tests->[$tx]{"start"} = $NR;
	    $tests->[$tx]{"compare"} = {
		"stdout" => undef,
		"stderr" => undef,
		"exit"   => undef,
	    };
	    $tests->[$tx]{"fail"} = {
		"stdout" => undef,
		"stderr" => undef,
		"exit"   => undef,
	    };
	    @{$tests->[$tx]{"quotes"}} = @quotes;
	    $tests->[$tx]{"show"} = {
		"stdout" => undef,
		"stderr" => undef,
		"exit"   => undef,
	    };
	    @{$tests->[$tx]{"status"}} = @status;

	    $inTest = 1;
	    next;
	}

	if ($line =~ / ^ \s* command \s+ ( .* ) $ /x) {
	    DEBUG($Debug, "  got command\n");
	    $tests->[$tx]{"command"} = $1;
	    next;
	}

	if ($line =~ / ^ \s* compare \s+ ( $WHAT ) (?: \s+ ( .* ) )? $ /x) {
	    DEBUG($Debug, "  got compare\n");
	    if (defined $2) {
		parseCompareFail(
		    $tests->[$tx]{"compare"},
		    $NR,
		    $tests->[$tx]{"quotes"}[0],
		    $line,
		    $tests->[$tx]{"quotes"}[1]
		);
	    } else {
		$tests->[$tx]{"compare"}{$1} = $compare{$1};
	    }
	    next;
	}

	if ($line =~ / ^ \s* exit \s+ ( \d+ ) $ /x) {
	    DEBUG($Debug, "  got exit\n");
	    $tests->[$tx]{"exit"} = $1;
	    next;
	}

	if ($line =~ / ^ \s* fail \s+ ( $WHAT ) (?: \s+ ( .* ) )? $ /x) {
	    DEBUG($Debug, "  got fail\n");
	    if (defined $2) {
		parseCompareFail(
		    $tests->[$tx]{"fail"},
		    $NR,
		    $tests->[$tx]{"quotes"}[0],
		    $line,
		    $tests->[$tx]{"quotes"}[1]
		);
	    } else {
		$tests->[$tx]{"fail"}{$1} = $fail{$1};
	    }
	    next;
	}

	if ($line =~ / ^ \s* report $ /x) {
	    DEBUG($Debug, "  got report\n");
	    $tests->[$tx]{"report"} = 1;
	    next;
	}

	if ($line =~ / ^ \s* quotes \s+ .. $ /x) {
	    DEBUG($Debug, "  got quotes\n");
	    $ret = parseQuotes($tests->[$tx]{"quotes"}, $line);
	    next;
	}

	if ($line =~ / ^ \s* show \s+ ( $WHAT ) ( \s+ ( \S.* ) )? $ /x) {
	    DEBUG($Debug, "  got show\n");
	    if (defined $3) {
		$tests->[$tx]{"show"}{$1} = mungInputString(
		    $tests->[$tx]{"quotes"}[0],
		    $3,
		    $tests->[$tx]{"quotes"}[1]
		);
	    } else {
		$tests->[$tx]{"show"}{$1} = $show{$1};
	    }
	    next;
	}

	if ($line =~ / ^ \s* status \s+ .+ $ /x) {
	    DEBUG($Debug, "  got status\n");
	    $ret = parseStatus(
		$tests->[$tx]{"status"},
		$tests->[$tx]{"quotes"}[0],
		$line,
		$tests->[$tx]{"quotes"}[1]
	    );
	    next;
	}

	if ($line =~ / ^ \s* stderr \s+ ( .* ) $ /x) {
	    DEBUG($Debug, "  got stderr\n");
	    $tests->[$tx]{"stderr"} = mungInputString(
		$tests->[$tx]{"quotes"}[0],
		$1,
		$tests->[$tx]{"quotes"}[1]
	    );
	    next;
	}

	if ($line =~ / ^ \s* stdout \s+ ( .* ) $ /x) {
	    DEBUG($Debug, "  got stdout\n");
	    $tests->[$tx]{"stdout"} = mungInputString(
		$tests->[$tx]{"quotes"}[0],
		$1,
		$tests->[$tx]{"quotes"}[1]
	    );
	    next;
	}

	# End of test; validate the record we just got
	if ($line =~ / ^ }/x) {
	    DEBUG($Debug, "  got end of test\n");
	    if (! testIsValid($tests->[$tx])) {
		$ok = 0;
	    }

	    ++$tx;
	    $inTest = 0;
	    next;
	}

	# Fall-through == unrecognized line
	abort(
	    3,
	    $PROG,
	    "%s: line %d, unrecognized input: %s: '%s'\n",
	    $PROG, $NR, $PROG, $line
	);
    }

    close $fh;

    if ($ok == 0) {
	abort(3, $PROG, "%s: found errors in file '%s'\n", $PROG, $file);
    } else {
	return;
    }
} # assertGetTests

sub assertRunTest {
    my ($tests, $name) = @_;
    my $ok = 1;
    my @results = ( "-", "-", "-" );
    my %ret;
    my $test;

    # Find the test in the array
    $test = getTestByName($tests, $name);
    if (! defined($test)) {
	abort(2, $PROG, "%s: no such test '%s'\n", $PROG, $name);
    }
    DEBUG($Debug, "test = %s", Dumper($test));

    %ret = doSystem($test->{"command"});
    DEBUG($Debug, "ret = %s", Dumper(\%ret));

    if (defined $test->{"stdout"}) {
	DEBUG($Debug, "> stdout\n");
	if ($ret{"stdout"} eq $test->{"stdout"}) {
	    report($test->{"report"}, "stdout", $test->{"status"}[0]);
	    $results[0] = 1;
	} else {
	    report($test->{"report"}, "stdout", $test->{"status"}[1]);
	    $results[0] = 0;
	    $ok = 0;
	}
    }
    if (defined $test->{"compare"}{"stdout"}) {
	DEBUG($Debug, "> compare stdout\n");
	print23(
	    $test->{"compare"}{"stdout"},
	    $test->{"stdout"},
	    $ret{"stdout"},
	    $test->{"status"}
	);
    };
    if ( (defined $test->{"fail"}{"stdout"}) && ($results[0] == 0) ) {
	DEBUG($Debug, "> fail stdout\n");
	print23(
	    $test->{"fail"}{"stdout"},
	    $test->{"stdout"},
	    $ret{"stdout"},
	    $test->{"status"}
	);
    };
    if (defined $test->{"show"}{"stdout"}) {
	DEBUG($Debug, "> show stdout\n");
	printf $test->{"show"}{"stdout"}, mungOutputString($ret{"stdout"});
    };

    if (defined $test->{"stderr"}) {
	DEBUG($Debug, "> stderr\n");
	if ($ret{"stderr"} eq $test->{"stderr"}) {
	    report($test->{"report"}, "stderr", $test->{"status"}[0]);
	    $results[1] = 1;
	} else {
	    report($test->{"report"}, "stderr", $test->{"status"}[1]);
	    $results[1] = 0;
	    $ok = 0;
	}
    }
    if (defined $test->{"compare"}{"stderr"}) {
	DEBUG($Debug, "> compare stderr\n");
	print23(
	    $test->{"compare"}{"stderr"},
	    $test->{"stderr"},
	    $ret{"stderr"},
	    $test->{"status"}
	);
    };
    if ( (defined $test->{"fail"}{"stderr"}) && ($results[1] == 0) ) {
	DEBUG($Debug, "> fail stderr\n");
	print23(
	    $test->{"fail"}{"stderr"},
	    $test->{"stderr"},
	    $ret{"stderr"},
	    $test->{"status"}
	);
    };
    if (defined $test->{"show"}{"stderr"}) {
	DEBUG($Debug, "> show stderr\n");
	printf $test->{"show"}{"stderr"}, mungOutputString($ret{"stderr"});
    };

    if (defined $test->{"exit"}) {
	DEBUG($Debug, "> exit\n");
	if ($ret{"status"} == $test->{"exit"}) {
	    report($test->{"report"}, "exit", $test->{"status"}[0]);
	    $results[2] = 1;
	} else {
	    report($test->{"report"}, "exit", $test->{"status"}[1]);
	    $results[2] = 0;
	    $ok = 0;
	}
    }
    if (defined $test->{"compare"}{"exit"}) {
	DEBUG($Debug, "> compare exit\n");
	print23(
	    $test->{"compare"}{"exit"},
	    $test->{"exit"},
	    $ret{"status"},
	    $test->{"status"}
	);
    };
    if ( (defined $test->{"fail"}{"exit"}) && ($results[2] == 0) ) {
	DEBUG($Debug, "> fail exit\n");
	print23(
	    $test->{"fail"}{"exit"},
	    $test->{"exit"},
	    $ret{"status"},
	    $test->{"status"}
	);
    };
    if (defined $test->{"show"}{"exit"}) {
	DEBUG($Debug, "> show exit\n");
	printf $test->{"show"}{"exit"}, $ret{"status"};
    };

    printf "results: %s/%s/%s\n", @results;
    return $ok;
} # assertRunTest

sub dateRcsToISO {
    my ($rcsDate) = @_;
    my $isoDate;
    my @months = qw( Xxx Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
    my @parts;

    @parts = split m{/}, $rcsDate;
    $parts[1] =~ s/^0//;
    $parts[2] =~ s/^0//;

    $isoDate =
	sprintf "%02d-%s-%d", $parts[2], $months[$parts[1]], $parts[0];
} # dateRcsToISO

sub defaultCompare {
    my ($ref) = @_;

    parseCompareFail(
	$ref,
	0,
	q{"},
	qq{COMPARE stdout "stdout expected = '%s'\n"}
	.             qq{ "stdout got      = '%s'\n"}
	.             qq{ "stdout match    = %s\n"},
	q{"}
    );

    parseCompareFail(
	$ref,
	0,
	q{"},
	qq{COMPARE stderr "stderr expected = '%s'\n"}
	.             qq{ "stderr got      = '%s'\n"}
	.             qq{ "stderr match    = %s\n"},
	q{"}
    );

    parseCompareFail(
	$ref,
	0,
	q{"},
	qq{COMPARE exit "exit expected = %d\n"}
	.             qq{ "exit got      = %d\n"}
	.             qq{ "exit match    = %s\n"},
	q{"}
    );
} # defaultCompare

sub defaultFail {
    my ($ref) = @_;

    parseCompareFail(
	$ref,
	0,
	q{"},
	qq{FAIL stdout "stdout FAILED:\n  expected = '%s'\n"}
	.                        qq{ "  got      = '%s'\n"},
	q{"}
    );

    parseCompareFail(
	$ref,
	0,
	q{"},
	qq{FAIL stderr "stderr FAILED:\n  expected = '%s'\n"}
	.                          qq{ "  got      = '%s'\n"},
	q{"}
    );

    parseCompareFail(
	$ref,
	0,
	q{"},
	qq{FAIL exit "exit FAILED:\n  expected = %d\n"}
	.                    qq{ "  got      = %d\n"},
	q{"}
    );
} # defaultFail

sub doSystem {
	my ($command, $tmpdir) = @_;
	my $fh;
	my $prog;
	my %results;
	my $ret;
	my $tmpErr;
	my $tmpOut;

	$prog = basename($PROGRAM_NAME);

	if (! defined($tmpdir)) {
		if (defined $ENV{"TMPDIR"}) {
			$tmpdir = $ENV{"TMPDIR"};
		} else {
			$tmpdir = "/tmp";
		}
	}

	($fh, $tmpOut) =
		tempfile("${prog}_stdout.XXXXXX", DIR => $tmpdir);
	close $fh;

	($fh, $tmpErr) =
		tempfile("${prog}_stderr.XXXXXX", DIR => $tmpdir);
	close $fh;

	$command .= " > $tmpOut 2> $tmpErr";

	%results = ();
	$ret = system $command;
	$results{"status"} = WEXITSTATUS($ret);

	if (-s "$tmpOut") {
		$results{"stdout"} = `cat $tmpOut`;
	} else {
		$results{"stdout"} = "";
	}

	if (-s "$tmpErr") {
		$results{"stderr"} = `cat $tmpErr`;
	} else {
		$results{"stderr"} = "";
	}

	unlink $tmpOut, $tmpErr;
	return %results;
} # doSystem

sub equal {
    my ($value1, $value2) = @_;

    if (($value1 =~ /\A \d+ \z/x) && ($value2 =~ /\A \d+ \z/x)) {
	DEBUG($Debug, "%d == %d\n", $value1, $value2);
	return $value1 == $value2;
    } else {
	DEBUG(
	    $Debug,
	    "'%s' eq '%s'\n",
	    mungInputString(q{"}, $value1, q{"}),
	    mungInputString(q{"}, $value2, q{"})
	);
	return $value1 eq $value2;
    }

} # equal

sub getTestByName {
    my ($tests, $name) = @_;

    DEBUG($Debug, "name = '%s'\n", $name);
    for my $tx (0..scalar(@{$tests}) - 1) {
	DEBUG($Debug, "[%d]{test} = '%s'\n", $tx, $tests->[$tx]{"test"});
	if ($tests->[$tx]{"test"} eq $name) {
	    return $tests->[$tx];
	}
    }

    return;
} # getTestByName

sub incrementPassFail {
	my $result;
	my $pass;
	my $fail;

	($result, $pass, $fail) = @_;
	if ($result) {
		++$$pass;
	} else {
		++$$fail;
	}
	return;
} # incrementPassFail

sub mungInputString {
    my ($l_quote, $string, $r_quote) = @_;

    $string =~ s/ \A $l_quote //x;
    $string =~ s/ $r_quote \z //x;
    $string =~ s/ \\n /\n/xg;
    $string =~ s/ \\t /\t/xg;
    return $string;
} # mungInputString

sub mungOutputString {
    my ($string) = @_;

    $string =~ s/ \n /\\n/xg;
    $string =~ s/ \t /\\t/xg;
    return $string;
} # mungOutputString

#
# Input:
#    reference to destination hash
#    line number
#    left quote
#    string
#    right quote
#
# Return:
#     0 - OK
#     1 - unrecognized line
#     2 - incorrect number of strings
#
sub parseCompareFail {
    my ($ref, $lineNum, $left, $str, $right) = @_;
    my $emptyOK;
    my $lcCompFailRegexp;
    my $numStrs;
    my @tmp;
    my $ucCompFailRegexp;
    my $what;

    DEBUG($Debug, "=> '%s'\n", mungOutputString($str));

    $lcCompFailRegexp = "compare | fail";
    $ucCompFailRegexp = uc $lcCompFailRegexp;

    if ($str =~ / \A ( $ucCompFailRegexp ) \s+ ( $WHAT ) /x) {
	$emptyOK = 0;
    } elsif ($str =~ / \A \s* ( $lcCompFailRegexp ) \s+ ( $WHAT ) \s* /x) {
	$emptyOK = 1;
    } else {
	printf STDERR "%s: line %d: unrecognized input: '%s'\n",
	    $PROG, $NR, $str;
	return 1;
    }
    DEBUG($Debug, "emptyOK = %d\n", $emptyOK);

    $str =~ s/ \A \s* (?: $lcCompFailRegexp ) \s+ ( $WHAT ) \s* //ix;
    DEBUG($Debug, "str = '%s'\n", mungOutputString($str));
    $what = $1;
    DEBUG($Debug, "what = '%s'\n", $what);
    $ref->{$what} = [];

    if ($str =~ / \A $left /x) {
	@tmp = split / $right \s+ $left /x, $str;
    } else {
	@tmp = split / \s+ /x, $str;
    }
    $numStrs = scalar @tmp;
    DEBUG($Debug, "numStrs = %d\n", $numStrs);
    if (($numStrs == 1) || ($numStrs > 3)) {
	printf STDERR "%s: line %d: expected 2 or 3 strings, got %d\n",
	    $PROG, $NR, $numStrs;
	printf STDERR "%s: line %d: '%s'\n", $PROG, $NR, $str;
	return 2;
    } elsif (($numStrs == 0) && ($emptyOK == 0)) {
	printf STDERR "%s: line %d: expected 2 or 3 strings, got %d\n",
	    $PROG, $NR, $numStrs;
	printf STDERR "%s: line %d: '%s'\n", $PROG, $NR, $str;
	return 2;
    }

    # At this point, numStrs == 0 is always OK
    if ($numStrs == 0) {
	DEBUG($Debug, "returning 0 because numStrs == 0\n");
	return 0;
    }

    DEBUG($Debug, "storing 1 and 2\n");
    $ref->{$what}[0] = mungInputString($left, $tmp[0], $right);
    $ref->{$what}[1] = mungInputString($left, $tmp[1], $right);
    if ($numStrs == 3) {
	DEBUG($Debug, "storing 3\n");
	$ref->{$what}[2] = mungInputString($left, $tmp[2], $right);
    }

    DEBUG($Debug, "returning 0\n");
    return 0;
} # parseCompareFail

#
# Input:
#    reference to destination array
#    string
#
# Return:
#     0 - OK
#     1 - incorrect number of characters
#
sub parseQuotes {
    my ($ref, $str) = @_;
    my $numChars;

    DEBUG($Debug, "=> '%s'\n", $str);

    $str =~ s/ \A \s* quotes \s+ ( .. ) $ /$1/ix;
    DEBUG($Debug, "=> '%s'\n", $str);

    @{$ref} = split //, $str;
    $numChars = scalar @{$ref};
    DEBUG($Debug, "numChars = %d\n", $numChars);
    if ($numChars == 2) {
	return 0;
    } else {
	printf STDERR "%s: line %d: expected 2 quote characters, got %d\n",
	    $PROG, $NR, $numChars;
	printf STDERR "%s: line %d: '%s'\n", $PROG, $NR, $str;
	return 1;
    }
} # parseQuotes

#
# Input:
#    reference to destination array
#    left quote
#    string
#    right quote
#
# Return:
#     0 - OK
#     1 - incorrect number of strings
#
sub parseStatus {
    my ($ref, $left, $str, $right) = @_;
    my $numStrs;

    DEBUG($Debug, "=> '%s'\n", $left);
    DEBUG($Debug, "=> '%s'\n", mungOutputString($str));
    DEBUG($Debug, "=> '%s'\n", $right);

    $str =~ s/ \A \s* status \s+ ( .+ ) $ /$1/ix;
    DEBUG($Debug, "str = '%s'\n", mungOutputString($str));

    if ($str =~ / \A $left /x) {
	@{$ref} = split / $right \s+ $left /x, $str;
    } else {
	@{$ref} = split / \s+ /x, $str;
    }
    $numStrs = scalar @{$ref};
    DEBUG($Debug, "numStrs = %d\n", $numStrs);
    if ($numStrs != 2) {
	printf STDERR "%s: line %d: expected 2 strings, got %d\n",
	    $PROG, $NR, $numStrs;
	printf STDERR "%s: line %d: '%s'\n", $PROG, $NR, $str;
	return 1;
    }

    DEBUG($Debug, "munging 0 and 1\n");
    $ref->[0] = mungInputString($left, $ref->[0], $right);
    $ref->[1] = mungInputString($left, $ref->[1], $right);

    return 0;
} # parseStatus

sub print23 {
    my ($spec, $expected, $got, $status) = @_;

    if (! defined($expected)) {
	$expected = "";
    }

    printf $spec->[0], mungOutputString($expected);
    printf $spec->[1], mungOutputString($got);
    if (scalar(@{$spec}) == 3) {
	if (equal($expected, $got)) {
	    printf $spec->[2], $status->[0];
	} else {
	    printf $spec->[2], $status->[1];
	}
    }
} # print23

sub printNumPassFail {
	my ($string, $pass, $fail) = @_;
	printf "%s: %d pass / %d fail\n", $string, $pass, $fail;
	return;
} # printNumPassFail

sub report {
    my ($report, $what, $result) = @_;

    if ($report) {
	printf "%s: %s\n", $what, $result;
    }
} # report

sub returnPassFail {
	if ($_[1]) {
		return 0;
	} else {
		return 1;
	}
} # returnPassFail

sub testIsValid {
    my ($test) = @_;
    my $count = 0;
    my $ok = 1;

    if (! defined($test->{"command"})) {
	printf STDERR "%s: test '%s' (line %d): no 'command' found\n",
	    $PROG, $test->{"test"}, $test->{"start"};
	$ok = 0;
    }

    foreach my $key ( "stdout", "stderr", "exit" ) {
	if (defined $test->{$key}) {
	    ++$count;
	    DEBUG($Debug, "got %s\n", $key);
	}
    }
    if ($count == 0) {
	printf STDERR "%s: test '%s' (line %d): no 'conditions' found\n",
	    $PROG, $test->{"test"}, $test->{"start"};
	 printf STDERR 
	    "%s: (where 'conditions' is one of 'stdout', 'stderr',"
	    ." or 'exit')\n",
	    $PROG;
	$ok = 0;
    }

    return $ok;
} # testIsValid

sub trap {
    # *NOT* my $Error -- this is the global variable!
    $Error = shift @_;
    chomp $Error;
} # trap

sub versionString {
    my @rcsInfo;
    my $string;

    @rcsInfo = split
	/ \s /x, '$Id: tester,v 1.82 2012/01/08 16:34:38 adamm Exp $';

    $rcsInfo[1] = basename $rcsInfo[1], ",v";
    $string = sprintf "%s v%s (%s UTC)",
	$rcsInfo[1],
	$rcsInfo[2],
	dateRcsToISO($rcsInfo[3])
	;

    return $string;
} # versionString

sub DEBUG {
    my ($subList, @args) = @_;
    my $line;
    my @stackframe;
    my $sub;

    @stackframe = caller(1);
    ($sub = $stackframe[3]) =~ s/ ^main:: //x;

    if (($subList eq "ALL") || ($subList =~ / : $sub : /x)) {
	@stackframe = caller(0);
	$line = $stackframe[2];

	printf STDERR "%s:%d: ", $sub, $line;
	printf STDERR @args;
    }
} # DEBUG

main();


#==============================================================================
#==============================================================================


__END__

=head1 NAME

B<tester> - a program for testing other programs

=head1 SYNOPSIS

B<tester> [ B<-d> [ I<sub[,...]> ] ] [ B<-s> ] B<-f> I<FILE> [ test ... ]

B<tester> B<--man> | B<--help>

B<tester> B<--version>

=head1 DESCRIPTION

B<tester> is a program that tests other programs. B<tester> doesn't
require special frameworks, programming languages, libraries, or
anything like that; it is completely self-contained and uses simple
commands in a text file to specify tests and desired results. It it
written in Perl but can test programs written in any language, as long
as those programs can be run from the command line.

The name(s) of one or more tests (as defined in I<FILE>, see below)  may
be given on the command line; if present, only these teste will be run.
The default is to run all tests found in I<FILE>.

=head1 OPTIONS

=over 4

=item B<-f, --file> FILE

read test specifications from I<FILE>

=item B<-s, --stop>

stop after the first failure; the default is to run all tests

=item B<-d, --debug> [ I<sub[,...]> ] ]

(debug)

=item B<--man>

=item B<--help>

show this documentation

=item B<--version>

Show version information then exit.

=back

=head1 INPUT

B<tester> reads its configuration from the file specified by the B<-f>
switch (above); only one file may be given.

In all specifications below, B<what> is always one of C<stdout>,
C<stderr>, or C<exit>; any variant of B<str> is a (quoted) string, and
B<int> in a positive integer. Where B<str1 str2 [ str3 ]> is shown, the
first string will show the expected value, the second will show the
value from the command, and the thrid (if given), will show the status
of the test (pass or fail). All three should be C<printf()>-style format
strings, however, I<\n> and I<\t> are the only escape sequences
recognized.

=over 4

=item I<#>

the line will be treated as a comment (and ignored); blank likes are
also ignored

=item I<COMPARE> B<what> str1 str2 [ str3 ]

set the output strings for I<compare> directives (below)

=item I<FAIL> B<what> str1 str2 [ str3 ]

set the output strings for I<fail> directives (below)

=item I<PATH> str

Set $PATH to C<str> (which should be a colon-separated list of paths)

=item I<QUOTES> lr

set the quote characters for all input strings; C<lr> must be exactly
two characters; default is C<"">; note that lines in specification files
are processed sequentially, so if alternate quotes are desired the
I<QUOTES> line needs to appear before the alternate quotes are used

=item I<SHOW> B<what> str

set the output strings for I<show> directives (below)

=item I<STATUS> pass-str fail-str

set the default "pass" and "fail" strings

=item B<name {>

start of a test stanza; B<name> must start with a letter, then may
contain any combination of letters, digits, dash, and underscore.

=over 4

=item I<command> str

run the command specified by I<str>, capturing stdout, stderr, and the
exit value

=item I<compare> B<what> [ str1 str2 [ str3 ] ]

compare expected and received values for B<what>; output strings (in
order of precedence) are: those (optionally) specified in this
directive, those specified in an I<COMPARE> directive (above), or the
built-n defaults

=item I<exit> int

expected exit value of I<command> (above)

=item I<fail> B<what> [ str1 str2 [ str3 ] ]

identical to I<compare> (above) except that expected and received values
are shown only if they do not match (whereas I<compare> always shows the
values)

=item I<quotes> lr

set the quote characters for input strings in this test; other tests are
not affected; see I<QUOTE> above for details

=item I<report>

report the results (pass/fail) of any tests (I<stdout>, I<stderr>, or
I<exit>)

=item I<show> B<what> [ str ]

show the value received from I<command> (above); the precedence of
output strings is the same as explained in I<compare> and I<fail>
(above), except the global string comes from I<SHOW> (also above)

=item I<status> pass-str fail-str

set the "pass" and "fail" strings for just this test; other tests are
not affected

=item I<stderr> str

expected results of I<command> (above) on stderr; may contain I<\n> and
I<\t> but otherwise must match the results from the command exactly

=item I<stdout> str

expected results of I<command> (above) on stdout; I<str> is identical to
I<stderr> (above)

=back

=item B<}>

=back

Every test stanza must contain at least the following directives:

=over 4

B<name {>

=over 4

I<command>

one of I<stdout>, I<stderr>, or I<exit>

=back

B<}>

=back

=head1 OUTPUT

For each test, at least two lines will be printed:

=over 4

I<==E<gt> name>

results: o/e/x

=back

where I<o>, I<e>, and I<x> correspond to tests I<stdout>, I<stderr>, and
I<exit>, and the results values will be one of C<0> for test failed,
C<1> for test passed, and C<-> for not tested. Directives such as
I<compare>, I<report>, etc. will produce additional output.

After all tests have run, a final line showing the name of the tests
file, the number of tests passed, and the number of tests failed will be
printed.

=head1 EXAMPLES

Basic pass/fail tests:

     true {
         command /bin/true
         exit 0
     }

     false {
	 command /bin/false
	 exit 0
     }

     Test C<true> will pass and C<false> will fail.

Simple pass/fail test:

     echo1 {
	 command echo this is a test
	 stdout "this is a test\n"
	 stderr ""
	 exit 0
	 report
     }

An example of I<compare> versus I<fail>:

     echo2 {
	 command echo this is a test
	 stdout "this is a test\n"
	 compare stdout
     }

     echo3 {
	 command echo this is a test
	 stdout "this is a test\n"
	 fail stdout
     }

     echo4 {
	 command echo this is a test
	 stdout "This is a test.\n"
	 fail stdout
     }

     Rather than try to explain the differences here, put those three
     stanzas in a file and run B<tester>; the differences should be
     obvious.

A more complete example:

     # Global stuff
     QUOTES {}
     COMPARE stdout {out\nexp = '%s'\n} {got = '%s'\n} {?   = %s\n--\n}
     FAIL stderr {STDERR FAIL:\ne = '%s'\n}, {g = '%s'\n}
     PATH bin:/usr/bin:/home/adamm/bin
     SHOW exit {exit value = %d\n}
     STATUS {it worked!} {it didn't work :-(}

     # Test starts here
     example {
	 # Quotes local to this test only
         quotes <>
         command my-command
         stdout <some string\n>
         stderr <>
         exit 0
         compare stdout
	 fail stderr
         show exit
     }

=head1 DEBUGGING

The debugging facility is mostly intended for finding and fixing
problems in the code but it may prove useful for bugs in test
specification files. The B<-d> (or B<--debug>) switch will turn on
debugging output from all subroutines; for more limited output, give a
comma-separated list of one or more subroutine names. For most test
problems, using B<--debug> I<assertRunTest> will give the most useful
output. Not all subroutines produce debugging output, and some should
produce more; someday I may get around to fixing this.

=head1 EXIT STATUS

B<tester> may exit with any of the following values:

     0 - all tests passed
     1 - one or more tests failed
     2 - problems related to the command line
     3 - problems with the test specifications file

=head1 AUTHOR

Adam Moskowitz.

=head1 BUGS

Please report bugs to <bug-reports@menlo.com>.

=cut

###
### Copyright, 2011 - 2012, Moskowitz. All rights reserved.
###
### Any redistribution of this software must retain the above copyright
### notice, this list of conditions, and the following disclaimer.
###
### Without specific prior written permission from the copyright holder,
### you may not charge a fee for the redistribution of this software.
###
### All other redistribution and use is hereby permitted.
###
### This software is provided "as is" and without any express or implied
### warranties, including, without limitation, the implied warranties of
### merchantability and fitness for a particular purpose.
###
