tests/Coreutils.pm

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