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.9 $ ') =~ tr/[0-9].//cd;
  16 @EXPORT = qw (run_tests);
  17
  18 my $debug = $ENV{DEBUG};
  19
  20 my @Types = qw (IN OUT ERR AUX CMP 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, AUX, CMP, 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 sub _compare_files ($$$$$)
  95 {
  96   my ($program_name, $test_name, $in_or_out, $actual, $expected) = @_;
  97
  98   my $differ = compare ($expected, $actual);
  99   if ($differ)
 100     {
 101       my $info = (defined $in_or_out ? "std$in_or_out " : '');
 102       warn "$program_name: test $test_name: ${info}mismatch, comparing "
 103         . "$actual (actual) and $expected (expected)\n";
 104       # Ignore any failure, discard stderr.
 105       system "diff -c $actual $expected 2>/dev/null";
 106     }
 107
 108   return $differ;
 109 }
 110
 111 sub _process_file_spec ($$$$$)
 112 {
 113   my ($program_name, $test_name, $file_spec, $type, $junk_files) = @_;
 114
 115   my ($file_name, $contents);
 116   if (!ref $file_spec)
 117     {
 118       ($file_name, $contents) = (undef, $file_spec);
 119     }
 120   elsif (ref $file_spec eq 'HASH')
 121     {
 122       my $n = keys %$file_spec;
 123       die "$program_name: $test_name: $type spec has $n elements --"
 124         . " expected 1\n"
 125           if $n != 1;
 126       ($file_name, $contents) = each %$file_spec;
 127
 128       # This happens for the AUX hash in an io_spec like this:
 129       # {CMP=> ['zy123utsrqponmlkji', {'@AUX@'=> undef}]},
 130       defined $contents
 131         or return $file_name;
 132     }
 133   else
 134     {
 135       die "$program_name: $test_name: invalid RHS in $type-spec\n"
 136     }
 137
 138   my $is_junk_file = (! defined $file_name
 139                       || (($type eq 'IN' || $type eq 'AUX' || $type eq 'CMP')
 140                           && defined $contents));
 141   my $file = _create_file ($program_name, $test_name,
 142                            $file_name, $contents);
 143
 144   if ($is_junk_file)
 145     {
 146       push @$junk_files, $file
 147     }
 148   else
 149     {
 150       # FIXME: put $srcdir in here somewhere
 151       warn "$program_name: $test_name: specified file `$file' does"
 152         . " not exist\n"
 153           if ! -f "$srcdir/$file";
 154     }
 155
 156   return $file;
 157 }
 158
 159 sub _at_replace ($$)
 160 {
 161   my ($map, $s) = @_;
 162   foreach my $eo (qw (AUX OUT ERR))
 163     {
 164       my $f = $map->{$eo};
 165       $f and $s =~ s/\@$eo\@/$f/g;
 166     }
 167   return $s;
 168 }
 169
 170 # FIXME: cleanup on interrupt
 171 # FIXME: extract `do_1_test' function
 172
 173 # FIXME: having to include $program_name here is an expedient kludge.
 174 # Library code doesn't `die'.
 175 sub run_tests ($$$$$)
 176 {
 177   my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_;
 178
 179   # Warn about empty t_spec.
 180   # FIXME
 181
 182   # Remove all temp files upon interrupt.
 183   # FIXME
 184
 185   # Verify that test names are distinct.
 186   my $found_duplicate = 0;
 187   my %seen;
 188   my $t;
 189   foreach $t (@$t_spec)
 190     {
 191       my $test_name = $t->[0];
 192       if ($seen{$test_name})
 193         {
 194           warn "$program_name: $test_name: duplicate test name\n";
 195           $found_duplicate = 1;
 196         }
 197       $seen{$test_name} = 1;
 198     }
 199   return 1 if $found_duplicate;
 200
 201   # FIXME check exit status
 202   system ($prog, '--version') if $verbose;
 203
 204   my @junk_files;
 205   my $fail = 0;
 206   foreach $t (@$t_spec)
 207     {
 208       my @post_compare;
 209       my $test_name = shift @$t;
 210       my $expect = {};
 211       my ($pre, $post);
 212
 213       # FIXME: maybe don't reset this.
 214       $Global_count = 1;
 215       my @args;
 216       my $io_spec;
 217       my %seen_type;
 218       foreach $io_spec (@$t)
 219         {
 220           if (!ref $io_spec)
 221             {
 222               push @args, $io_spec;
 223               next;
 224             }
 225
 226           die "$program_name: $test_name: invalid test spec\n"
 227             if ref $io_spec ne 'HASH';
 228
 229           my $n = keys %$io_spec;
 230           die "$program_name: $test_name: spec has $n elements --"
 231             . " expected 1\n"
 232               if $n != 1;
 233           my ($type, $val) = each %$io_spec;
 234           die "$program_name: $test_name: invalid key `$type' in test spec\n"
 235             if ! $Types{$type};
 236
 237           # Make sure there's no more than one of OUT, ERR, EXIT.
 238           die "$program_name: $test_name: more than one $type spec\n"
 239             if $Zero_one_type{$type} and $seen_type{$type}++;
 240
 241           if ($type eq 'PRE' or $type eq 'POST')
 242             {
 243               $expect->{$type} = $val;
 244               next;
 245             }
 246
 247           if ($type eq 'CMP')
 248             {
 249               my $t = ref $val;
 250               $t && $t eq 'ARRAY'
 251                 or die "$program_name: $test_name: invalid CMP spec\n";
 252               @$val == 2
 253                 or die "$program_name: $test_name: invalid CMP list;  must have"
 254                   . " exactly 2 elements\n";
 255               my @cmp_files;
 256               foreach my $e (@$val)
 257                 {
 258                   my $r = ref $e;
 259                   $r && $r ne 'HASH'
 260                     and die "$program_name: $test_name: invalid element ($r)"
 261                       . " in CMP list;  only scalars and hash references "
 262                         . "are allowed\n";
 263                   if ($r && $r eq 'HASH')
 264                     {
 265                       my $n = keys %$e;
 266                       $n == 1
 267                         or die "$program_name: $test_name: CMP spec has $n "
 268                           . "elements -- expected 1\n";
 269
 270                       # Replace any `@AUX@' in the key of %$e.
 271                       my ($ff, $val) = each %$e;
 272                       my $new_ff = _at_replace $expect, $ff;
 273                       if ($new_ff ne $ff)
 274                         {
 275                           $e->{$new_ff} = $val;
 276                           delete $e->{$ff};
 277                         }
 278                     }
 279                   my $cmp_file = _process_file_spec ($program_name, $test_name,
 280                                                      $e, $type, \@junk_files);
 281                   push @cmp_files, $cmp_file;
 282                 }
 283               push @post_compare, [@cmp_files];
 284
 285               $expect->{$type} = $val;
 286               next;
 287             }
 288
 289           if ($type eq 'EXIT')
 290             {
 291               die "$program_name: $test_name: invalid EXIT code\n"
 292                 if $val !~ /^\d+$/;
 293               # FIXME: make sure $data is numeric
 294               $expect->{EXIT} = $val;
 295               next;
 296             }
 297
 298           my $file = _process_file_spec ($program_name, $test_name, $val,
 299                                          $type, \@junk_files);
 300
 301           if ($type eq 'IN')
 302             {
 303               push @args, _shell_quote $file;
 304             }
 305           elsif ($type eq 'AUX' || $type eq 'OUT' || $type eq 'ERR')
 306             {
 307               $expect->{$type} = $file;
 308             }
 309           else
 310             {
 311               die "$program_name: $test_name: invalid type: $type\n"
 312             }
 313         }
 314
 315       # Expect an exit status of zero if it's not specified.
 316       $expect->{EXIT} ||= 0;
 317
 318       # Allow ERR to be omitted -- in that case, expect no error output.
 319       foreach my $eo (qw (OUT ERR))
 320         {
 321           if (!exists $expect->{$eo})
 322             {
 323               $expect->{$eo} = _create_file ($program_name, $test_name,
 324                                              undef, '');
 325               push @junk_files, $expect->{$eo};
 326             }
 327         }
 328
 329       # FIXME: Does it ever make sense to specify a filename *and* contents
 330       # in OUT or ERR spec?
 331
 332       # FIXME: this is really suboptimal...
 333       my @new_args;
 334       foreach my $a (@args)
 335         {
 336           $a = _at_replace $expect, $a;
 337           push @new_args, $a;
 338         }
 339       @args = @new_args;
 340
 341       warn "$test_name...\n" if $verbose;
 342       &{$expect->{PRE}} if $expect->{PRE};
 343       my %tmp;
 344       $tmp{OUT} = "$test_name.O";
 345       $tmp{ERR} = "$test_name.E";
 346       push @junk_files, $tmp{OUT}, $tmp{ERR};
 347       my @cmd = ($prog, @args, "> $tmp{OUT}", "2> $tmp{ERR}");
 348       my $cmd_str = join ' ', @cmd;
 349       warn "Running command: `$cmd_str'\n" if $debug;
 350       my $rc = 0xffff & system $cmd_str;
 351       if ($rc == 0xff00)
 352         {
 353           warn "$program_name: test $test_name failed: command failed:\n"
 354             . "  `$cmd_str': $!\n";
 355           $fail = 1;
 356           goto cleanup;
 357         }
 358       $rc >>= 8 if $rc > 0x80;
 359       if ($expect->{EXIT} != $rc)
 360         {
 361           warn "$program_name: test $test_name failed: exit status mismatch:"
 362             . "  expected $expect->{EXIT}, got $rc\n";
 363           $fail = 1;
 364           goto cleanup;
 365         }
 366
 367       foreach my $eo (qw (OUT ERR))
 368         {
 369           my $eo_lower = lc $eo;
 370           _compare_files ($program_name, $test_name, $eo_lower,
 371                           $expect->{$eo}, $tmp{$eo})
 372             and $fail = 1;
 373         }
 374
 375     foreach my $pair (@post_compare)
 376       {
 377         my ($a, $b) = @$pair;
 378         _compare_files $program_name, $test_name, undef, $a, $b
 379           and $fail = 1;
 380       }
 381
 382     cleanup:
 383       &{$expect->{POST}} if $expect->{POST};
 384
 385     }
 386
 387   # FIXME: maybe unlink files inside the big foreach loop?
 388   unlink @junk_files if ! $save_temps;
 389
 390   return $fail;
 391 }
 392
 393 ## package return
 394 1;