mirror of
https://github.com/coreutils/coreutils.git
synced 2024-11-28 20:44:42 +08:00
621 lines
19 KiB
Perl
621 lines
19 KiB
Perl
package Coreutils;
|
|
# This is a testing framework.
|
|
|
|
# Copyright (C) 1998, 2000-2002, 2004-2011 Free Software Foundation, Inc.
|
|
|
|
# This program is free software: you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation, either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
use strict;
|
|
use vars qw($VERSION @ISA @EXPORT);
|
|
|
|
use FileHandle;
|
|
use File::Compare qw(compare);
|
|
|
|
@ISA = qw(Exporter);
|
|
($VERSION = '$Revision: 1.5 $ ') =~ tr/[0-9].//cd;
|
|
@EXPORT = qw (run_tests triple_test getlimits);
|
|
|
|
my $debug = $ENV{DEBUG};
|
|
|
|
my @Types = qw (IN IN_PIPE OUT ERR AUX CMP EXIT PRE POST OUT_SUBST
|
|
ERR_SUBST ENV ENV_DEL);
|
|
my %Types = map {$_ => 1} @Types;
|
|
my %Zero_one_type = map {$_ => 1}
|
|
qw (OUT ERR EXIT PRE POST OUT_SUBST ERR_SUBST ENV);
|
|
my $srcdir = $ENV{srcdir};
|
|
my $Global_count = 1;
|
|
|
|
# When running in a DJGPP environment, make $ENV{SHELL} point to bash.
|
|
# Otherwise, a bad shell might be used (e.g. command.com) and many
|
|
# tests would fail.
|
|
defined $ENV{DJDIR}
|
|
and $ENV{SHELL} = "$ENV{DJDIR}/bin/bash.exe";
|
|
|
|
# A file spec: a scalar or a reference to a single-keyed hash
|
|
# ================
|
|
# 'contents' contents only (file name is derived from test name)
|
|
# {filename => 'contents'} filename and contents
|
|
# {filename => undef} filename only -- $(srcdir)/filename must exist
|
|
#
|
|
# FIXME: If there is more than one input file, then you can't specify `REDIR'.
|
|
# PIPE is still ok.
|
|
#
|
|
# I/O spec: a hash ref with the following properties
|
|
# ================
|
|
# - one key/value pair
|
|
# - the key must be one of these strings: IN, OUT, ERR, AUX, CMP, EXIT
|
|
# - the value must be a file spec
|
|
# {OUT => 'data'} put data in a temp file and compare it to stdout from cmd
|
|
# {OUT => {'filename'=>undef}} compare contents of existing filename to
|
|
# stdout from cmd
|
|
# {OUT => {'filename'=>[$CTOR, $DTOR]}} $CTOR and $DTOR are references to
|
|
# functions, each which is passed the single argument `filename'.
|
|
# $CTOR must create `filename'.
|
|
# DTOR may be omitted in which case `sub{unlink @_[0]}' is used.
|
|
# FIXME: implement this
|
|
# {ERR => ...}
|
|
# Same as for OUT, but compare with stderr, not stdout.
|
|
# {OUT_SUBST => 's/variable_output/expected_output/'}
|
|
# Transform actual standard output before comparing it against expected.
|
|
# This is useful e.g. for programs like du that produce output that
|
|
# varies a lot from system. E.g., an empty file may consume zero file
|
|
# blocks, or more, depending on the OS and on the file system type.
|
|
# {ERR_SUBST => 's/variable_output/expected_output/'}
|
|
# Transform actual stderr output before comparing it against expected.
|
|
# This is useful when verifying that we get a meaningful diagnostic.
|
|
# For example, in rm/fail-2eperm, we have to account for three different
|
|
# diagnostics: Operation not permitted, Not owner, and Permission denied.
|
|
# {EXIT => N} expect exit status of cmd to be N
|
|
# {ENV => 'VAR=val ...'}
|
|
# Prepend 'VAR=val ...' to the command that we execute via `system'.
|
|
# {ENV_DEL => 'VAR'}
|
|
# Remove VAR from the environment just before running the corresponding
|
|
# command, and restore any value just afterwards.
|
|
#
|
|
# There may be many input file specs. File names from the input specs
|
|
# are concatenated in order on the command line.
|
|
# There may be at most one of the OUT-, ERR-, and EXIT-keyed specs.
|
|
# If the OUT-(or ERR)-keyed hash ref is omitted, then expect no output
|
|
# on stdout (or stderr).
|
|
# If the EXIT-keyed one is omitted, then expect the exit status to be zero.
|
|
|
|
# FIXME: Make sure that no junkfile is also listed as a
|
|
# non-junkfile (i.e. with undef for contents)
|
|
|
|
sub _shell_quote ($)
|
|
{
|
|
my ($string) = @_;
|
|
$string =~ s/\'/\'\\\'\'/g;
|
|
return "'$string'";
|
|
}
|
|
|
|
sub _create_file ($$$$)
|
|
{
|
|
my ($program_name, $test_name, $file_name, $data) = @_;
|
|
my $file;
|
|
if (defined $file_name)
|
|
{
|
|
$file = $file_name;
|
|
}
|
|
else
|
|
{
|
|
$file = "$test_name.$Global_count";
|
|
++$Global_count;
|
|
}
|
|
|
|
warn "creating file `$file' with contents `$data'\n" if $debug;
|
|
|
|
# The test spec gave a string.
|
|
# Write it to a temp file and return tempfile name.
|
|
my $fh = new FileHandle "> $file";
|
|
die "$program_name: $file: $!\n" if ! $fh;
|
|
print $fh $data;
|
|
$fh->close || die "$program_name: $file: $!\n";
|
|
|
|
return $file;
|
|
}
|
|
|
|
sub _compare_files ($$$$$)
|
|
{
|
|
my ($program_name, $test_name, $in_or_out, $actual, $expected) = @_;
|
|
|
|
my $differ = compare ($expected, $actual);
|
|
if ($differ)
|
|
{
|
|
my $info = (defined $in_or_out ? "std$in_or_out " : '');
|
|
warn "$program_name: test $test_name: ${info}mismatch, comparing "
|
|
. "$actual (actual) and $expected (expected)\n";
|
|
# Ignore any failure, discard stderr.
|
|
system "diff -c $actual $expected 2>/dev/null";
|
|
}
|
|
|
|
return $differ;
|
|
}
|
|
|
|
sub _process_file_spec ($$$$$)
|
|
{
|
|
my ($program_name, $test_name, $file_spec, $type, $junk_files) = @_;
|
|
|
|
my ($file_name, $contents);
|
|
if (!ref $file_spec)
|
|
{
|
|
($file_name, $contents) = (undef, $file_spec);
|
|
}
|
|
elsif (ref $file_spec eq 'HASH')
|
|
{
|
|
my $n = keys %$file_spec;
|
|
die "$program_name: $test_name: $type spec has $n elements --"
|
|
. " expected 1\n"
|
|
if $n != 1;
|
|
($file_name, $contents) = each %$file_spec;
|
|
|
|
# This happens for the AUX hash in an io_spec like this:
|
|
# {CMP=> ['zy123utsrqponmlkji', {'@AUX@'=> undef}]},
|
|
defined $contents
|
|
or return $file_name;
|
|
}
|
|
else
|
|
{
|
|
die "$program_name: $test_name: invalid RHS in $type-spec\n"
|
|
}
|
|
|
|
my $is_junk_file = (! defined $file_name
|
|
|| (($type eq 'IN' || $type eq 'AUX' || $type eq 'CMP')
|
|
&& defined $contents));
|
|
my $file = _create_file ($program_name, $test_name,
|
|
$file_name, $contents);
|
|
|
|
if ($is_junk_file)
|
|
{
|
|
push @$junk_files, $file
|
|
}
|
|
else
|
|
{
|
|
# FIXME: put $srcdir in here somewhere
|
|
warn "$program_name: $test_name: specified file `$file' does"
|
|
. " not exist\n"
|
|
if ! -f "$srcdir/$file";
|
|
}
|
|
|
|
return $file;
|
|
}
|
|
|
|
sub _at_replace ($$)
|
|
{
|
|
my ($map, $s) = @_;
|
|
foreach my $eo (qw (AUX OUT ERR))
|
|
{
|
|
my $f = $map->{$eo};
|
|
$f
|
|
and $s =~ /\@$eo\@/
|
|
and $s =~ s/\@$eo\@/$f/g;
|
|
}
|
|
return $s;
|
|
}
|
|
|
|
sub getlimits()
|
|
{
|
|
my $NV;
|
|
open $NV, "getlimits |" or die "Error running getlimits\n";
|
|
my %limits = map {split /=|\n/} <$NV>;
|
|
return \%limits;
|
|
}
|
|
|
|
# FIXME: cleanup on interrupt
|
|
# FIXME: extract `do_1_test' function
|
|
|
|
# FIXME: having to include $program_name here is an expedient kludge.
|
|
# Library code doesn't `die'.
|
|
sub run_tests ($$$$$)
|
|
{
|
|
my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_;
|
|
|
|
# To indicate that $prog is a shell built-in, you'd make it a string 'ref'.
|
|
# E.g., call run_tests ($prog, \$prog, \@Tests, $save_temps, $verbose);
|
|
# If it's a ref, invoke it via "env":
|
|
my @prog = ref $prog ? (qw(env --), $$prog) : $prog;
|
|
|
|
# Warn about empty t_spec.
|
|
# FIXME
|
|
|
|
# Remove all temp files upon interrupt.
|
|
# FIXME
|
|
|
|
# Verify that test names are distinct.
|
|
my $bad_test_name = 0;
|
|
my %seen;
|
|
my %seen_8dot3;
|
|
my $t;
|
|
foreach $t (@$t_spec)
|
|
{
|
|
my $test_name = $t->[0];
|
|
if ($seen{$test_name})
|
|
{
|
|
warn "$program_name: $test_name: duplicate test name\n";
|
|
$bad_test_name = 1;
|
|
}
|
|
$seen{$test_name} = 1;
|
|
|
|
if (0)
|
|
{
|
|
my $t8 = lc substr $test_name, 0, 8;
|
|
if ($seen_8dot3{$t8})
|
|
{
|
|
warn "$program_name: 8.3 test name conflict: "
|
|
. "$test_name, $seen_8dot3{$t8}\n";
|
|
$bad_test_name = 1;
|
|
}
|
|
$seen_8dot3{$t8} = $test_name;
|
|
}
|
|
|
|
# The test name may be no longer than 30 bytes.
|
|
# Yes, this is an arbitrary limit. If it causes trouble,
|
|
# consider removing it.
|
|
my $max = 30;
|
|
if ($max < length $test_name)
|
|
{
|
|
warn "$program_name: $test_name: test name is too long (> $max)\n";
|
|
$bad_test_name = 1;
|
|
}
|
|
}
|
|
return 1 if $bad_test_name;
|
|
|
|
# FIXME check exit status
|
|
system (@prog, '--version') if $verbose;
|
|
|
|
my @junk_files;
|
|
my $fail = 0;
|
|
foreach my $tt (@$t_spec)
|
|
{
|
|
my @post_compare;
|
|
my @dummy = @$tt;
|
|
my $t = \@dummy;
|
|
my $test_name = shift @$t;
|
|
my $expect = {};
|
|
my ($pre, $post);
|
|
|
|
# FIXME: maybe don't reset this.
|
|
$Global_count = 1;
|
|
my @args;
|
|
my $io_spec;
|
|
my %seen_type;
|
|
my @env_delete;
|
|
my $env_prefix = '';
|
|
my $input_pipe_cmd;
|
|
foreach $io_spec (@$t)
|
|
{
|
|
if (!ref $io_spec)
|
|
{
|
|
push @args, $io_spec;
|
|
next;
|
|
}
|
|
|
|
if (ref $io_spec ne 'HASH')
|
|
{
|
|
eval 'use Data::Dumper';
|
|
die "$program_name: $test_name: invalid entry in test spec; "
|
|
. "expected HASH-ref,\nbut got this:\n"
|
|
. Data::Dumper->Dump ([\$io_spec], ['$io_spec']) . "\n";
|
|
}
|
|
|
|
my $n = keys %$io_spec;
|
|
die "$program_name: $test_name: spec has $n elements --"
|
|
. " expected 1\n"
|
|
if $n != 1;
|
|
my ($type, $val) = each %$io_spec;
|
|
die "$program_name: $test_name: invalid key `$type' in test spec\n"
|
|
if ! $Types{$type};
|
|
|
|
# Make sure there's no more than one of OUT, ERR, EXIT, etc.
|
|
die "$program_name: $test_name: more than one $type spec\n"
|
|
if $Zero_one_type{$type} and $seen_type{$type}++;
|
|
|
|
if ($type eq 'PRE' or $type eq 'POST')
|
|
{
|
|
$expect->{$type} = $val;
|
|
next;
|
|
}
|
|
|
|
if ($type eq 'CMP')
|
|
{
|
|
my $t = ref $val;
|
|
$t && $t eq 'ARRAY'
|
|
or die "$program_name: $test_name: invalid CMP spec\n";
|
|
@$val == 2
|
|
or die "$program_name: $test_name: invalid CMP list; must have"
|
|
. " exactly 2 elements\n";
|
|
my @cmp_files;
|
|
foreach my $e (@$val)
|
|
{
|
|
my $r = ref $e;
|
|
$r && $r ne 'HASH'
|
|
and die "$program_name: $test_name: invalid element ($r)"
|
|
. " in CMP list; only scalars and hash references "
|
|
. "are allowed\n";
|
|
if ($r && $r eq 'HASH')
|
|
{
|
|
my $n = keys %$e;
|
|
$n == 1
|
|
or die "$program_name: $test_name: CMP spec has $n "
|
|
. "elements -- expected 1\n";
|
|
|
|
# Replace any `@AUX@' in the key of %$e.
|
|
my ($ff, $val) = each %$e;
|
|
my $new_ff = _at_replace $expect, $ff;
|
|
if ($new_ff ne $ff)
|
|
{
|
|
$e->{$new_ff} = $val;
|
|
delete $e->{$ff};
|
|
}
|
|
}
|
|
my $cmp_file = _process_file_spec ($program_name, $test_name,
|
|
$e, $type, \@junk_files);
|
|
push @cmp_files, $cmp_file;
|
|
}
|
|
push @post_compare, [@cmp_files];
|
|
|
|
$expect->{$type} = $val;
|
|
next;
|
|
}
|
|
|
|
if ($type eq 'EXIT')
|
|
{
|
|
die "$program_name: $test_name: invalid EXIT code\n"
|
|
if $val !~ /^\d+$/;
|
|
# FIXME: make sure $data is numeric
|
|
$expect->{EXIT} = $val;
|
|
next;
|
|
}
|
|
|
|
if ($type =~ /^(OUT|ERR)_SUBST$/)
|
|
{
|
|
$expect->{RESULT_SUBST} ||= {};
|
|
$expect->{RESULT_SUBST}->{$1} = $val;
|
|
next;
|
|
}
|
|
|
|
if ($type eq 'ENV')
|
|
{
|
|
$env_prefix = "$val ";
|
|
next;
|
|
}
|
|
|
|
if ($type eq 'ENV_DEL')
|
|
{
|
|
push @env_delete, $val;
|
|
next;
|
|
}
|
|
|
|
my $file = _process_file_spec ($program_name, $test_name, $val,
|
|
$type, \@junk_files);
|
|
|
|
if ($type eq 'IN' || $type eq 'IN_PIPE')
|
|
{
|
|
my $quoted_file = _shell_quote $file;
|
|
if ($type eq 'IN_PIPE')
|
|
{
|
|
defined $input_pipe_cmd
|
|
and die "$program_name: $test_name: only one input"
|
|
. " may be specified with IN_PIPE\n";
|
|
$input_pipe_cmd = "cat $quoted_file |";
|
|
}
|
|
else
|
|
{
|
|
push @args, $quoted_file;
|
|
}
|
|
}
|
|
elsif ($type eq 'AUX' || $type eq 'OUT' || $type eq 'ERR')
|
|
{
|
|
$expect->{$type} = $file;
|
|
}
|
|
else
|
|
{
|
|
die "$program_name: $test_name: invalid type: $type\n"
|
|
}
|
|
}
|
|
|
|
# Expect an exit status of zero if it's not specified.
|
|
$expect->{EXIT} ||= 0;
|
|
|
|
# Allow ERR to be omitted -- in that case, expect no error output.
|
|
foreach my $eo (qw (OUT ERR))
|
|
{
|
|
if (!exists $expect->{$eo})
|
|
{
|
|
$expect->{$eo} = _create_file ($program_name, $test_name,
|
|
undef, '');
|
|
push @junk_files, $expect->{$eo};
|
|
}
|
|
}
|
|
|
|
# FIXME: Does it ever make sense to specify a filename *and* contents
|
|
# in OUT or ERR spec?
|
|
|
|
# FIXME: this is really suboptimal...
|
|
my @new_args;
|
|
foreach my $a (@args)
|
|
{
|
|
$a = _at_replace $expect, $a;
|
|
push @new_args, $a;
|
|
}
|
|
@args = @new_args;
|
|
|
|
warn "$test_name...\n" if $verbose;
|
|
&{$expect->{PRE}} if $expect->{PRE};
|
|
my %actual;
|
|
$actual{OUT} = "$test_name.O";
|
|
$actual{ERR} = "$test_name.E";
|
|
push @junk_files, $actual{OUT}, $actual{ERR};
|
|
my @cmd = (@prog, @args, "> $actual{OUT}", "2> $actual{ERR}");
|
|
$env_prefix
|
|
and unshift @cmd, $env_prefix;
|
|
defined $input_pipe_cmd
|
|
and unshift @cmd, $input_pipe_cmd;
|
|
my $cmd_str = join (' ', @cmd);
|
|
|
|
# Delete from the environment any symbols specified by syntax
|
|
# like this: {ENV_DEL => 'TZ'}.
|
|
my %pushed_env;
|
|
foreach my $env_sym (@env_delete)
|
|
{
|
|
my $val = delete $ENV{$env_sym};
|
|
defined $val
|
|
and $pushed_env{$env_sym} = $val;
|
|
}
|
|
|
|
warn "Running command: `$cmd_str'\n" if $debug;
|
|
my $rc = 0xffff & system $cmd_str;
|
|
|
|
# Restore any environment setting we changed via a deletion.
|
|
foreach my $env_sym (keys %pushed_env)
|
|
{
|
|
$ENV{$env_sym} = $pushed_env{$env_sym};
|
|
}
|
|
|
|
if ($rc == 0xff00)
|
|
{
|
|
warn "$program_name: test $test_name failed: command failed:\n"
|
|
. " `$cmd_str': $!\n";
|
|
$fail = 1;
|
|
goto cleanup;
|
|
}
|
|
$rc >>= 8 if $rc > 0x80;
|
|
if ($expect->{EXIT} != $rc)
|
|
{
|
|
warn "$program_name: test $test_name failed: exit status mismatch:"
|
|
. " expected $expect->{EXIT}, got $rc\n";
|
|
$fail = 1;
|
|
goto cleanup;
|
|
}
|
|
|
|
my %actual_data;
|
|
# Record actual stdout and stderr contents, if POST may need them.
|
|
if ($expect->{POST})
|
|
{
|
|
foreach my $eo (qw (OUT ERR))
|
|
{
|
|
my $out_file = $actual{$eo};
|
|
open IN, $out_file
|
|
or (warn
|
|
"$program_name: cannot open $out_file for reading: $!\n"),
|
|
$fail = 1, next;
|
|
$actual_data{$eo} = <IN>;
|
|
close IN
|
|
or (warn "$program_name: failed to read $out_file: $!\n"),
|
|
$fail = 1;
|
|
}
|
|
}
|
|
|
|
foreach my $eo (qw (OUT ERR))
|
|
{
|
|
my $subst_expr = $expect->{RESULT_SUBST}->{$eo};
|
|
if (defined $subst_expr)
|
|
{
|
|
my $out = $actual{$eo};
|
|
my $orig = "$out.orig";
|
|
|
|
# Move $out aside (to $orig), then recreate $out
|
|
# by transforming each line of $orig via $subst_expr.
|
|
rename $out, $orig
|
|
or (warn "$program_name: cannot rename $out to $orig: $!\n"),
|
|
$fail = 1, next;
|
|
open IN, $orig
|
|
or (warn "$program_name: cannot open $orig for reading: $!\n"),
|
|
$fail = 1, (unlink $orig), next;
|
|
unlink $orig
|
|
or (warn "$program_name: cannot unlink $orig: $!\n"),
|
|
$fail = 1;
|
|
open OUT, ">$out"
|
|
or (warn "$program_name: cannot open $out for writing: $!\n"),
|
|
$fail = 1, next;
|
|
while (defined (my $line = <IN>))
|
|
{
|
|
eval "\$_ = \$line; $subst_expr; \$line = \$_";
|
|
print OUT $line;
|
|
}
|
|
close IN;
|
|
close OUT
|
|
or (warn "$program_name: failed to write $out: $!\n"),
|
|
$fail = 1, next;
|
|
}
|
|
|
|
my $eo_lower = lc $eo;
|
|
_compare_files ($program_name, $test_name, $eo_lower,
|
|
$actual{$eo}, $expect->{$eo})
|
|
and $fail = 1;
|
|
}
|
|
|
|
foreach my $pair (@post_compare)
|
|
{
|
|
my ($expected, $actual) = @$pair;
|
|
_compare_files $program_name, $test_name, undef, $actual, $expected
|
|
and $fail = 1;
|
|
}
|
|
|
|
cleanup:
|
|
$expect->{POST}
|
|
and &{$expect->{POST}} ($actual_data{OUT}, $actual_data{ERR});
|
|
|
|
}
|
|
|
|
# FIXME: maybe unlink files inside the big foreach loop?
|
|
unlink @junk_files if ! $save_temps;
|
|
|
|
return $fail;
|
|
}
|
|
|
|
# For each test in @$TESTS, generate two additional tests,
|
|
# one using stdin, the other using a pipe. I.e., given this one
|
|
# ['idem-0', {IN=>''}, {OUT=>''}],
|
|
# generate these:
|
|
# ['idem-0.r', '<', {IN=>''}, {OUT=>''}],
|
|
# ['idem-0.p', {IN_PIPE=>''}, {OUT=>''}],
|
|
# Generate new tests only if there is exactly one input spec.
|
|
# The returned list of tests contains each input test, followed
|
|
# by zero or two derived tests.
|
|
sub triple_test($)
|
|
{
|
|
my ($tests) = @_;
|
|
my @new;
|
|
foreach my $t (@$tests)
|
|
{
|
|
push @new, $t;
|
|
|
|
my @in;
|
|
my @args;
|
|
my @list_of_hash;
|
|
foreach my $e (@$t)
|
|
{
|
|
!ref $e
|
|
and push (@args, $e), next;
|
|
|
|
ref $e && ref $e eq 'HASH'
|
|
or (warn "$0: $t->[0]: unexpected entry type\n"), next;
|
|
defined $e->{IN}
|
|
and (push @in, $e->{IN}), next;
|
|
push @list_of_hash, $e;
|
|
}
|
|
# Add variants IFF there is exactly one input file.
|
|
@in == 1
|
|
or next;
|
|
shift @args; # discard test name
|
|
push @new, ["$t->[0].r", @args, '<', {IN => $in[0]}, @list_of_hash];
|
|
push @new, ["$t->[0].p", @args, {IN_PIPE => $in[0]}, @list_of_hash];
|
|
}
|
|
return @new;
|
|
}
|
|
|
|
## package return
|
|
1;
|