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.12 $ ') =~ 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 # When running in a DJGPP environment, make $ENV{SHELL} point to bash.
  27 # Otherwise, a bad shell might be used (e.g. command.com) and many
  28 # tests would fail.
  29 defined $ENV{DJDIR}
  30   and $ENV{SHELL} = "$ENV{DJDIR}/bin/bash.exe";
  31
  32 # A file spec: a scalar or a reference to a single-keyed hash
  33 # ================
  34 # 'contents'               contents only (file name is derived from test name)
  35 # {filename => 'contents'} filename and contents
  36 # {filename => undef}      filename only -- $(srcdir)/filename must exist
  37 #
  38 # FIXME: If there is more than one input file, the you can't specify REDIRECT.
  39 # PIPE is still ok.
  40 #
  41 # I/O spec: a hash ref with the following properties
  42 # ================
  43 # - one key/value pair
  44 # - the key must be one of these strings: IN, OUT, ERR, AUX, CMP, EXIT
  45 # - the value must be a file spec
  46 # {OUT => 'data'}    put data in a temp file and compare it to stdout from cmd
  47 # {OUT => {'filename'=>undef}} compare contents of existing filename to
  48 #           stdout from cmd
  49 # {OUT => {'filename'=>[$CTOR, $DTOR]}} $CTOR and $DTOR are references to
  50 #           functions, each which is passed the single argument `filename'.
  51 #           $CTOR must create `filename'.
  52 #           DTOR may be omitted in which case `sub{unlink @_[0]}' is used.
  53 #           FIXME: implement this
  54 # Ditto for `ERR', but compare with stderr
  55 # {EXIT => N} expect exit status of cmd to be N
  56 #
  57 # There may be many input file specs.  File names from the input specs
  58 # are concatenated in order on the command line.
  59 # There may be at most one of the OUT-, ERR-, and EXIT-keyed specs.
  60 # If the OUT-(or ERR)-keyed hash ref is omitted, then expect no output
  61 #   on stdout (or stderr).
  62 # If the EXIT-keyed one is omitted, then expect the exit status to be zero.
  63
  64 # FIXME: Make sure that no junkfile is also listed as a
  65 # non-junkfile (i.e. with undef for contents)
  66
  67 sub _shell_quote ($)
  68 {
  69   my ($string) = @_;
  70   $string =~ s/\'/\'\\\'\'/g;
  71   return "'$string'";
  72 }
  73
  74 sub _create_file ($$$$)
  75 {
  76   my ($program_name, $test_name, $file_name, $data) = @_;
  77   my $file;
  78   if (defined $file_name)
  79     {
  80       $file = $file_name;
  81     }
  82   else
  83     {
  84       $file = "$test_name.$Global_count";
  85       ++$Global_count;
  86     }
  87
  88   warn "creating file `$file' with contents `$data'\n" if $debug;
  89
  90   # The test spec gave a string.
  91   # Write it to a temp file and return tempfile name.
  92   my $fh = new FileHandle "> $file";
  93   die "$program_name: $file: $!\n" if ! $fh;
  94   print $fh $data;
  95   $fh->close || die "$program_name: $file: $!\n";
  96
  97   return $file;
  98 }
  99
 100 sub _compare_files ($$$$$)
 101 {
 102   my ($program_name, $test_name, $in_or_out, $actual, $expected) = @_;
 103
 104   my $differ = compare ($expected, $actual);
 105   if ($differ)
 106     {
 107       my $info = (defined $in_or_out ? "std$in_or_out " : '');
 108       warn "$program_name: test $test_name: ${info}mismatch, comparing "
 109         . "$actual (actual) and $expected (expected)\n";
 110       # Ignore any failure, discard stderr.
 111       system "diff -c $actual $expected 2>/dev/null";
 112     }
 113
 114   return $differ;
 115 }
 116
 117 sub _process_file_spec ($$$$$)
 118 {
 119   my ($program_name, $test_name, $file_spec, $type, $junk_files) = @_;
 120
 121   my ($file_name, $contents);
 122   if (!ref $file_spec)
 123     {
 124       ($file_name, $contents) = (undef, $file_spec);
 125     }
 126   elsif (ref $file_spec eq 'HASH')
 127     {
 128       my $n = keys %$file_spec;
 129       die "$program_name: $test_name: $type spec has $n elements --"
 130         . " expected 1\n"
 131           if $n != 1;
 132       ($file_name, $contents) = each %$file_spec;
 133
 134       # This happens for the AUX hash in an io_spec like this:
 135       # {CMP=> ['zy123utsrqponmlkji', {'@AUX@'=> undef}]},
 136       defined $contents
 137         or return $file_name;
 138     }
 139   else
 140     {
 141       die "$program_name: $test_name: invalid RHS in $type-spec\n"
 142     }
 143
 144   my $is_junk_file = (! defined $file_name
 145                       || (($type eq 'IN' || $type eq 'AUX' || $type eq 'CMP')
 146                           && defined $contents));
 147   my $file = _create_file ($program_name, $test_name,
 148                            $file_name, $contents);
 149
 150   if ($is_junk_file)
 151     {
 152       push @$junk_files, $file
 153     }
 154   else
 155     {
 156       # FIXME: put $srcdir in here somewhere
 157       warn "$program_name: $test_name: specified file `$file' does"
 158         . " not exist\n"
 159           if ! -f "$srcdir/$file";
 160     }
 161
 162   return $file;
 163 }
 164
 165 sub _at_replace ($$)
 166 {
 167   my ($map, $s) = @_;
 168   foreach my $eo (qw (AUX OUT ERR))
 169     {
 170       my $f = $map->{$eo};
 171       $f
 172         and $s =~ /\@$eo\@/
 173           and $s =~ s/\@$eo\@/$f/g;
 174     }
 175   return $s;
 176 }
 177
 178 # FIXME: cleanup on interrupt
 179 # FIXME: extract `do_1_test' function
 180
 181 # FIXME: having to include $program_name here is an expedient kludge.
 182 # Library code doesn't `die'.
 183 sub run_tests ($$$$$)
 184 {
 185   my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_;
 186
 187   # Warn about empty t_spec.
 188   # FIXME
 189
 190   # Remove all temp files upon interrupt.
 191   # FIXME
 192
 193   # Verify that test names are distinct.
 194   my $bad_test_name = 0;
 195   my %seen;
 196   my $t;
 197   foreach $t (@$t_spec)
 198     {
 199       my $test_name = $t->[0];
 200       if ($seen{$test_name})
 201         {
 202           warn "$program_name: $test_name: duplicate test name\n";
 203           $bad_test_name = 1;
 204         }
 205       $seen{$test_name} = 1;
 206
 207       # The test name may be no longer than 12 bytes,
 208       # so that we can add a two-byte suffix without exceeding
 209       # the maximum of 14 imposed on some old file systems.
 210       if (14 < (length $test_name) + 2)
 211         {
 212           warn "$program_name: $test_name: test name is too long (> 12)\n";
 213           $bad_test_name = 1;
 214         }
 215     }
 216   return 1 if $bad_test_name;
 217
 218   # FIXME check exit status
 219   system ($prog, '--version') if $verbose;
 220
 221   my @junk_files;
 222   my $fail = 0;
 223   foreach $t (@$t_spec)
 224     {
 225       my @post_compare;
 226       my $test_name = shift @$t;
 227       my $expect = {};
 228       my ($pre, $post);
 229
 230       # FIXME: maybe don't reset this.
 231       $Global_count = 1;
 232       my @args;
 233       my $io_spec;
 234       my %seen_type;
 235       foreach $io_spec (@$t)
 236         {
 237           if (!ref $io_spec)
 238             {
 239               push @args, $io_spec;
 240               next;
 241             }
 242
 243           die "$program_name: $test_name: invalid test spec\n"
 244             if ref $io_spec ne 'HASH';
 245
 246           my $n = keys %$io_spec;
 247           die "$program_name: $test_name: spec has $n elements --"
 248             . " expected 1\n"
 249               if $n != 1;
 250           my ($type, $val) = each %$io_spec;
 251           die "$program_name: $test_name: invalid key `$type' in test spec\n"
 252             if ! $Types{$type};
 253
 254           # Make sure there's no more than one of OUT, ERR, EXIT.
 255           die "$program_name: $test_name: more than one $type spec\n"
 256             if $Zero_one_type{$type} and $seen_type{$type}++;
 257
 258           if ($type eq 'PRE' or $type eq 'POST')
 259             {
 260               $expect->{$type} = $val;
 261               next;
 262             }
 263
 264           if ($type eq 'CMP')
 265             {
 266               my $t = ref $val;
 267               $t && $t eq 'ARRAY'
 268                 or die "$program_name: $test_name: invalid CMP spec\n";
 269               @$val == 2
 270                 or die "$program_name: $test_name: invalid CMP list;  must have"
 271                   . " exactly 2 elements\n";
 272               my @cmp_files;
 273               foreach my $e (@$val)
 274                 {
 275                   my $r = ref $e;
 276                   $r && $r ne 'HASH'
 277                     and die "$program_name: $test_name: invalid element ($r)"
 278                       . " in CMP list;  only scalars and hash references "
 279                         . "are allowed\n";
 280                   if ($r && $r eq 'HASH')
 281                     {
 282                       my $n = keys %$e;
 283                       $n == 1
 284                         or die "$program_name: $test_name: CMP spec has $n "
 285                           . "elements -- expected 1\n";
 286
 287                       # Replace any `@AUX@' in the key of %$e.
 288                       my ($ff, $val) = each %$e;
 289                       my $new_ff = _at_replace $expect, $ff;
 290                       if ($new_ff ne $ff)
 291                         {
 292                           $e->{$new_ff} = $val;
 293                           delete $e->{$ff};
 294                         }
 295                     }
 296                   my $cmp_file = _process_file_spec ($program_name, $test_name,
 297                                                      $e, $type, \@junk_files);
 298                   push @cmp_files, $cmp_file;
 299                 }
 300               push @post_compare, [@cmp_files];
 301
 302               $expect->{$type} = $val;
 303               next;
 304             }
 305
 306           if ($type eq 'EXIT')
 307             {
 308               die "$program_name: $test_name: invalid EXIT code\n"
 309                 if $val !~ /^\d+$/;
 310               # FIXME: make sure $data is numeric
 311               $expect->{EXIT} = $val;
 312               next;
 313             }
 314
 315           my $file = _process_file_spec ($program_name, $test_name, $val,
 316                                          $type, \@junk_files);
 317
 318           if ($type eq 'IN')
 319             {
 320               push @args, _shell_quote $file;
 321             }
 322           elsif ($type eq 'AUX' || $type eq 'OUT' || $type eq 'ERR')
 323             {
 324               $expect->{$type} = $file;
 325             }
 326           else
 327             {
 328               die "$program_name: $test_name: invalid type: $type\n"
 329             }
 330         }
 331
 332       # Expect an exit status of zero if it's not specified.
 333       $expect->{EXIT} ||= 0;
 334
 335       # Allow ERR to be omitted -- in that case, expect no error output.
 336       foreach my $eo (qw (OUT ERR))
 337         {
 338           if (!exists $expect->{$eo})
 339             {
 340               $expect->{$eo} = _create_file ($program_name, $test_name,
 341                                              undef, '');
 342               push @junk_files, $expect->{$eo};
 343             }
 344         }
 345
 346       # FIXME: Does it ever make sense to specify a filename *and* contents
 347       # in OUT or ERR spec?
 348
 349       # FIXME: this is really suboptimal...
 350       my @new_args;
 351       foreach my $a (@args)
 352         {
 353           $a = _at_replace $expect, $a;
 354           push @new_args, $a;
 355         }
 356       @args = @new_args;
 357
 358       warn "$test_name...\n" if $verbose;
 359       &{$expect->{PRE}} if $expect->{PRE};
 360       my %tmp;
 361       $tmp{OUT} = "$test_name.O";
 362       $tmp{ERR} = "$test_name.E";
 363       push @junk_files, $tmp{OUT}, $tmp{ERR};
 364       my @cmd = ($prog, @args, "> $tmp{OUT}", "2> $tmp{ERR}");
 365       my $cmd_str = join ' ', @cmd;
 366       warn "Running command: `$cmd_str'\n" if $debug;
 367       my $rc = 0xffff & system $cmd_str;
 368       if ($rc == 0xff00)
 369         {
 370           warn "$program_name: test $test_name failed: command failed:\n"
 371             . "  `$cmd_str': $!\n";
 372           $fail = 1;
 373           goto cleanup;
 374         }
 375       $rc >>= 8 if $rc > 0x80;
 376       if ($expect->{EXIT} != $rc)
 377         {
 378           warn "$program_name: test $test_name failed: exit status mismatch:"
 379             . "  expected $expect->{EXIT}, got $rc\n";
 380           $fail = 1;
 381           goto cleanup;
 382         }
 383
 384       foreach my $eo (qw (OUT ERR))
 385         {
 386           my $eo_lower = lc $eo;
 387           _compare_files ($program_name, $test_name, $eo_lower,
 388                           $expect->{$eo}, $tmp{$eo})
 389             and $fail = 1;
 390         }
 391
 392     foreach my $pair (@post_compare)
 393       {
 394         my ($a, $b) = @$pair;
 395         _compare_files $program_name, $test_name, undef, $a, $b
 396           and $fail = 1;
 397       }
 398
 399     cleanup:
 400       &{$expect->{POST}} if $expect->{POST};
 401
 402     }
 403
 404   # FIXME: maybe unlink files inside the big foreach loop?
 405   unlink @junk_files if ! $save_temps;
 406
 407   return $fail;
 408 }
 409
 410 ## package return
 411 1;