tests/Coreutils.pm

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