1package 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
19use strict;
20use vars qw($VERSION @ISA @EXPORT);
21
22use FileHandle;
23use 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
29my $debug = $ENV{DEBUG};
30
31my @Types = qw (IN IN_PIPE OUT ERR AUX CMP EXIT PRE POST OUT_SUBST
32                ERR_SUBST ENV ENV_DEL);
33my %Types = map {$_ => 1} @Types;
34my %Zero_one_type = map {$_ => 1}
35   qw (OUT ERR EXIT PRE POST OUT_SUBST ERR_SUBST ENV);
36my $srcdir = "$ENV{srcdir}";
37my $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.
42defined $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.
47defined $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
101sub _shell_quote ($)
102{
103  my ($string) = @_;
104  $string =~ s/\'/\'\\\'\'/g;
105  return "'$string'";
106}
107
108sub _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
134sub _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
151sub _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
199sub _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
212sub 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'.
225sub 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.
596sub 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
6291;
630