diff options
-rw-r--r-- | tests/Fetish.pm | 275 |
1 files changed, 275 insertions, 0 deletions
diff --git a/tests/Fetish.pm b/tests/Fetish.pm new file mode 100644 index 000000000..4ab7d07e1 --- /dev/null +++ b/tests/Fetish.pm @@ -0,0 +1,275 @@ +package Fetish; +# This is a testing framework. + +# In case you're wondering about the name, it comes from the +# names of the three packages: FIleutils, SH-utils, TExtutils. + +require 5.003; +use strict; +use vars qw($VERSION @ISA @EXPORT); + +use FileHandle; +use File::Compare qw(compare); + +@ISA = qw(Exporter); +($VERSION = '$Revision: 1.1 $ ') =~ tr/[0-9].//cd; +@EXPORT = qw (run_tests); + +my @Types = qw (IN OUT ERR EXIT); +my %Types = map {$_ => 1} @Types; +my %Zero_one_type = map {$_ => 1} qw (OUT ERR EXIT); +my $srcdir = $ENV{srcdir}; +my $Global_count = 1; + +# A file spec: a scalar or a reference to a single-keyed hash +# ================ +# 'contents' contents only (file name is derived from test name) +# {filename => 'contents'} filename and contents +# {filename => undef} filename only -- $(srcdir)/filename must exist +# +# FIXME: If there is more than one input file, the you can't specify REDIRECT. +# PIPE is still ok. +# +# I/O spec: a hash ref with the following properties +# ================ +# - one key/value pair +# - the key must be one of these strings: IN, OUT, ERR, EXIT +# - the value must be a file spec +# {OUT => 'data'} put data in a temp file and compare it to stdout from cmd +# {OUT => {'filename'=>undef}} compare contents of existing filename to +# stdout from cmd +# {OUT => {'filename'=>[$CTOR, $DTOR]}} $CTOR and $DTOR are references to +# functions, each which is passed the single argument `filename'. +# $CTOR must create `filename'. +# DTOR may be omitted in which case `sub{unlink @_[0]}' is used. +# FIXME: implement this +# Ditto for `ERR', but compare with stderr +# {EXIT => N} expect exit status of cmd to be N +# +# There may be many input file specs. File names from the input specs +# are concatenated in order on the command line. +# There may be at most one of the OUT-, ERR-, and EXIT-keyed specs. +# If the OUT-(or ERR)-keyed hash ref is omitted, then expect no output +# on stdout (or stderr). +# If the EXIT-keyed one is omitted, then expect the exit status to be zero. + +# FIXME: Make sure that no junkfile is also listed as a +# non-junkfile (i.e. with undef for contents) + +sub _shell_quote ($) +{ + my ($string) = @_; + $string =~ s/\'/\'\\\'\'/g; + return "'$string'"; +} + +sub _create_file ($$$$) +{ + my ($program_name, $test_name, $file_name, $data) = @_; + my $file; + if (defined $file_name) + { + $file = $file_name; + } + else + { + $file = "$test_name-$$.$Global_count"; + ++$Global_count; + } + + # The test spec gave a string. + # Write it to a temp file and return tempfile name. + my $fh = new FileHandle "> $file"; + die "$program_name: $file: $!\n" if ! $fh; + print $fh $data; + $fh->close || die "$program_name: $file: $!\n"; + + return $file; +} + +# FIXME: cleanup on interrupt +# FIXME: extract `do_1_test' function + +# FIXME: having to include $program_name here is an expedient kludge. +# Library code doesn't `die'. +sub run_tests ($$$$$) +{ + my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_; + + # Warn about empty t_spec. + # FIXME + + # Remove all temp files upon interrupt. + # FIXME + + # Verify that test names are distinct. + my $found_duplicate = 0; + my %seen; + my $t; + foreach $t (@$t_spec) + { + my $test_name = $t->[0]; + if ($seen{$test_name}) + { + warn "$program_name: $test_name: duplicate test name\n"; + $found_duplicate = 1; + } + $seen{$test_name} = 1; + } + return 1 if $found_duplicate; + + # FIXME check exit status + system ($prog, '--version'); + + my @junk_files; + my $fail = 0; + foreach $t (@$t_spec) + { + my $test_name = shift @$t; + my $expect = {}; + + # FIXME: maybe don't reset this. + $Global_count = 1; + my @args; + my $io_spec; + my %seen_type; + foreach $io_spec (@$t) + { + if (!ref $io_spec) + { + push @args, $io_spec; + next; + } + + die "$program_name: $test_name: invalid test spec\n" + if ref $io_spec ne 'HASH'; + + my $n = keys %$io_spec; + die "$program_name: $test_name: spec has $n elements --" + . " expected 1\n" + if $n != 1; + my ($type, $val) = each %$io_spec; + die "$program_name: $test_name: invalid key `$type' in test spec\n" + if ! $Types{$type}; + + # Make sure there's no more than one of OUT, ERR, EXIT. + die "$program_name: $test_name: more than one $type spec\n" + if $Zero_one_type{$type} and $seen_type{$type}++; + + if ($type eq 'EXIT') + { + die "$program_name: $test_name: invalid EXIT code\n" + if $val !~ /^\d+$/; + # FIXME: make sure $data is numeric + $expect->{EXIT} = $val; + next; + } + + my $file_spec = $val; + my ($file_name, $contents); + if (!ref $file_spec) + { + ($file_name, $contents) = (undef, $file_spec); + } + elsif (ref $file_spec eq 'HASH') + { + my $n = keys %$file_spec; + die "$program_name: $test_name: $type spec has $n elements --" + . " expected 1\n" + if $n != 1; + ($file_name, $contents) = each %$file_spec; + } + else + { + die "$program_name: $test_name: invalid RHS in $type-spec\n" + } + + my $is_junk_file = (! defined $file_name + || ($type eq 'IN' && defined $contents)); + my $file = _create_file ($program_name, $test_name, + $file_name, $contents); + if ($type eq 'IN') + { + push @args, _shell_quote $file; + } + else + { + $expect->{$type} = $file; + } + + if ($is_junk_file) + { + push @junk_files, $file + } + else + { + # FIXME: put $srcdir in here somewhere + warn "$program_name: $test_name: specified file `$file' does" + . " not exist\n" + if ! -f "$srcdir/$file"; + } + } + + # Expect an exit status of zero if it's not specified. + $expect->{EXIT} ||= 0; + + # Allow ERR to be omitted -- in that case, expect no error output. + my $eo; + foreach $eo (qw (OUT ERR)) + { + if (!exists $expect->{$eo}) + { + $expect->{$eo} = _create_file ($program_name, $test_name, + undef, ''); + push @junk_files, $expect->{$eo}; + } + } + + # FIXME: Does it ever make sense to specify a filename *and* contents + # in OUT or ERR spec? + + warn "$test_name...\n" if $verbose; + my %tmp; + $tmp{OUT} = "$test_name-out"; + $tmp{ERR} = "$test_name-err"; + push @junk_files, $tmp{OUT}, $tmp{ERR}; + my @cmd = ($prog, @args, "> $tmp{OUT}", "2> $tmp{ERR}"); + my $cmd_str = join ' ', @cmd; + warn "Running command: `$cmd_str'\n" if $verbose; + my $rc = 0xffff & system $cmd_str; + if ($rc == 0xff00) + { + warn "$program_name: test $test_name failed: command failed:\n" + . " `$cmd_str': $!\n"; + $fail = 1; + next; + } + $rc >>= 8 if $rc > 0x80; + if ($expect->{EXIT} != $rc) + { + warn "$program_name: test $test_name failed: exit status mismatch:" + . " expected $expect->{EXIT}, got $rc\n"; + $fail = 1; + next; + } + + foreach $eo (qw (OUT ERR)) + { + my $eo_lower = lc $eo; + if (compare ($expect->{$eo}, $tmp{$eo})) + { + warn "$program_name: test $test_name: std$eo_lower mismatch," + . " comparing $expect->{$eo} and $tmp{$eo}\n"; + $fail = 1; + } + } + } + + # FIXME: maybe unlink files inside the big foreach loop? + unlink @junk_files if ! $save_temps; + + return $fail; +} + +## package return +1; |