tests/ls-2/Fetish.pm

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