tests/Coreutils.pm

   1 package Coreutils;
   2 # This is a testing framework.
   3
   4 # Copyright (C) 1998, 2000, 2001, 2002, 2004, 2005, 2006 Free Software
   5 # Foundation, Inc.
   6
   7 # This program is free software; you can redistribute it and/or modify
   8 # it under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 2 of the License, or
  10 # (at your option) any later version.
  11
  12 # This program is distributed in the hope that it will be useful,
  13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 # GNU General Public License for more details.
  16
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  20 # 02110-1301, USA.
  21
  22 require 5.003;
  23 use strict;
  24 use vars qw($VERSION @ISA @EXPORT);
  25
  26 use FileHandle;
  27 use File::Compare qw(compare);
  28
  29 @ISA = qw(Exporter);
  30 ($VERSION = '$Revision: 1.5 $ ') =~ tr/[0-9].//cd;
  31 @EXPORT = qw (run_tests);
  32
  33 my $debug = $ENV{DEBUG};
  34
  35 my @Types = qw (IN IN_PIPE OUT ERR AUX CMP EXIT PRE POST OUT_SUBST
  36                 ERR_SUBST ENV ENV_DEL);
  37 my %Types = map {$_ => 1} @Types;
  38 my %Zero_one_type = map {$_ => 1}
  39    qw (OUT ERR EXIT PRE POST OUT_SUBST ERR_SUBST ENV);
  40 my $srcdir = $ENV{srcdir};
  41 my $Global_count = 1;
  42
  43 # When running in a DJGPP environment, make $ENV{SHELL} point to bash.
  44 # Otherwise, a bad shell might be used (e.g. command.com) and many
  45 # tests would fail.
  46 defined $ENV{DJDIR}
  47   and $ENV{SHELL} = "$ENV{DJDIR}/bin/bash.exe";
  48
  49 # A file spec: a scalar or a reference to a single-keyed hash
  50 # ================
  51 # 'contents'               contents only (file name is derived from test name)
  52 # {filename => 'contents'} filename and contents
  53 # {filename => undef}      filename only -- $(srcdir)/filename must exist
  54 #
  55 # FIXME: If there is more than one input file, then you can't specify `REDIR'.
  56 # PIPE is still ok.
  57 #
  58 # I/O spec: a hash ref with the following properties
  59 # ================
  60 # - one key/value pair
  61 # - the key must be one of these strings: IN, OUT, ERR, AUX, CMP, EXIT
  62 # - the value must be a file spec
  63 # {OUT => 'data'}    put data in a temp file and compare it to stdout from cmd
  64 # {OUT => {'filename'=>undef}} compare contents of existing filename to
  65 #           stdout from cmd
  66 # {OUT => {'filename'=>[$CTOR, $DTOR]}} $CTOR and $DTOR are references to
  67 #           functions, each which is passed the single argument `filename'.
  68 #           $CTOR must create `filename'.
  69 #           DTOR may be omitted in which case `sub{unlink @_[0]}' is used.
  70 #           FIXME: implement this
  71 # {ERR => ...}
  72 #           Same as for OUT, but compare with stderr, not stdout.
  73 # {OUT_SUBST => 's/variable_output/expected_output/'}
  74 #   Transform actual standard output before comparing it against expected output.
  75 #   This is useful e.g. for programs like du that produce output that
  76 #   varies a lot from system.  E.g., an empty file may consume zero file
  77 #   blocks, or more, depending on the OS and on the file system type.
  78 # {ERR_SUBST => 's/variable_output/expected_output/'}
  79 #   Transform actual stderr output before comparing it against expected.
  80 #   This is useful when verifying that we get a meaningful diagnostic.
  81 #   For example, in rm/fail-2eperm, we have to account for three different
  82 #   diagnostics: Operation not permitted, Not owner, and Permission denied.
  83 # {EXIT => N} expect exit status of cmd to be N
  84 # {ENV => 'VAR=val ...'}
  85 #   Prepend 'VAR=val ...' to the command that we execute via `system'.
  86 # {ENV_DEL => 'VAR'}
  87 #   Remove VAR from the environment just before running the corresponding
  88 #   command, and restore any value just afterwards.
  89 #
  90 # There may be many input file specs.  File names from the input specs
  91 # are concatenated in order on the command line.
  92 # There may be at most one of the OUT-, ERR-, and EXIT-keyed specs.
  93 # If the OUT-(or ERR)-keyed hash ref is omitted, then expect no output
  94 #   on stdout (or stderr).
  95 # If the EXIT-keyed one is omitted, then expect the exit status to be zero.
  96
  97 # FIXME: Make sure that no junkfile is also listed as a
  98 # non-junkfile (i.e. with undef for contents)
  99
 100 sub _shell_quote ($)
 101 {
 102   my ($string) = @_;
 103   $string =~ s/\'/\'\\\'\'/g;
 104   return "'$string'";
 105 }
 106
 107 sub _create_file ($$$$)
 108 {
 109   my ($program_name, $test_name, $file_name, $data) = @_;
 110   my $file;
 111   if (defined $file_name)
 112     {
 113       $file = $file_name;
 114     }
 115   else
 116     {
 117       $file = "$test_name.$Global_count";
 118       ++$Global_count;
 119     }
 120
 121   warn "creating file `$file' with contents `$data'\n" if $debug;
 122
 123   # The test spec gave a string.
 124   # Write it to a temp file and return tempfile name.
 125   my $fh = new FileHandle "> $file";
 126   die "$program_name: $file: $!\n" if ! $fh;
 127   print $fh $data;
 128   $fh->close || die "$program_name: $file: $!\n";
 129
 130   return $file;
 131 }
 132
 133 sub _compare_files ($$$$$)
 134 {
 135   my ($program_name, $test_name, $in_or_out, $actual, $expected) = @_;
 136
 137   my $differ = compare ($expected, $actual);
 138   if ($differ)
 139     {
 140       my $info = (defined $in_or_out ? "std$in_or_out " : '');
 141       warn "$program_name: test $test_name: ${info}mismatch, comparing "
 142         . "$actual (actual) and $expected (expected)\n";
 143       # Ignore any failure, discard stderr.
 144       system "diff -c $actual $expected 2>/dev/null";
 145     }
 146
 147   return $differ;
 148 }
 149
 150 sub _process_file_spec ($$$$$)
 151 {
 152   my ($program_name, $test_name, $file_spec, $type, $junk_files) = @_;
 153
 154   my ($file_name, $contents);
 155   if (!ref $file_spec)
 156     {
 157       ($file_name, $contents) = (undef, $file_spec);
 158     }
 159   elsif (ref $file_spec eq 'HASH')
 160     {
 161       my $n = keys %$file_spec;
 162       die "$program_name: $test_name: $type spec has $n elements --"
 163         . " expected 1\n"
 164           if $n != 1;
 165       ($file_name, $contents) = each %$file_spec;
 166
 167       # This happens for the AUX hash in an io_spec like this:
 168       # {CMP=> ['zy123utsrqponmlkji', {'@AUX@'=> undef}]},
 169       defined $contents
 170         or return $file_name;
 171     }
 172   else
 173     {
 174       die "$program_name: $test_name: invalid RHS in $type-spec\n"
 175     }
 176
 177   my $is_junk_file = (! defined $file_name
 178                       || (($type eq 'IN' || $type eq 'AUX' || $type eq 'CMP')
 179                           && defined $contents));
 180   my $file = _create_file ($program_name, $test_name,
 181                            $file_name, $contents);
 182
 183   if ($is_junk_file)
 184     {
 185       push @$junk_files, $file
 186     }
 187   else
 188     {
 189       # FIXME: put $srcdir in here somewhere
 190       warn "$program_name: $test_name: specified file `$file' does"
 191         . " not exist\n"
 192           if ! -f "$srcdir/$file";
 193     }
 194
 195   return $file;
 196 }
 197
 198 sub _at_replace ($$)
 199 {
 200   my ($map, $s) = @_;
 201   foreach my $eo (qw (AUX OUT ERR))
 202     {
 203       my $f = $map->{$eo};
 204       $f
 205         and $s =~ /\@$eo\@/
 206           and $s =~ s/\@$eo\@/$f/g;
 207     }
 208   return $s;
 209 }
 210
 211 # FIXME: cleanup on interrupt
 212 # FIXME: extract `do_1_test' function
 213
 214 # FIXME: having to include $program_name here is an expedient kludge.
 215 # Library code doesn't `die'.
 216 sub run_tests ($$$$$)
 217 {
 218   my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_;
 219
 220   # Warn about empty t_spec.
 221   # FIXME
 222
 223   # Remove all temp files upon interrupt.
 224   # FIXME
 225
 226   # Verify that test names are distinct.
 227   my $bad_test_name = 0;
 228   my %seen;
 229   my %seen_8dot3;
 230   my $t;
 231   foreach $t (@$t_spec)
 232     {
 233       my $test_name = $t->[0];
 234       if ($seen{$test_name})
 235         {
 236           warn "$program_name: $test_name: duplicate test name\n";
 237           $bad_test_name = 1;
 238         }
 239       $seen{$test_name} = 1;
 240
 241       if (0)
 242         {
 243           my $t8 = lc substr $test_name, 0, 8;
 244           if ($seen_8dot3{$t8})
 245             {
 246               warn "$program_name: 8.3 test name conflict: "
 247                 . "$test_name, $seen_8dot3{$t8}\n";
 248               $bad_test_name = 1;
 249             }
 250           $seen_8dot3{$t8} = $test_name;
 251         }
 252
 253       # The test name may be no longer than 12 bytes,
 254       # so that we can add a two-byte suffix without exceeding
 255       # the maximum of 14 imposed on some old file systems.
 256       if (14 < (length $test_name) + 2)
 257         {
 258           warn "$program_name: $test_name: test name is too long (> 12)\n";
 259           $bad_test_name = 1;
 260         }
 261     }
 262   return 1 if $bad_test_name;
 263
 264   # FIXME check exit status
 265   system ($prog, '--version') if $verbose;
 266
 267   my @junk_files;
 268   my $fail = 0;
 269   foreach $t (@$t_spec)
 270     {
 271       my @post_compare;
 272       my $test_name = shift @$t;
 273       my $expect = {};
 274       my ($pre, $post);
 275
 276       # FIXME: maybe don't reset this.
 277       $Global_count = 1;
 278       my @args;
 279       my $io_spec;
 280       my %seen_type;
 281       my @env_delete;
 282       my $env_prefix = '';
 283       my $input_pipe_cmd;
 284       foreach $io_spec (@$t)
 285         {
 286           if (!ref $io_spec)
 287             {
 288               push @args, $io_spec;
 289               next;
 290             }
 291
 292           die "$program_name: $test_name: invalid test spec\n"
 293             if ref $io_spec ne 'HASH';
 294
 295           my $n = keys %$io_spec;
 296           die "$program_name: $test_name: spec has $n elements --"
 297             . " expected 1\n"
 298               if $n != 1;
 299           my ($type, $val) = each %$io_spec;
 300           die "$program_name: $test_name: invalid key `$type' in test spec\n"
 301             if ! $Types{$type};
 302
 303           # Make sure there's no more than one of OUT, ERR, EXIT, etc.
 304           die "$program_name: $test_name: more than one $type spec\n"
 305             if $Zero_one_type{$type} and $seen_type{$type}++;
 306
 307           if ($type eq 'PRE' or $type eq 'POST')
 308             {
 309               $expect->{$type} = $val;
 310               next;
 311             }
 312
 313           if ($type eq 'CMP')
 314             {
 315               my $t = ref $val;
 316               $t && $t eq 'ARRAY'
 317                 or die "$program_name: $test_name: invalid CMP spec\n";
 318               @$val == 2
 319                 or die "$program_name: $test_name: invalid CMP list;  must have"
 320                   . " exactly 2 elements\n";
 321               my @cmp_files;
 322               foreach my $e (@$val)
 323                 {
 324                   my $r = ref $e;
 325                   $r && $r ne 'HASH'
 326                     and die "$program_name: $test_name: invalid element ($r)"
 327                       . " in CMP list;  only scalars and hash references "
 328                         . "are allowed\n";
 329                   if ($r && $r eq 'HASH')
 330                     {
 331                       my $n = keys %$e;
 332                       $n == 1
 333                         or die "$program_name: $test_name: CMP spec has $n "
 334                           . "elements -- expected 1\n";
 335
 336                       # Replace any `@AUX@' in the key of %$e.
 337                       my ($ff, $val) = each %$e;
 338                       my $new_ff = _at_replace $expect, $ff;
 339                       if ($new_ff ne $ff)
 340                         {
 341                           $e->{$new_ff} = $val;
 342                           delete $e->{$ff};
 343                         }
 344                     }
 345                   my $cmp_file = _process_file_spec ($program_name, $test_name,
 346                                                      $e, $type, \@junk_files);
 347                   push @cmp_files, $cmp_file;
 348                 }
 349               push @post_compare, [@cmp_files];
 350
 351               $expect->{$type} = $val;
 352               next;
 353             }
 354
 355           if ($type eq 'EXIT')
 356             {
 357               die "$program_name: $test_name: invalid EXIT code\n"
 358                 if $val !~ /^\d+$/;
 359               # FIXME: make sure $data is numeric
 360               $expect->{EXIT} = $val;
 361               next;
 362             }
 363
 364           if ($type =~ /^(OUT|ERR)_SUBST$/)
 365             {
 366               $expect->{RESULT_SUBST} ||= {};
 367               $expect->{RESULT_SUBST}->{$1} = $val;
 368               next;
 369             }
 370
 371           if ($type eq 'ENV')
 372             {
 373               $env_prefix = "$val ";
 374               next;
 375             }
 376
 377           if ($type eq 'ENV_DEL')
 378             {
 379               push @env_delete, $val;
 380               next;
 381             }
 382
 383           my $file = _process_file_spec ($program_name, $test_name, $val,
 384                                          $type, \@junk_files);
 385
 386           if ($type eq 'IN' || $type eq 'IN_PIPE')
 387             {
 388               my $quoted_file = _shell_quote $file;
 389               if ($type eq 'IN_PIPE')
 390                 {
 391                   defined $input_pipe_cmd
 392                     and die "$program_name: $test_name: only one input"
 393                       . " may be specified with IN_PIPE\n";
 394                   $input_pipe_cmd = "cat $quoted_file |";
 395                 }
 396               else
 397                 {
 398                   push @args, $quoted_file;
 399                 }
 400             }
 401           elsif ($type eq 'AUX' || $type eq 'OUT' || $type eq 'ERR')
 402             {
 403               $expect->{$type} = $file;
 404             }
 405           else
 406             {
 407               die "$program_name: $test_name: invalid type: $type\n"
 408             }
 409         }
 410
 411       # Expect an exit status of zero if it's not specified.
 412       $expect->{EXIT} ||= 0;
 413
 414       # Allow ERR to be omitted -- in that case, expect no error output.
 415       foreach my $eo (qw (OUT ERR))
 416         {
 417           if (!exists $expect->{$eo})
 418             {
 419               $expect->{$eo} = _create_file ($program_name, $test_name,
 420                                              undef, '');
 421               push @junk_files, $expect->{$eo};
 422             }
 423         }
 424
 425       # FIXME: Does it ever make sense to specify a filename *and* contents
 426       # in OUT or ERR spec?
 427
 428       # FIXME: this is really suboptimal...
 429       my @new_args;
 430       foreach my $a (@args)
 431         {
 432           $a = _at_replace $expect, $a;
 433           push @new_args, $a;
 434         }
 435       @args = @new_args;
 436
 437       warn "$test_name...\n" if $verbose;
 438       &{$expect->{PRE}} if $expect->{PRE};
 439       my %actual;
 440       $actual{OUT} = "$test_name.O";
 441       $actual{ERR} = "$test_name.E";
 442       push @junk_files, $actual{OUT}, $actual{ERR};
 443       my @cmd = ($prog, @args, "> $actual{OUT}", "2> $actual{ERR}");
 444       defined $input_pipe_cmd
 445         and unshift @cmd, $input_pipe_cmd;
 446       my $cmd_str = $env_prefix . join (' ', @cmd);
 447
 448       # Delete from the environment any symbols specified by syntax
 449       # like this: {ENV_DEL => 'TZ'}.
 450       my %pushed_env;
 451       foreach my $env_sym (@env_delete)
 452         {
 453           my $val = delete $ENV{$env_sym};
 454           defined $val
 455             and $pushed_env{$env_sym} = $val;
 456         }
 457
 458       warn "Running command: `$cmd_str'\n" if $debug;
 459       my $rc = 0xffff & system $cmd_str;
 460
 461       # Restore any environment setting we changed via a deletion.
 462       foreach my $env_sym (keys %pushed_env)
 463         {
 464           $ENV{$env_sym} = $pushed_env{$env_sym};
 465         }
 466
 467       if ($rc == 0xff00)
 468         {
 469           warn "$program_name: test $test_name failed: command failed:\n"
 470             . "  `$cmd_str': $!\n";
 471           $fail = 1;
 472           goto cleanup;
 473         }
 474       $rc >>= 8 if $rc > 0x80;
 475       if ($expect->{EXIT} != $rc)
 476         {
 477           warn "$program_name: test $test_name failed: exit status mismatch:"
 478             . "  expected $expect->{EXIT}, got $rc\n";
 479           $fail = 1;
 480           goto cleanup;
 481         }
 482
 483       foreach my $eo (qw (OUT ERR))
 484         {
 485           my $subst_expr = $expect->{RESULT_SUBST}->{$eo};
 486           if (defined $subst_expr)
 487             {
 488               my $out = $actual{$eo};
 489               my $orig = "$out.orig";
 490
 491               # Move $out aside (to $orig), then recreate $out
 492               # by transforming each line of $orig via $subst_expr.
 493               rename $out, $orig
 494                 or (warn "$program_name: cannot rename $out to $orig: $!\n"),
 495                   $fail = 1, next;
 496               open IN, $orig
 497                 or (warn "$program_name: cannot open $orig for reading: $!\n"),
 498                   $fail = 1, (unlink $orig), next;
 499               unlink $orig
 500                 or (warn "$program_name: cannot unlink $orig: $!\n"),
 501                   $fail = 1;
 502               open OUT, ">$out"
 503                 or (warn "$program_name: cannot open $out for writing: $!\n"),
 504                   $fail = 1, next;
 505               while (defined (my $line = <IN>))
 506                 {
 507                   eval "\$_ = \$line; $subst_expr; \$line = \$_";
 508                   print OUT $line;
 509                 }
 510               close IN;
 511               close OUT
 512                 or (warn "$program_name: failed to write $out: $!\n"),
 513                   $fail = 1, next;
 514             }
 515
 516           my $eo_lower = lc $eo;
 517           _compare_files ($program_name, $test_name, $eo_lower,
 518                           $actual{$eo}, $expect->{$eo})
 519             and $fail = 1;
 520         }
 521
 522       foreach my $pair (@post_compare)
 523         {
 524           my ($expected, $actual) = @$pair;
 525           _compare_files $program_name, $test_name, undef, $actual, $expected
 526             and $fail = 1;
 527         }
 528
 529     cleanup:
 530       &{$expect->{POST}} if $expect->{POST};
 531
 532     }
 533
 534   # FIXME: maybe unlink files inside the big foreach loop?
 535   unlink @junk_files if ! $save_temps;
 536
 537   return $fail;
 538 }
 539
 540 ## package return
 541 1;