tests/Fetish.pm

   1 package Fetish;
   2 # This is a testing framework.
   3
   4 # In case you're wondering about the name, it comes from the
   5 # names of the three packages: FIleutils, SH-utils, TExtutils.
   6
   7 require 5.003;
   8 use strict;
   9 use vars qw($VERSION @ISA @EXPORT);
  10
  11 use FileHandle;
  12 use File::Compare qw(compare);
  13
  14 @ISA = qw(Exporter);
  15 ($VERSION = '$Revision: 1.6 $ ') =~ tr/[0-9].//cd;
  16 @EXPORT = qw (run_tests);
  17
  18 my $debug = $ENV{DEBUG};
  19
  20 my @Types = qw (IN OUT ERR EXIT PRE POST);
  21 my %Types = map {$_ => 1} @Types;
  22 my %Zero_one_type = map {$_ => 1} qw (OUT ERR EXIT PRE POST);
  23 my $srcdir = $ENV{srcdir};
  24 my $Global_count = 1;
  25
  26 # A file spec: a scalar or a reference to a single-keyed hash
  27 # ================
  28 # 'contents'               contents only (file name is derived from test name)
  29 # {filename => 'contents'} filename and contents
  30 # {filename => undef}      filename only -- $(srcdir)/filename must exist
  31 #
  32 # FIXME: If there is more than one input file, the you can't specify REDIRECT.
  33 # PIPE is still ok.
  34 #
  35 # I/O spec: a hash ref with the following properties
  36 # ================
  37 # - one key/value pair
  38 # - the key must be one of these strings: IN, OUT, ERR, EXIT
  39 # - the value must be a file spec
  40 # {OUT => 'data'}    put data in a temp file and compare it to stdout from cmd
  41 # {OUT => {'filename'=>undef}} compare contents of existing filename to
  42 #           stdout from cmd
  43 # {OUT => {'filename'=>[$CTOR, $DTOR]}} $CTOR and $DTOR are references to
  44 #           functions, each which is passed the single argument `filename'.
  45 #           $CTOR must create `filename'.
  46 #           DTOR may be omitted in which case `sub{unlink @_[0]}' is used.
  47 #           FIXME: implement this
  48 # Ditto for `ERR', but compare with stderr
  49 # {EXIT => N} expect exit status of cmd to be N
  50 #
  51 # There may be many input file specs.  File names from the input specs
  52 # are concatenated in order on the command line.
  53 # There may be at most one of the OUT-, ERR-, and EXIT-keyed specs.
  54 # If the OUT-(or ERR)-keyed hash ref is omitted, then expect no output
  55 #   on stdout (or stderr).
  56 # If the EXIT-keyed one is omitted, then expect the exit status to be zero.
  57
  58 # FIXME: Make sure that no junkfile is also listed as a
  59 # non-junkfile (i.e. with undef for contents)
  60
  61 sub _shell_quote ($)
  62 {
  63   my ($string) = @_;
  64   $string =~ s/\'/\'\\\'\'/g;
  65   return "'$string'";
  66 }
  67
  68 sub _create_file ($$$$)
  69 {
  70   my ($program_name, $test_name, $file_name, $data) = @_;
  71   my $file;
  72   if (defined $file_name)
  73     {
  74       $file = $file_name;
  75     }
  76   else
  77     {
  78       $file = "$test_name.$Global_count";
  79       ++$Global_count;
  80     }
  81
  82   warn "creating file `$file' with contents `$data'\n" if $debug;
  83
  84   # The test spec gave a string.
  85   # Write it to a temp file and return tempfile name.
  86   my $fh = new FileHandle "> $file";
  87   die "$program_name: $file: $!\n" if ! $fh;
  88   print $fh $data;
  89   $fh->close || die "$program_name: $file: $!\n";
  90
  91   return $file;
  92 }
  93
  94 # FIXME: cleanup on interrupt
  95 # FIXME: extract `do_1_test' function
  96
  97 # FIXME: having to include $program_name here is an expedient kludge.
  98 # Library code doesn't `die'.
  99 sub run_tests ($$$$$)
 100 {
 101   my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_;
 102
 103   # Warn about empty t_spec.
 104   # FIXME
 105
 106   # Remove all temp files upon interrupt.
 107   # FIXME
 108
 109   # Verify that test names are distinct.
 110   my $found_duplicate = 0;
 111   my %seen;
 112   my $t;
 113   foreach $t (@$t_spec)
 114     {
 115       my $test_name = $t->[0];
 116       if ($seen{$test_name})
 117         {
 118           warn "$program_name: $test_name: duplicate test name\n";
 119           $found_duplicate = 1;
 120         }
 121       $seen{$test_name} = 1;
 122     }
 123   return 1 if $found_duplicate;
 124
 125   # FIXME check exit status
 126   system ($prog, '--version') if $verbose;
 127
 128   my @junk_files;
 129   my $fail = 0;
 130   foreach $t (@$t_spec)
 131     {
 132       my $test_name = shift @$t;
 133       my $expect = {};
 134       my ($pre, $post);
 135
 136       # FIXME: maybe don't reset this.
 137       $Global_count = 1;
 138       my @args;
 139       my $io_spec;
 140       my %seen_type;
 141       foreach $io_spec (@$t)
 142         {
 143           if (!ref $io_spec)
 144             {
 145               push @args, $io_spec;
 146               next;
 147             }
 148
 149           die "$program_name: $test_name: invalid test spec\n"
 150             if ref $io_spec ne 'HASH';
 151
 152           my $n = keys %$io_spec;
 153           die "$program_name: $test_name: spec has $n elements --"
 154             . " expected 1\n"
 155               if $n != 1;
 156           my ($type, $val) = each %$io_spec;
 157           die "$program_name: $test_name: invalid key `$type' in test spec\n"
 158             if ! $Types{$type};
 159
 160           # Make sure there's no more than one of OUT, ERR, EXIT.
 161           die "$program_name: $test_name: more than one $type spec\n"
 162             if $Zero_one_type{$type} and $seen_type{$type}++;
 163
 164           if ($type eq 'PRE' or $type eq 'POST')
 165             {
 166               $expect->{$type} = $val;
 167               next;
 168             }
 169
 170           if ($type eq 'EXIT')
 171             {
 172               die "$program_name: $test_name: invalid EXIT code\n"
 173                 if $val !~ /^\d+$/;
 174               # FIXME: make sure $data is numeric
 175               $expect->{EXIT} = $val;
 176               next;
 177             }
 178
 179           my $file_spec = $val;
 180           my ($file_name, $contents);
 181           if (!ref $file_spec)
 182             {
 183               ($file_name, $contents) = (undef, $file_spec);
 184             }
 185           elsif (ref $file_spec eq 'HASH')
 186             {
 187               my $n = keys %$file_spec;
 188               die "$program_name: $test_name: $type spec has $n elements --"
 189                 . " expected 1\n"
 190                   if $n != 1;
 191               ($file_name, $contents) = each %$file_spec;
 192             }
 193           else
 194             {
 195               die "$program_name: $test_name: invalid RHS in $type-spec\n"
 196             }
 197
 198           my $is_junk_file = (! defined $file_name
 199                               || ($type eq 'IN' && defined $contents));
 200           my $file = _create_file ($program_name, $test_name,
 201                                    $file_name, $contents);
 202           if ($type eq 'IN')
 203             {
 204               push @args, _shell_quote $file;
 205             }
 206           else
 207             {
 208               $expect->{$type} = $file;
 209             }
 210
 211           if ($is_junk_file)
 212             {
 213               push @junk_files, $file
 214             }
 215           else
 216             {
 217               # FIXME: put $srcdir in here somewhere
 218               warn "$program_name: $test_name: specified file `$file' does"
 219                 . " not exist\n"
 220                   if ! -f "$srcdir/$file";
 221             }
 222         }
 223
 224       # Expect an exit status of zero if it's not specified.
 225       $expect->{EXIT} ||= 0;
 226
 227       # Allow ERR to be omitted -- in that case, expect no error output.
 228       my $eo;
 229       foreach $eo (qw (OUT ERR))
 230         {
 231           if (!exists $expect->{$eo})
 232             {
 233               $expect->{$eo} = _create_file ($program_name, $test_name,
 234                                              undef, '');
 235               push @junk_files, $expect->{$eo};
 236             }
 237         }
 238
 239       # FIXME: Does it ever make sense to specify a filename *and* contents
 240       # in OUT or ERR spec?
 241
 242       warn "$test_name...\n" if $verbose;
 243       &{$expect->{PRE}} if $expect->{PRE};
 244       my %tmp;
 245       $tmp{OUT} = "$test_name.O";
 246       $tmp{ERR} = "$test_name.E";
 247       push @junk_files, $tmp{OUT}, $tmp{ERR};
 248       my @cmd = ($prog, @args, "> $tmp{OUT}", "2> $tmp{ERR}");
 249       my $cmd_str = join ' ', @cmd;
 250       warn "Running command: `$cmd_str'\n" if $debug;
 251       my $rc = 0xffff & system $cmd_str;
 252       if ($rc == 0xff00)
 253         {
 254           warn "$program_name: test $test_name failed: command failed:\n"
 255             . "  `$cmd_str': $!\n";
 256           $fail = 1;
 257           goto cleanup;
 258         }
 259       $rc >>= 8 if $rc > 0x80;
 260       if ($expect->{EXIT} != $rc)
 261         {
 262           warn "$program_name: test $test_name failed: exit status mismatch:"
 263             . "  expected $expect->{EXIT}, got $rc\n";
 264           $fail = 1;
 265           goto cleanup;
 266         }
 267
 268       foreach $eo (qw (OUT ERR))
 269         {
 270           my $eo_lower = lc $eo;
 271           if (compare ($expect->{$eo}, $tmp{$eo}))
 272             {
 273               warn "$program_name: test $test_name: std$eo_lower mismatch,"
 274                 . " comparing $expect->{$eo} and $tmp{$eo}\n";
 275               $fail = 1;
 276             }
 277         }
 278
 279     cleanup:
 280       &{$expect->{POST}} if $expect->{POST};
 281
 282     }
 283
 284   # FIXME: maybe unlink files inside the big foreach loop?
 285   unlink @junk_files if ! $save_temps;
 286
 287   return $fail;
 288 }
 289
 290 ## package return
 291 1;