| 1 | package Coreutils;
|
|---|
| 2 | # This is a testing framework.
|
|---|
| 3 |
|
|---|
| 4 | # Copyright (C) 1998-2015, 2017-2021 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 | # 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)/tests/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.
|
|---|
| 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 ($actual, $expected);
|
|---|
| 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 | . "$expected (expected) and $actual (actual)\n";
|
|---|
| 139 | # Ignore any failure, discard stderr.
|
|---|
| 140 | system "diff -c $expected $actual 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/tests/$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 | sub getlimits()
|
|---|
| 208 | {
|
|---|
| 209 | my $NV;
|
|---|
| 210 | open $NV, "getlimits |" or die "Error running getlimits\n";
|
|---|
| 211 | my %limits = map {split /=|\n/} <$NV>;
|
|---|
| 212 | return \%limits;
|
|---|
| 213 | }
|
|---|
| 214 |
|
|---|
| 215 | # FIXME: cleanup on interrupt
|
|---|
| 216 | # FIXME: extract 'do_1_test' function
|
|---|
| 217 |
|
|---|
| 218 | # FIXME: having to include $program_name here is an expedient kludge.
|
|---|
| 219 | # Library code doesn't 'die'.
|
|---|
| 220 | sub run_tests ($$$$$)
|
|---|
| 221 | {
|
|---|
| 222 | my ($program_name, $prog, $t_spec, $save_temps, $verbose) = @_;
|
|---|
| 223 |
|
|---|
| 224 | # To indicate that $prog is a shell built-in, you'd make it a string 'ref'.
|
|---|
| 225 | # E.g., call run_tests ($prog, \$prog, \@Tests, $save_temps, $verbose);
|
|---|
| 226 | # If it's a ref, invoke it via "env":
|
|---|
| 227 | my @prog = ref $prog ? (qw(env --), $$prog) : $prog;
|
|---|
| 228 |
|
|---|
| 229 | # Warn about empty t_spec.
|
|---|
| 230 | # FIXME
|
|---|
| 231 |
|
|---|
| 232 | # Remove all temp files upon interrupt.
|
|---|
| 233 | # FIXME
|
|---|
| 234 |
|
|---|
| 235 | # Verify that test names are distinct.
|
|---|
| 236 | my $bad_test_name = 0;
|
|---|
| 237 | my %seen;
|
|---|
| 238 | my %seen_8dot3;
|
|---|
| 239 | my $t;
|
|---|
| 240 | foreach $t (@$t_spec)
|
|---|
| 241 | {
|
|---|
| 242 | my $test_name = $t->[0];
|
|---|
| 243 | if ($seen{$test_name})
|
|---|
| 244 | {
|
|---|
| 245 | warn "$program_name: $test_name: duplicate test name\n";
|
|---|
| 246 | $bad_test_name = 1;
|
|---|
| 247 | }
|
|---|
| 248 | $seen{$test_name} = 1;
|
|---|
| 249 |
|
|---|
| 250 | if (0)
|
|---|
| 251 | {
|
|---|
| 252 | my $t8 = lc substr $test_name, 0, 8;
|
|---|
| 253 | if ($seen_8dot3{$t8})
|
|---|
| 254 | {
|
|---|
| 255 | warn "$program_name: 8.3 test name conflict: "
|
|---|
| 256 | . "$test_name, $seen_8dot3{$t8}\n";
|
|---|
| 257 | $bad_test_name = 1;
|
|---|
| 258 | }
|
|---|
| 259 | $seen_8dot3{$t8} = $test_name;
|
|---|
| 260 | }
|
|---|
| 261 |
|
|---|
| 262 | # The test name may be no longer than 30 bytes.
|
|---|
| 263 | # Yes, this is an arbitrary limit. If it causes trouble,
|
|---|
| 264 | # consider removing it.
|
|---|
| 265 | my $max = 30;
|
|---|
| 266 | if ($max < length $test_name)
|
|---|
| 267 | {
|
|---|
| 268 | warn "$program_name: $test_name: test name is too long (> $max)\n";
|
|---|
| 269 | $bad_test_name = 1;
|
|---|
| 270 | }
|
|---|
| 271 | }
|
|---|
| 272 | return 1 if $bad_test_name;
|
|---|
| 273 |
|
|---|
| 274 | # FIXME check exit status
|
|---|
| 275 | system (@prog, '--version') if $verbose;
|
|---|
| 276 |
|
|---|
| 277 | my @junk_files;
|
|---|
| 278 | my $fail = 0;
|
|---|
| 279 | foreach my $tt (@$t_spec)
|
|---|
| 280 | {
|
|---|
| 281 | my @post_compare;
|
|---|
| 282 | my @dummy = @$tt;
|
|---|
| 283 | my $t = \@dummy;
|
|---|
| 284 | my $test_name = shift @$t;
|
|---|
| 285 | my $expect = {};
|
|---|
| 286 | my ($pre, $post);
|
|---|
| 287 |
|
|---|
| 288 | # FIXME: maybe don't reset this.
|
|---|
| 289 | $Global_count = 1;
|
|---|
| 290 | my @args;
|
|---|
| 291 | my $io_spec;
|
|---|
| 292 | my %seen_type;
|
|---|
| 293 | my @env_delete;
|
|---|
| 294 | my $env_prefix = '';
|
|---|
| 295 | my $input_pipe_cmd;
|
|---|
| 296 | foreach $io_spec (@$t)
|
|---|
| 297 | {
|
|---|
| 298 | if (!ref $io_spec)
|
|---|
| 299 | {
|
|---|
| 300 | push @args, $io_spec;
|
|---|
| 301 | next;
|
|---|
| 302 | }
|
|---|
| 303 |
|
|---|
| 304 | if (ref $io_spec ne 'HASH')
|
|---|
| 305 | {
|
|---|
| 306 | eval 'use Data::Dumper';
|
|---|
| 307 | die "$program_name: $test_name: invalid entry in test spec; "
|
|---|
| 308 | . "expected HASH-ref,\nbut got this:\n"
|
|---|
| 309 | . Data::Dumper->Dump ([\$io_spec], ['$io_spec']) . "\n";
|
|---|
| 310 | }
|
|---|
| 311 |
|
|---|
| 312 | my $n = keys %$io_spec;
|
|---|
| 313 | die "$program_name: $test_name: spec has $n elements --"
|
|---|
| 314 | . " expected 1\n"
|
|---|
| 315 | if $n != 1;
|
|---|
| 316 | my ($type, $val) = each %$io_spec;
|
|---|
| 317 | die "$program_name: $test_name: invalid key '$type' in test spec\n"
|
|---|
| 318 | if ! $Types{$type};
|
|---|
| 319 |
|
|---|
| 320 | # Make sure there's no more than one of OUT, ERR, EXIT, etc.
|
|---|
| 321 | die "$program_name: $test_name: more than one $type spec\n"
|
|---|
| 322 | if $Zero_one_type{$type} and $seen_type{$type}++;
|
|---|
| 323 |
|
|---|
| 324 | if ($type eq 'PRE' or $type eq 'POST')
|
|---|
| 325 | {
|
|---|
| 326 | $expect->{$type} = $val;
|
|---|
| 327 | next;
|
|---|
| 328 | }
|
|---|
| 329 |
|
|---|
| 330 | if ($type eq 'CMP')
|
|---|
| 331 | {
|
|---|
| 332 | my $t = ref $val;
|
|---|
| 333 | $t && $t eq 'ARRAY'
|
|---|
| 334 | or die "$program_name: $test_name: invalid CMP spec\n";
|
|---|
| 335 | @$val == 2
|
|---|
| 336 | or die "$program_name: $test_name: invalid CMP list; must have"
|
|---|
| 337 | . " exactly 2 elements\n";
|
|---|
| 338 | my @cmp_files;
|
|---|
| 339 | foreach my $e (@$val)
|
|---|
| 340 | {
|
|---|
| 341 | my $r = ref $e;
|
|---|
| 342 | $r && $r ne 'HASH'
|
|---|
| 343 | and die "$program_name: $test_name: invalid element ($r)"
|
|---|
| 344 | . " in CMP list; only scalars and hash references "
|
|---|
| 345 | . "are allowed\n";
|
|---|
| 346 | if ($r && $r eq 'HASH')
|
|---|
| 347 | {
|
|---|
| 348 | my $n = keys %$e;
|
|---|
| 349 | $n == 1
|
|---|
| 350 | or die "$program_name: $test_name: CMP spec has $n "
|
|---|
| 351 | . "elements -- expected 1\n";
|
|---|
| 352 |
|
|---|
| 353 | # Replace any '@AUX@' in the key of %$e.
|
|---|
| 354 | my ($ff, $val) = each %$e;
|
|---|
| 355 | my $new_ff = _at_replace $expect, $ff;
|
|---|
| 356 | if ($new_ff ne $ff)
|
|---|
| 357 | {
|
|---|
| 358 | $e->{$new_ff} = $val;
|
|---|
| 359 | delete $e->{$ff};
|
|---|
| 360 | }
|
|---|
| 361 | }
|
|---|
| 362 | my $cmp_file = _process_file_spec ($program_name, $test_name,
|
|---|
| 363 | $e, $type, \@junk_files);
|
|---|
| 364 | push @cmp_files, $cmp_file;
|
|---|
| 365 | }
|
|---|
| 366 | push @post_compare, [@cmp_files];
|
|---|
| 367 |
|
|---|
| 368 | $expect->{$type} = $val;
|
|---|
| 369 | next;
|
|---|
| 370 | }
|
|---|
| 371 |
|
|---|
| 372 | if ($type eq 'EXIT')
|
|---|
| 373 | {
|
|---|
| 374 | die "$program_name: $test_name: invalid EXIT code\n"
|
|---|
| 375 | if $val !~ /^\d+$/;
|
|---|
| 376 | # FIXME: make sure $data is numeric
|
|---|
| 377 | $expect->{EXIT} = $val;
|
|---|
| 378 | next;
|
|---|
| 379 | }
|
|---|
| 380 |
|
|---|
| 381 | if ($type =~ /^(OUT|ERR)_SUBST$/)
|
|---|
| 382 | {
|
|---|
| 383 | $expect->{RESULT_SUBST} ||= {};
|
|---|
| 384 | $expect->{RESULT_SUBST}->{$1} = $val;
|
|---|
| 385 | next;
|
|---|
| 386 | }
|
|---|
| 387 |
|
|---|
| 388 | if ($type eq 'ENV')
|
|---|
| 389 | {
|
|---|
| 390 | $env_prefix = "$val ";
|
|---|
| 391 | next;
|
|---|
| 392 | }
|
|---|
| 393 |
|
|---|
| 394 | if ($type eq 'ENV_DEL')
|
|---|
| 395 | {
|
|---|
| 396 | push @env_delete, $val;
|
|---|
| 397 | next;
|
|---|
| 398 | }
|
|---|
| 399 |
|
|---|
| 400 | my $file = _process_file_spec ($program_name, $test_name, $val,
|
|---|
| 401 | $type, \@junk_files);
|
|---|
| 402 |
|
|---|
| 403 | if ($type eq 'IN' || $type eq 'IN_PIPE')
|
|---|
| 404 | {
|
|---|
| 405 | my $quoted_file = _shell_quote $file;
|
|---|
| 406 | if ($type eq 'IN_PIPE')
|
|---|
| 407 | {
|
|---|
| 408 | defined $input_pipe_cmd
|
|---|
| 409 | and die "$program_name: $test_name: only one input"
|
|---|
| 410 | . " may be specified with IN_PIPE\n";
|
|---|
| 411 | $input_pipe_cmd = "cat $quoted_file |";
|
|---|
| 412 | }
|
|---|
| 413 | else
|
|---|
| 414 | {
|
|---|
| 415 | push @args, $quoted_file;
|
|---|
| 416 | }
|
|---|
| 417 | }
|
|---|
| 418 | elsif ($type eq 'AUX' || $type eq 'OUT' || $type eq 'ERR')
|
|---|
| 419 | {
|
|---|
| 420 | $expect->{$type} = $file;
|
|---|
| 421 | }
|
|---|
| 422 | else
|
|---|
| 423 | {
|
|---|
| 424 | die "$program_name: $test_name: invalid type: $type\n"
|
|---|
| 425 | }
|
|---|
| 426 | }
|
|---|
| 427 |
|
|---|
| 428 | # Expect an exit status of zero if it's not specified.
|
|---|
| 429 | $expect->{EXIT} ||= 0;
|
|---|
| 430 |
|
|---|
| 431 | # Allow ERR to be omitted -- in that case, expect no error output.
|
|---|
| 432 | foreach my $eo (qw (OUT ERR))
|
|---|
| 433 | {
|
|---|
| 434 | if (!exists $expect->{$eo})
|
|---|
| 435 | {
|
|---|
| 436 | $expect->{$eo} = _create_file ($program_name, $test_name,
|
|---|
| 437 | undef, '');
|
|---|
| 438 | push @junk_files, $expect->{$eo};
|
|---|
| 439 | }
|
|---|
| 440 | }
|
|---|
| 441 |
|
|---|
| 442 | # FIXME: Does it ever make sense to specify a filename *and* contents
|
|---|
| 443 | # in OUT or ERR spec?
|
|---|
| 444 |
|
|---|
| 445 | # FIXME: this is really suboptimal...
|
|---|
| 446 | my @new_args;
|
|---|
| 447 | foreach my $a (@args)
|
|---|
| 448 | {
|
|---|
| 449 | $a = _at_replace $expect, $a;
|
|---|
| 450 | push @new_args, $a;
|
|---|
| 451 | }
|
|---|
| 452 | @args = @new_args;
|
|---|
| 453 |
|
|---|
| 454 | warn "$test_name...\n" if $verbose;
|
|---|
| 455 | &{$expect->{PRE}} if $expect->{PRE};
|
|---|
| 456 | my %actual;
|
|---|
| 457 | $actual{OUT} = "$test_name.O";
|
|---|
| 458 | $actual{ERR} = "$test_name.E";
|
|---|
| 459 | push @junk_files, $actual{OUT}, $actual{ERR};
|
|---|
| 460 | my @cmd = (@prog, @args, "> $actual{OUT}", "2> $actual{ERR}");
|
|---|
| 461 | $env_prefix
|
|---|
| 462 | and unshift @cmd, $env_prefix;
|
|---|
| 463 | defined $input_pipe_cmd
|
|---|
| 464 | and unshift @cmd, $input_pipe_cmd;
|
|---|
| 465 | my $cmd_str = join (' ', @cmd);
|
|---|
| 466 |
|
|---|
| 467 | # Delete from the environment any symbols specified by syntax
|
|---|
| 468 | # like this: {ENV_DEL => 'TZ'}.
|
|---|
| 469 | my %pushed_env;
|
|---|
| 470 | foreach my $env_sym (@env_delete)
|
|---|
| 471 | {
|
|---|
| 472 | my $val = delete $ENV{$env_sym};
|
|---|
| 473 | defined $val
|
|---|
| 474 | and $pushed_env{$env_sym} = $val;
|
|---|
| 475 | }
|
|---|
| 476 |
|
|---|
| 477 | warn "Running command: '$cmd_str'\n" if $debug;
|
|---|
| 478 | my $rc = 0xffff & system $cmd_str;
|
|---|
| 479 |
|
|---|
| 480 | # Restore any environment setting we changed via a deletion.
|
|---|
| 481 | foreach my $env_sym (keys %pushed_env)
|
|---|
| 482 | {
|
|---|
| 483 | $ENV{$env_sym} = $pushed_env{$env_sym};
|
|---|
| 484 | }
|
|---|
| 485 |
|
|---|
| 486 | if ($rc == 0xff00)
|
|---|
| 487 | {
|
|---|
| 488 | warn "$program_name: test $test_name failed: command failed:\n"
|
|---|
| 489 | . " '$cmd_str': $!\n";
|
|---|
| 490 | $fail = 1;
|
|---|
| 491 | goto cleanup;
|
|---|
| 492 | }
|
|---|
| 493 | $rc >>= 8 if $rc > 0x80;
|
|---|
| 494 | if ($expect->{EXIT} != $rc)
|
|---|
| 495 | {
|
|---|
| 496 | warn "$program_name: test $test_name failed: exit status mismatch:"
|
|---|
| 497 | . " expected $expect->{EXIT}, got $rc\n";
|
|---|
| 498 | $fail = 1;
|
|---|
| 499 | goto cleanup;
|
|---|
| 500 | }
|
|---|
| 501 |
|
|---|
| 502 | my %actual_data;
|
|---|
| 503 | # Record actual stdout and stderr contents, if POST may need them.
|
|---|
| 504 | if ($expect->{POST})
|
|---|
| 505 | {
|
|---|
| 506 | foreach my $eo (qw (OUT ERR))
|
|---|
| 507 | {
|
|---|
| 508 | my $out_file = $actual{$eo};
|
|---|
| 509 | open IN, $out_file
|
|---|
| 510 | or (warn
|
|---|
| 511 | "$program_name: cannot open $out_file for reading: $!\n"),
|
|---|
| 512 | $fail = 1, next;
|
|---|
| 513 | $actual_data{$eo} = <IN>;
|
|---|
| 514 | close IN
|
|---|
| 515 | or (warn "$program_name: failed to read $out_file: $!\n"),
|
|---|
| 516 | $fail = 1;
|
|---|
| 517 | }
|
|---|
| 518 | }
|
|---|
| 519 |
|
|---|
| 520 | foreach my $eo (qw (OUT ERR))
|
|---|
| 521 | {
|
|---|
| 522 | my $subst_expr = $expect->{RESULT_SUBST}->{$eo};
|
|---|
| 523 | if (defined $subst_expr)
|
|---|
| 524 | {
|
|---|
| 525 | my $out = $actual{$eo};
|
|---|
| 526 | my $orig = "$out.orig";
|
|---|
| 527 |
|
|---|
| 528 | # Move $out aside (to $orig), then recreate $out
|
|---|
| 529 | # by transforming each line of $orig via $subst_expr.
|
|---|
| 530 | rename $out, $orig
|
|---|
| 531 | or (warn "$program_name: cannot rename $out to $orig: $!\n"),
|
|---|
| 532 | $fail = 1, next;
|
|---|
| 533 | open IN, $orig
|
|---|
| 534 | or (warn "$program_name: cannot open $orig for reading: $!\n"),
|
|---|
| 535 | $fail = 1, (unlink $orig), next;
|
|---|
| 536 | unlink $orig
|
|---|
| 537 | or (warn "$program_name: cannot unlink $orig: $!\n"),
|
|---|
| 538 | $fail = 1;
|
|---|
| 539 | open OUT, ">$out"
|
|---|
| 540 | or (warn "$program_name: cannot open $out for writing: $!\n"),
|
|---|
| 541 | $fail = 1, next;
|
|---|
| 542 | while (defined (my $line = <IN>))
|
|---|
| 543 | {
|
|---|
| 544 | eval "\$_ = \$line; $subst_expr; \$line = \$_";
|
|---|
| 545 | print OUT $line;
|
|---|
| 546 | }
|
|---|
| 547 | close IN;
|
|---|
| 548 | close OUT
|
|---|
| 549 | or (warn "$program_name: failed to write $out: $!\n"),
|
|---|
| 550 | $fail = 1, next;
|
|---|
| 551 | }
|
|---|
| 552 |
|
|---|
| 553 | my $eo_lower = lc $eo;
|
|---|
| 554 | _compare_files ($program_name, $test_name, $eo_lower,
|
|---|
| 555 | $actual{$eo}, $expect->{$eo})
|
|---|
| 556 | and $fail = 1;
|
|---|
| 557 | }
|
|---|
| 558 |
|
|---|
| 559 | foreach my $pair (@post_compare)
|
|---|
| 560 | {
|
|---|
| 561 | my ($expected, $actual) = @$pair;
|
|---|
| 562 | _compare_files $program_name, $test_name, undef, $actual, $expected
|
|---|
| 563 | and $fail = 1;
|
|---|
| 564 | }
|
|---|
| 565 |
|
|---|
| 566 | cleanup:
|
|---|
| 567 | $expect->{POST}
|
|---|
| 568 | and &{$expect->{POST}} ($actual_data{OUT}, $actual_data{ERR});
|
|---|
| 569 |
|
|---|
| 570 | }
|
|---|
| 571 |
|
|---|
| 572 | # FIXME: maybe unlink files inside the big foreach loop?
|
|---|
| 573 | unlink @junk_files if ! $save_temps;
|
|---|
| 574 |
|
|---|
| 575 | return $fail;
|
|---|
| 576 | }
|
|---|
| 577 |
|
|---|
| 578 | # For each test in @$TESTS, generate two additional tests,
|
|---|
| 579 | # one using stdin, the other using a pipe. I.e., given this one
|
|---|
| 580 | # ['idem-0', {IN=>''}, {OUT=>''}],
|
|---|
| 581 | # generate these:
|
|---|
| 582 | # ['idem-0.r', '<', {IN=>''}, {OUT=>''}],
|
|---|
| 583 | # ['idem-0.p', {IN_PIPE=>''}, {OUT=>''}],
|
|---|
| 584 | # Generate new tests only if there is exactly one input spec.
|
|---|
| 585 | # The returned list of tests contains each input test, followed
|
|---|
| 586 | # by zero or two derived tests.
|
|---|
| 587 | sub triple_test($)
|
|---|
| 588 | {
|
|---|
| 589 | my ($tests) = @_;
|
|---|
| 590 | my @new;
|
|---|
| 591 | foreach my $t (@$tests)
|
|---|
| 592 | {
|
|---|
| 593 | push @new, $t;
|
|---|
| 594 |
|
|---|
| 595 | my @in;
|
|---|
| 596 | my @args;
|
|---|
| 597 | my @list_of_hash;
|
|---|
| 598 | foreach my $e (@$t)
|
|---|
| 599 | {
|
|---|
| 600 | !ref $e
|
|---|
| 601 | and push (@args, $e), next;
|
|---|
| 602 |
|
|---|
| 603 | ref $e && ref $e eq 'HASH'
|
|---|
| 604 | or (warn "$0: $t->[0]: unexpected entry type\n"), next;
|
|---|
| 605 | defined $e->{IN}
|
|---|
| 606 | and (push @in, $e->{IN}), next;
|
|---|
| 607 | push @list_of_hash, $e;
|
|---|
| 608 | }
|
|---|
| 609 | # Add variants IFF there is exactly one input file.
|
|---|
| 610 | @in == 1
|
|---|
| 611 | or next;
|
|---|
| 612 | shift @args; # discard test name
|
|---|
| 613 | push @new, ["$t->[0].r", @args, '<', {IN => $in[0]}, @list_of_hash];
|
|---|
| 614 | push @new, ["$t->[0].p", @args, {IN_PIPE => $in[0]}, @list_of_hash];
|
|---|
| 615 | }
|
|---|
| 616 | return @new;
|
|---|
| 617 | }
|
|---|
| 618 |
|
|---|
| 619 | ## package return
|
|---|
| 620 | 1;
|
|---|
