.

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;