blob: 752dbbf16a257c7595837165c89c1a174c547b6b [file] [log] [blame]
Dieter Baron8a3ea142014-05-09 11:55:31 +02001package NiHTest;
2
3use strict;
4use warnings;
5
6use Cwd;
7use File::Copy;
Thomas Klausnerea510d42015-09-15 13:54:15 +02008use File::Path qw(mkpath remove_tree);
Dieter Barond5fced42016-02-17 14:13:55 +01009use Getopt::Long qw(:config posix_default bundling no_ignore_case);
Dieter Baron8a3ea142014-05-09 11:55:31 +020010use IPC::Open3;
Tomáš Malý6ad85d72019-10-07 14:24:26 +020011#use IPC::Cmd qw(run);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +020012use Storable qw(dclone);
Dieter Baron8a3ea142014-05-09 11:55:31 +020013use Symbol 'gensym';
14use UNIVERSAL;
15
Thomas Klausnerbc6c7232017-08-14 15:26:22 +020016#use Data::Dumper qw(Dumper);
Dieter Baron8a3ea142014-05-09 11:55:31 +020017
18# NiHTest -- package to run regression tests
Dieter Barond5fced42016-02-17 14:13:55 +010019# Copyright (C) 2002-2016 Dieter Baron and Thomas Klausner
Dieter Baron8a3ea142014-05-09 11:55:31 +020020#
21# This file is part of ckmame, a program to check rom sets for MAME.
22# The authors can be contacted at <ckmame@nih.at>
23#
24# Redistribution and use in source and binary forms, with or without
25# modification, are permitted provided that the following conditions
26# are met:
27# 1. Redistributions of source code must retain the above copyright
28# notice, this list of conditions and the following disclaimer.
29# 2. Redistributions in binary form must reproduce the above copyright
30# notice, this list of conditions and the following disclaimer in
31# the documentation and/or other materials provided with the
32# distribution.
33# 3. The names of the authors may not be used to endorse or promote
34# products derived from this software without specific prior
35# written permission.
36#
37# THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
38# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
39# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
40# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
41# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
42# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
43# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
44# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
45# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
46# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
47# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
48
49# runtest TESTNAME
50#
51# files:
52# TESTNAME.test: test scenario
53#
54# test scenario:
55# Lines beginning with # are comments.
56#
57# The following commands are recognized; return and args must
58# appear exactly once, the others are optional.
59#
60# args ARGS
61# run program with command line arguments ARGS
62#
63# description TEXT
64# description of what test is for
65#
66# features FEATURE ...
67# only run test if all FEATUREs are present, otherwise skip it.
68#
69# file TEST IN OUT
70# copy file IN as TEST, compare against OUT after program run.
71#
72# file-del TEST IN
73# copy file IN as TEST, check that it is removed by program.
74#
75# file-new TEST OUT
76# check that file TEST is created by program and compare
77# against OUT.
78#
79# mkdir MODE NAME
80# create directory NAME with permissions MODE.
81#
Dieter Baronb437aba2017-12-13 14:31:51 +010082# precheck COMMAND ARGS ...
83# if COMMAND exits with non-zero status, skip test.
84#
Dieter Baron8a3ea142014-05-09 11:55:31 +020085# preload LIBRARY
86# pre-load LIBRARY before running program.
87#
88# program PRG
89# run PRG instead of ckmame.
90#
91# return RET
92# RET is the expected exit code
93#
94# setenv VAR VALUE
95# set environment variable VAR to VALUE.
96#
97# stderr TEXT
98# program is expected to produce the error message TEXT. If
99# multiple stderr commands are used, the messages are
100# expected in the order given.
101#
102# stderr-replace REGEX REPLACEMENT
103# run regex replacement over expected and got stderr output.
104#
Dieter Baron4560f772020-05-30 10:30:03 +0200105# stdin TEST
106# Provide TEXT to program's stdin.
107#
108# stdin-file FILE
109# pipe FILE to program's stdin.
110#
Dieter Baron8a3ea142014-05-09 11:55:31 +0200111# stdout TEXT
112# program is expected to print TEXT to stdout. If multiple
113# stdout commands are used, the messages are expected in
114# the order given.
115#
116# touch MTIME FILE
117# set last modified timestamp of FILE to MTIME (seconds since epoch).
118# If FILE doesn't exist, an empty file is created.
119#
120# ulimit C VALUE
121# set ulimit -C to VALUE while running the program.
122#
123# exit status
124# runtest uses the following exit codes:
125# 0: test passed
126# 1: test failed
127# 2: other error
128# 77: test was skipped
129#
130# environment variables:
131# RUN_GDB: if set, run gdb on program in test environment
132# KEEP_BROKEN: if set, don't delete test environment if test failed
133# NO_CLEANUP: if set, don't delete test environment
134# SETUP_ONLY: if set, exit after creating test environment
135# VERBOSE: if set, be more verbose (e. g., output diffs)
136
137my %EXIT_CODES = (
138 PASS => 0,
139 FAIL => 1,
140 SKIP => 77,
141 ERROR => 99
142 );
143
Dieter Baronc1f7e002017-03-31 10:11:49 +0200144# MARK: - Public API
145
Dieter Baron8a3ea142014-05-09 11:55:31 +0200146sub new {
147 my $class = UNIVERSAL::isa ($_[0], __PACKAGE__) ? shift : __PACKAGE__;
148 my $self = bless {}, $class;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200149
Dieter Baron8a3ea142014-05-09 11:55:31 +0200150 my ($opts) = @_;
151
152 $self->{default_program} = $opts->{default_program};
153 $self->{zipcmp} = $opts->{zipcmp} // 'zipcmp';
Thomas Klausnerf5024512017-05-22 12:09:01 +0200154 $self->{zipcmp_flags} = $opts->{zipcmp_flags} // '-p';
Dieter Baron8a3ea142014-05-09 11:55:31 +0200155
156 $self->{directives} = {
157 args => { type => 'string...', once => 1, required => 1 },
158 description => { type => 'string', once => 1 },
159 features => { type => 'string...', once => 1 },
160 file => { type => 'string string string' },
161 'file-del' => { type => 'string string' },
162 'file-new' => { type => 'string string' },
163 mkdir => { type => 'string string' },
Dieter Baronb437aba2017-12-13 14:31:51 +0100164 precheck => { type => 'string...' },
Dieter Baron8a3ea142014-05-09 11:55:31 +0200165 preload => { type => 'string', once => 1 },
166 program => { type => 'string', once => 1 },
167 'return' => { type => 'int', once => 1, required => 1 },
168 setenv => { type => 'string string' },
169 stderr => { type => 'string' },
170 'stderr-replace' => { type => 'string string' },
Thomas Klausner14a97bd2020-05-27 23:37:38 +0200171 stdin => { type => 'string' },
Dieter Baron4560f772020-05-30 10:30:03 +0200172 'stdin-file' => { type => 'string', once => 1 },
Dieter Baron8a3ea142014-05-09 11:55:31 +0200173 stdout => { type => 'string' },
174 touch => { type => 'int string' },
175 ulimit => { type => 'char string' }
176 };
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200177
Dieter Baron8a3ea142014-05-09 11:55:31 +0200178 $self->{compare_by_type} = {};
179 $self->{copy_by_type} = {};
180 $self->{hooks} = {};
181
Dieter Baronc1f7e002017-03-31 10:11:49 +0200182 $self->get_variable('srcdir', $opts);
183 $self->get_variable('top_builddir', $opts);
184
Dieter Baron8a3ea142014-05-09 11:55:31 +0200185 $self->{in_sandbox} = 0;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200186
Dieter Baron8a3ea142014-05-09 11:55:31 +0200187 $self->{verbose} = $ENV{VERBOSE};
188 $self->{keep_broken} = $ENV{KEEP_BROKEN};
189 $self->{no_cleanup} = $ENV{NO_CLEANUP};
190 $self->{setup_only} = $ENV{SETUP_ONLY};
191
192 return $self;
193}
194
195
196sub add_comparator {
197 my ($self, $ext, $sub) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200198
Dieter Baron8a3ea142014-05-09 11:55:31 +0200199 return $self->add_file_proc('compare_by_type', $ext, $sub);
200}
201
202
203sub add_copier {
204 my ($self, $ext, $sub) = @_;
205
206 return $self->add_file_proc('copy_by_type', $ext, $sub);
207}
208
209
210sub add_directive {
211 my ($self, $name, $def) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200212
Dieter Baron8a3ea142014-05-09 11:55:31 +0200213 if (exists($self->{directives}->{$name})) {
214 $self->die("directive $name already defined");
215 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200216
Dieter Baron8a3ea142014-05-09 11:55:31 +0200217 # TODO: validate $def
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200218
Dieter Baron8a3ea142014-05-09 11:55:31 +0200219 $self->{directives}->{$name} = $def;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200220
Dieter Baron8a3ea142014-05-09 11:55:31 +0200221 return 1;
222}
223
224
225sub add_file_proc {
226 my ($self, $proc, $ext, $sub) = @_;
227
228 $self->{$proc}->{$ext} = [] unless (defined($self->{$proc}->{$ext}));
229 unshift @{$self->{$proc}->{$ext}}, $sub;
230
231 return 1;
232}
233
234
235sub add_hook {
236 my ($self, $hook, $sub) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200237
Dieter Baron8a3ea142014-05-09 11:55:31 +0200238 $self->{hooks}->{$hook} = [] unless (defined($self->{hooks}->{$hook}));
239 push @{$self->{hooks}->{$hook}}, $sub;
240
241 return 1;
242}
243
244
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200245sub add_variant {
246 my ($self, $name, $hooks) = @_;
247
248 if (!defined($self->{variants})) {
249 $self->{variants} = [];
250 $self->add_directive('variants' => { type => 'string...', once => 1 });
251 }
252 for my $variant (@{$self->{variants}}) {
253 if ($variant->{name} eq $name) {
254 $self->die("variant $name already defined");
255 }
256 }
257
258 push @{$self->{variants}}, { name => $name, hooks => $hooks };
259
260 return 1;
261}
262
263
Dieter Baron8a3ea142014-05-09 11:55:31 +0200264sub end {
265 my ($self, @results) = @_;
266
267 my $result = 'PASS';
268
269 for my $r (@results) {
270 if ($r eq 'ERROR' || ($r eq 'FAIL' && $result ne 'ERROR')) {
271 $result = $r;
272 }
273 }
274
275 $self->end_test($result);
276}
277
278
279sub run {
280 my ($self, @argv) = @_;
281
282 $self->setup(@argv);
283
284 $self->end($self->runtest());
285}
286
287
288sub runtest {
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200289 my ($self) = @_;
290
291 if (defined($self->{variants})) {
292 my @results = ();
293 $self->{original_test} = $self->{test};
294
295 my %variants;
296
297 if (defined($self->{test}->{variants})) {
298 %variants = map { $_ => 1; } @{$self->{test}->{variants}};
299 }
300
301 for my $variant (@{$self->{variants}}) {
302 next if (defined($self->{test}->{variants}) && !exists($variants{$variant->{name}}));
303
304 $self->{variant_hooks} = $variant->{hooks};
305 $self->{test} = dclone($self->{original_test});
306 $self->{variant} = $variant->{name};
307 $self->mangle_test_for_variant();
308 push @results, $self->runtest_one($variant->{name});
309 }
310
311 return @results;
312 }
313 else {
314 return $self->runtest_one();
315 }
316}
317
318
319sub runtest_one {
Dieter Baron8a3ea142014-05-09 11:55:31 +0200320 my ($self, $tag) = @_;
321
Thomas Klausner5cd63ce2014-12-02 11:52:38 +0100322 $ENV{TZ} = "UTC";
323 $ENV{LC_CTYPE} = "C";
Thomas Klausner2f947e82016-12-18 17:13:08 +0100324 $ENV{POSIXLY_CORRECT} = 1;
Dieter Baron8a3ea142014-05-09 11:55:31 +0200325 $self->sandbox_create($tag);
326 $self->sandbox_enter();
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200327
Dieter Baron8a3ea142014-05-09 11:55:31 +0200328 my $ok = 1;
329 $ok &= $self->copy_files();
330 $ok &= $self->run_hook('post_copy_files');
331 $ok &= $self->touch_files();
332 $ok &= $self->run_hook('prepare_sandbox');
333 return 'ERROR' unless ($ok);
334
335 if ($self->{setup_only}) {
Thomas Klausner276fef42014-12-02 14:43:01 +0100336 $self->sandbox_leave();
337 return 'SKIP';
Dieter Baron8a3ea142014-05-09 11:55:31 +0200338 }
339
340 for my $env (@{$self->{test}->{'setenv'}}) {
Thomas Klausner276fef42014-12-02 14:43:01 +0100341 $ENV{$env->[0]} = $env->[1];
Dieter Baron8a3ea142014-05-09 11:55:31 +0200342 }
Dieter Baron035af2e2017-01-29 10:10:16 +0100343 my $preload_env_var = 'LD_PRELOAD';
344 if ($^O eq 'darwin') {
345 $preload_env_var = 'DYLD_INSERT_LIBRARIES';
346 }
Dieter Baron8a3ea142014-05-09 11:55:31 +0200347 if (defined($self->{test}->{'preload'})) {
Thomas Klausner9060c8f2017-12-06 18:53:47 +0100348 if (-f cwd() . "/../.libs/$self->{test}->{'preload'}") {
349 $ENV{$preload_env_var} = cwd() . "/../.libs/$self->{test}->{'preload'}";
350 } else {
351 $ENV{$preload_env_var} = cwd() . "/../lib$self->{test}->{'preload'}";
352 }
Dieter Baron8a3ea142014-05-09 11:55:31 +0200353 }
354
355 $self->run_program();
356
357 for my $env (@{$self->{test}->{'setenv'}}) {
Thomas Klausner276fef42014-12-02 14:43:01 +0100358 delete ${ENV{$env->[0]}};
Dieter Baron8a3ea142014-05-09 11:55:31 +0200359 }
360 if (defined($self->{test}->{'preload'})) {
Dieter Baron035af2e2017-01-29 10:10:16 +0100361 delete ${ENV{$preload_env_var}};
Dieter Baron8a3ea142014-05-09 11:55:31 +0200362 }
363
Thomas Klausner14a97bd2020-05-27 23:37:38 +0200364 if ($self->{test}->{stdin}) {
365 $self->{stdin} = [ @{$self->{test}->{stdin}} ];
366 }
367
Dieter Baron8a3ea142014-05-09 11:55:31 +0200368 if ($self->{test}->{stdout}) {
369 $self->{expected_stdout} = [ @{$self->{test}->{stdout}} ];
370 }
371 else {
372 $self->{expected_stdout} = [];
373 }
374 if ($self->{test}->{stderr}) {
375 $self->{expected_stderr} = [ @{$self->{test}->{stderr}} ];
376 }
377 else {
378 $self->{expected_stderr} = [];
379 }
380
381 $self->run_hook('post_run_program');
382
383 my @failed = ();
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200384
Dieter Baron7adc6cc2016-03-03 10:47:00 +0100385 if ($self->{exit_status} != ($self->{test}->{return} // 0)) {
Dieter Baron8a3ea142014-05-09 11:55:31 +0200386 push @failed, 'exit status';
387 if ($self->{verbose}) {
388 print "Unexpected exit status:\n";
389 print "-" . ($self->{test}->{return} // 0) . "\n+$self->{exit_status}\n";
390 }
391 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200392
Dieter Baron8a3ea142014-05-09 11:55:31 +0200393 if (!$self->compare_arrays($self->{expected_stdout}, $self->{stdout}, 'output')) {
394 push @failed, 'output';
395 }
396 if (!$self->compare_arrays($self->{expected_stderr}, $self->{stderr}, 'error output')) {
397 push @failed, 'error output';
398 }
399 if (!$self->compare_files()) {
400 push @failed, 'files';
401 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200402
Dieter Baron8a3ea142014-05-09 11:55:31 +0200403 $self->{failed} = \@failed;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200404
Dieter Baron8a3ea142014-05-09 11:55:31 +0200405 $self->run_hook('checks');
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200406
Dieter Baron8a3ea142014-05-09 11:55:31 +0200407 my $result = scalar(@{$self->{failed}}) == 0 ? 'PASS' : 'FAIL';
408
409 $self->sandbox_leave();
410 if (!($self->{no_cleanup} || ($self->{keep_broken} && $result eq 'FAIL'))) {
411 $self->sandbox_remove();
412 }
413
414 $self->print_test_result($tag, $result, join ', ', @{$self->{failed}});
415
416 return $result;
417}
418
419
420sub setup {
421 my ($self, @argv) = @_;
Dieter Barond5fced42016-02-17 14:13:55 +0100422
423 my @save_argv = @ARGV;
424 @ARGV = @argv;
425 my $ok = GetOptions(
426 'help|h' => \my $help,
Dieter Baroned78a6f2020-01-07 15:07:10 +0100427 'bin-sub-directory=s' => \$self->{bin_sub_directory},
Thomas Klausnerf5024512017-05-22 12:09:01 +0200428 'keep-broken|k' => \$self->{keep_broken},
Dieter Barond5fced42016-02-17 14:13:55 +0100429 'no-cleanup' => \$self->{no_cleanup},
430 # 'run-gdb' => \$self->{run_gdb},
431 'setup-only' => \$self->{setup_only},
432 'verbose|v' => \$self->{verbose}
433 );
434 @argv = @ARGV;
435 @ARGV = @save_argv;
436
437 if (!$ok || scalar(@argv) != 1 || $help) {
Dieter Baroned78a6f2020-01-07 15:07:10 +0100438 print STDERR "Usage: $0 [-hv] [--bin-sub-directory DIR] [--keep-broken] [--no-cleanup] [--setup-only] testcase\n";
Dieter Baron8a3ea142014-05-09 11:55:31 +0200439 exit(1);
440 }
Dieter Barond5fced42016-02-17 14:13:55 +0100441
Dieter Baron8a3ea142014-05-09 11:55:31 +0200442 my $testcase = shift @argv;
443
444 $testcase .= '.test' unless ($testcase =~ m/\.test$/);
445
446 my $testcase_file = $self->find_file($testcase);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200447
Dieter Baron8a3ea142014-05-09 11:55:31 +0200448 $self->die("cannot find test case $testcase") unless ($testcase_file);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200449
Dieter Baron8a3ea142014-05-09 11:55:31 +0200450 $testcase =~ s,^(?:.*/)?([^/]*)\.test$,$1,;
451 $self->{testname} = $testcase;
452
453 $self->die("error in test case definition") unless $self->parse_case($testcase_file);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200454
Dieter Baron8a3ea142014-05-09 11:55:31 +0200455 $self->check_features_requirement() if ($self->{test}->{features});
Dieter Baronb437aba2017-12-13 14:31:51 +0100456 $self->run_precheck() if ($self->{test}->{precheck});
Dieter Barond5fced42016-02-17 14:13:55 +0100457
Thomas Klausnerf9c30372020-05-19 13:54:29 +0200458 $self->end_test('SKIP') if ($self->{test}->{preload} && ($^O eq 'darwin' || $^O eq 'MSWin32'));
Thomas Klausnerc8ade562020-06-24 09:02:47 +0200459 $self->end_test('SKIP') if (($self->{test}->{stdin} || $self->{test}->{'stdin-file'}) && $^O eq 'MSWin32');
Dieter Baron8a3ea142014-05-09 11:55:31 +0200460}
461
462
Dieter Baronc1f7e002017-03-31 10:11:49 +0200463# MARK: - Internal Methods
Dieter Baron8a3ea142014-05-09 11:55:31 +0200464
465sub add_file {
466 my ($self, $file) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200467
Dieter Baron8a3ea142014-05-09 11:55:31 +0200468 if (defined($self->{files}->{$file->{destination}})) {
469 $self->warn("duplicate specification for input file $file->{destination}");
470 return undef;
471 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200472
Dieter Baron8a3ea142014-05-09 11:55:31 +0200473 $self->{files}->{$file->{destination}} = $file;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200474
Dieter Baron8a3ea142014-05-09 11:55:31 +0200475 return 1;
476}
477
478
479sub check_features_requirement() {
480 my ($self) = @_;
Dieter Baronc1f7e002017-03-31 10:11:49 +0200481
482 my %features;
483
484 my $fh;
485 unless (open($fh, '<', "$self->{top_builddir}/config.h")) {
486 $self->die("cannot open config.h in top builddir $self->{top_builddir}");
487 }
488 while (my $line = <$fh>) {
489 if ($line =~ m/^#define HAVE_([A-Z0-9_a-z]*)/) {
490 $features{$1} = 1;
491 }
492 }
493 close($fh);
494
495 my @missing = ();
496 for my $feature (@{$self->{test}->{features}}) {
497 if (!$features{$feature}) {
498 push @missing, $feature;
499 }
500 }
501
502 if (scalar @missing > 0) {
503 my $reason = "missing features";
504 if (scalar(@missing) == 1) {
505 $reason = "missing feature";
506 }
507 $self->print_test_result('SKIP', "$reason: " . (join ' ', @missing));
508 $self->end_test('SKIP');
509 }
510
Dieter Baron8a3ea142014-05-09 11:55:31 +0200511 return 1;
512}
513
514
515sub comparator_zip {
516 my ($self, $got, $expected) = @_;
517
Tomáš Malý6ad85d72019-10-07 14:24:26 +0200518 my $zipcmp = (-f $self->{zipcmp}) ? $self->{zipcmp} : $self->find_program('zipcmp');
519 my @args = ($zipcmp, $self->{verbose} ? '-v' : '-q');
Dieter Baron8a3ea142014-05-09 11:55:31 +0200520 push @args, $self->{zipcmp_flags} if ($self->{zipcmp_flags});
521 push @args, ($expected, $got);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200522
Dieter Baron8a3ea142014-05-09 11:55:31 +0200523 my $ret = system(@args);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200524
Dieter Baron8a3ea142014-05-09 11:55:31 +0200525 return $ret == 0;
526}
527
528
529sub compare_arrays() {
530 my ($self, $a, $b, $tag) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200531
Dieter Baron8a3ea142014-05-09 11:55:31 +0200532 my $ok = 1;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200533
Dieter Baron8a3ea142014-05-09 11:55:31 +0200534 if (scalar(@$a) != scalar(@$b)) {
535 $ok = 0;
536 }
537 else {
538 for (my $i = 0; $i < scalar(@$a); $i++) {
539 if ($a->[$i] ne $b->[$i]) {
540 $ok = 0;
541 last;
542 }
543 }
544 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200545
Dieter Baron8a3ea142014-05-09 11:55:31 +0200546 if (!$ok && $self->{verbose}) {
547 print "Unexpected $tag:\n";
548 print "--- expected\n+++ got\n";
Thomas Klausner276fef42014-12-02 14:43:01 +0100549
550 diff_arrays($a, $b);
Dieter Baron8a3ea142014-05-09 11:55:31 +0200551 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200552
Dieter Baron8a3ea142014-05-09 11:55:31 +0200553 return $ok;
554}
555
Thomas Klausner8addde52015-09-15 14:00:52 +0200556sub file_cmp($$) {
557 my ($a, $b) = @_;
558 my $result = 0;
559 open my $fha, "< $a";
560 open my $fhb, "< $b";
561 binmode $fha;
562 binmode $fhb;
563 BYTE: while (!eof $fha && !eof $fhb) {
564 if (getc $fha ne getc $fhb) {
565 $result = 1;
566 last BYTE;
567 }
568 }
569 $result = 1 if eof $fha != eof $fhb;
570 close $fha;
571 close $fhb;
572 return $result;
573}
Dieter Baron8a3ea142014-05-09 11:55:31 +0200574
Thomas Klausner8addde52015-09-15 14:00:52 +0200575sub compare_file($$$) {
Dieter Baron8a3ea142014-05-09 11:55:31 +0200576 my ($self, $got, $expected) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200577
Dieter Baron8a3ea142014-05-09 11:55:31 +0200578 my $real_expected = $self->find_file($expected);
579 unless ($real_expected) {
580 $self->warn("cannot find expected result file $expected");
581 return 0;
582 }
583
584 my $ok = $self->run_comparator($got, $real_expected);
585
586 if (!defined($ok)) {
Thomas Klausner4b1053e2014-12-02 10:58:13 +0100587 my $ret;
588 if ($self->{verbose}) {
589 $ret = system('diff', '-u', $real_expected, $got);
590 }
591 else {
Thomas Klausner8addde52015-09-15 14:00:52 +0200592 $ret = file_cmp($real_expected, $got);
Thomas Klausner4b1053e2014-12-02 10:58:13 +0100593 }
Dieter Baron8a3ea142014-05-09 11:55:31 +0200594 $ok = ($ret == 0);
595 }
596
597 return $ok;
598}
599
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200600sub list_files {
601 my ($root) = @_;
602 my $ls;
603
604 my @files = ();
605 my @dirs = ($root);
606
607 while (scalar(@dirs) > 0) {
608 my $dir = shift @dirs;
Dieter Baroned78a6f2020-01-07 15:07:10 +0100609
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200610 opendir($ls, $dir);
611 unless ($ls) {
612 # TODO: handle error
613 }
614 while (my $entry = readdir($ls)) {
615 my $file = "$dir/$entry";
616 if ($dir eq '.') {
617 $file = $entry;
618 }
Dieter Baroned78a6f2020-01-07 15:07:10 +0100619
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200620 if (-f $file) {
621 push @files, "$file";
622 }
623 if (-d $file && $entry ne '.' && $entry ne '..') {
624 push @dirs, "$file";
625 }
626 }
627 closedir($ls);
628 }
629
630 return @files;
631}
Dieter Barond5fced42016-02-17 14:13:55 +0100632
Dieter Baron8a3ea142014-05-09 11:55:31 +0200633sub compare_files() {
634 my ($self) = @_;
Thomas Klausnerea510d42015-09-15 13:54:15 +0200635
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200636 my $ok = 1;
637
638
639 my @files_got = sort(list_files("."));
Dieter Baron8a3ea142014-05-09 11:55:31 +0200640 my @files_should = ();
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200641
Dieter Barondd9d8a02014-08-05 23:18:48 +0200642 for my $file (sort keys %{$self->{files}}) {
Dieter Baron8a3ea142014-05-09 11:55:31 +0200643 push @files_should, $file if ($self->{files}->{$file}->{result} || $self->{files}->{$file}->{ignore});
644 }
645
646 $self->{files_got} = \@files_got;
647 $self->{files_should} = \@files_should;
648
649 unless ($self->run_hook('post_list_files')) {
650 return 0;
651 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200652
Dieter Baron8a3ea142014-05-09 11:55:31 +0200653 $ok = $self->compare_arrays($self->{files_should}, $self->{files_got}, 'files');
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200654
Dieter Baron8a3ea142014-05-09 11:55:31 +0200655 for my $file (@{$self->{files_got}}) {
656 my $file_def = $self->{files}->{$file};
657 next unless ($file_def && $file_def->{result});
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200658
Dieter Baron8a3ea142014-05-09 11:55:31 +0200659 $ok &= $self->compare_file($file, $file_def->{result});
660 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200661
Dieter Baron8a3ea142014-05-09 11:55:31 +0200662 return $ok;
663}
664
665
666sub copy_files {
667 my ($self) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200668
Dieter Baron8a3ea142014-05-09 11:55:31 +0200669 my $ok = 1;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200670
Dieter Baron8a3ea142014-05-09 11:55:31 +0200671 for my $filename (sort keys %{$self->{files}}) {
672 my $file = $self->{files}->{$filename};
673 next unless ($file->{source});
674
675 my $src = $self->find_file($file->{source});
676 unless ($src) {
677 $self->warn("cannot find input file $file->{source}");
678 $ok = 0;
679 next;
680 }
681
682 if ($file->{destination} =~ m,/,) {
683 my $dir = $file->{destination};
684 $dir =~ s,/[^/]*$,,;
685 if (! -d $dir) {
686 mkpath($dir);
687 }
688 }
689
690 my $this_ok = $self->run_copier($src, $file->{destination});
691 if (defined($this_ok)) {
692 $ok &= $this_ok;
693 }
694 else {
695 unless (copy($src, $file->{destination})) {
696 $self->warn("cannot copy $src to $file->{destination}: $!");
697 $ok = 0;
698 }
699 }
700 }
701
702 if (defined($self->{test}->{mkdir})) {
703 for my $dir_spec (@{$self->{test}->{mkdir}}) {
704 my ($mode, $dir) = @$dir_spec;
705 if (! -d $dir) {
706 unless (mkdir($dir, oct($mode))) {
707 $self->warn("cannot create directory $dir: $!");
708 $ok = 0;
709 }
710 }
711 }
712 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200713
Dieter Baron8a3ea142014-05-09 11:55:31 +0200714 $self->die("failed to copy input files") unless ($ok);
715}
716
717
718sub die() {
719 my ($self, $msg) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200720
Dieter Baron8a3ea142014-05-09 11:55:31 +0200721 print STDERR "$0: $msg\n" if ($msg);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200722
Dieter Baron8a3ea142014-05-09 11:55:31 +0200723 $self->end_test('ERROR');
724}
725
726
727sub end_test {
728 my ($self, $status) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200729
Dieter Baron8a3ea142014-05-09 11:55:31 +0200730 my $exit_code = $EXIT_CODES{$status} // $EXIT_CODES{ERROR};
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200731
Dieter Baron8a3ea142014-05-09 11:55:31 +0200732 $self->exit($exit_code);
733}
734
735
736
737sub exit() {
738 my ($self, $status) = @_;
739 ### TODO: cleanup
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200740
Dieter Baron8a3ea142014-05-09 11:55:31 +0200741 exit($status);
742}
743
744
745sub find_file() {
746 my ($self, $fname) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200747
Dieter Baron8a3ea142014-05-09 11:55:31 +0200748 for my $dir (('', "$self->{srcdir}/")) {
749 my $f = "$dir$fname";
Tomáš Malý6ad85d72019-10-07 14:24:26 +0200750 $f = "../$f" if ($self->{in_sandbox} && $dir !~ m,^(\w:)?/,);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200751
Dieter Baron8a3ea142014-05-09 11:55:31 +0200752 return $f if (-f $f);
753 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200754
Dieter Baron8a3ea142014-05-09 11:55:31 +0200755 return undef;
756}
757
758
759sub get_extension {
760 my ($self, $fname) = @_;
761
762 my $ext = $fname;
763 if ($ext =~ m/\./) {
764 $ext =~ s/.*\.//;
765 }
766 else {
767 $ext = '';
768 }
769
770 return $ext;
771}
772
773
Dieter Baronc1f7e002017-03-31 10:11:49 +0200774sub get_variable {
775 my ($self, $name, $opts) = @_;
776
777 $self->{$name} = $opts->{$name} // $ENV{$name};
778 if (!defined($self->{$name}) || $self->{$name} eq '') {
779 my $fh;
780 unless (open($fh, '<', 'Makefile')) {
781 $self->die("cannot open Makefile: $!");
782 }
783 while (my $line = <$fh>) {
784 chomp $line;
785 if ($line =~ m/^$name = (.*)/) {
786 $self->{$name} = $1;
787 last;
788 }
789 }
790 close ($fh);
791 }
Dieter Barond9bffef2020-03-24 13:20:26 +0100792 if (!defined($self->{$name}) || $self->{$name} eq '') {
Dieter Baronc1f7e002017-03-31 10:11:49 +0200793 $self->die("cannot get variable $name");
794 }
795}
796
797
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200798sub mangle_test_for_variant {
799 my ($self) = @_;
800
801 $self->{test}->{stdout} = $self->strip_tags($self->{variant}, $self->{test}->{stdout});
802 $self->{test}->{stderr} = $self->strip_tags($self->{variant}, $self->{test}->{stderr});
803 $self->run_hook('mangle_test');
804
805 return 1;
806}
807
Dieter Baron8a3ea142014-05-09 11:55:31 +0200808sub parse_args {
809 my ($self, $type, $str) = @_;
Dieter Baron3a0f9382014-12-10 15:19:59 +0100810
811 if ($type eq 'string...') {
812 my $args = [];
813
814 while ($str ne '') {
815 if ($str =~ m/^\"/) {
816 unless ($str =~ m/^\"([^\"]*)\"\s*(.*)/) {
817 $self->warn_file_line("unclosed quote in [$str]");
818 return undef;
819 }
820 push @$args, $1;
821 $str = $2;
822 }
823 else {
824 $str =~ m/^(\S+)\s*(.*)/;
825 push @$args, $1;
826 $str = $2;
827 }
828 }
829
830 return $args;
831 }
832 elsif ($type =~ m/(\s|\.\.\.$)/) {
Dieter Baron8a3ea142014-05-09 11:55:31 +0200833 my $ellipsis = 0;
834 if ($type =~ m/(.*)\.\.\.$/) {
835 $ellipsis = 1;
836 $type = $1;
837 }
838 my @types = split /\s+/, $type;
839 my @strs = split /\s+/, $str;
Dieter Barond5fced42016-02-17 14:13:55 +0100840 my $optional = 0;
841 for (my $i = scalar(@types) - 1; $i >= 0; $i--) {
842 last unless ($types[$i] =~ m/(.*)\?$/);
843 $types[$i] = $1;
844 $optional++;
845 }
846
847 if ($ellipsis && $optional > 0) {
848 # TODO: check this when registering a directive
849 $self->warn_file_line("can't use ellipsis together with optional arguments");
850 return undef;
851 }
852 if (!$ellipsis && (scalar(@strs) < scalar(@types) - $optional || scalar(@strs) > scalar(@types))) {
853 my $expected = scalar(@types);
854 if ($optional > 0) {
855 $expected = ($expected - $optional) . "-$expected";
856 }
857 $self->warn_file_line("expected $expected arguments, got " . (scalar(@strs)));
Dieter Baron8a3ea142014-05-09 11:55:31 +0200858 return undef;
859 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200860
Dieter Baron8a3ea142014-05-09 11:55:31 +0200861 my $args = [];
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200862
Dieter Baron8a3ea142014-05-09 11:55:31 +0200863 my $n = scalar(@types);
864 for (my $i=0; $i<scalar(@strs); $i++) {
865 my $val = $self->parse_args(($i >= $n ? $types[$n-1] : $types[$i]), $strs[$i]);
866 return undef unless (defined($val));
867 push @$args, $val;
868 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200869
Dieter Baron8a3ea142014-05-09 11:55:31 +0200870 return $args;
871 }
872 else {
873 if ($type eq 'string') {
874 return $str;
875 }
876 elsif ($type eq 'int') {
877 if ($str !~ m/^\d+$/) {
878 $self->warn_file_line("illegal int [$str]");
879 return undef;
880 }
881 return $str+0;
882 }
883 elsif ($type eq 'char') {
884 if ($str !~ m/^.$/) {
885 $self->warn_file_line("illegal char [$str]");
886 return undef;
887 }
888 return $str;
889 }
890 else {
891 $self->warn_file_line("unknown type $type");
892 return undef;
893 }
894 }
895}
896
897
898sub parse_case() {
899 my ($self, $fname) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200900
Dieter Baron8a3ea142014-05-09 11:55:31 +0200901 my $ok = 1;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200902
Dieter Baron8a3ea142014-05-09 11:55:31 +0200903 open TST, "< $fname" or $self->die("cannot open test case $fname: $!");
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200904
Dieter Baron8a3ea142014-05-09 11:55:31 +0200905 $self->{testcase_fname} = $fname;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200906
Dieter Baron8a3ea142014-05-09 11:55:31 +0200907 my %test = ();
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200908
Dieter Baron8a3ea142014-05-09 11:55:31 +0200909 while (my $line = <TST>) {
Tomáš Malý6ad85d72019-10-07 14:24:26 +0200910 $line =~ s/(\n|\r)//g;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200911
Dieter Baron8a3ea142014-05-09 11:55:31 +0200912 next if ($line =~ m/^\#/);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200913
Dieter Baron8a3ea142014-05-09 11:55:31 +0200914 unless ($line =~ m/(\S*)(?:\s(.*))?/) {
915 $self->warn_file_line("cannot parse line $line");
916 $ok = 0;
917 next;
918 }
919 my ($cmd, $argstring) = ($1, $2//"");
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200920
Dieter Baron8a3ea142014-05-09 11:55:31 +0200921 my $def = $self->{directives}->{$cmd};
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200922
Dieter Baron8a3ea142014-05-09 11:55:31 +0200923 unless ($def) {
924 $self->warn_file_line("unknown directive $cmd in test file");
925 $ok = 0;
926 next;
927 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200928
Dieter Baron8a3ea142014-05-09 11:55:31 +0200929 my $args = $self->parse_args($def->{type}, $argstring);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200930
Dieter Barond5fced42016-02-17 14:13:55 +0100931 unless (defined($args)) {
Dieter Baron3a0f9382014-12-10 15:19:59 +0100932 $ok = 0;
933 next;
934 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200935
Dieter Baron8a3ea142014-05-09 11:55:31 +0200936 if ($def->{once}) {
937 if (defined($test{$cmd})) {
938 $self->warn_file_line("directive $cmd appeared twice in test file");
939 }
940 $test{$cmd} = $args;
941 }
942 else {
943 $test{$cmd} = [] unless (defined($test{$cmd}));
944 push @{$test{$cmd}}, $args;
945 }
946 }
947
948 close TST;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200949
Dieter Baron8a3ea142014-05-09 11:55:31 +0200950 return undef unless ($ok);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200951
Dieter Baron8a3ea142014-05-09 11:55:31 +0200952 for my $cmd (sort keys %test) {
953 if ($self->{directives}->{$cmd}->{required} && !defined($test{$cmd})) {
954 $self->warn_file("required directive $cmd missing in test file");
955 $ok = 0;
956 }
957 }
Thomas Klausner181f50c2017-08-14 11:38:51 +0200958
Dieter Baron4560f772020-05-30 10:30:03 +0200959 if ($test{'stdin-file'} && $test{stdin}) {
960 $self->warn_file("both stdin-file and stdin provided, choose one");
Thomas Klausner181f50c2017-08-14 11:38:51 +0200961 $ok = 0;
962 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200963
964 if (defined($self->{variants})) {
965 if (defined($test{variants})) {
966 for my $name (@{$test{variants}}) {
967 my $found = 0;
968 for my $variant (@{$self->{variants}}) {
969 if ($name eq $variant->{name}) {
970 $found = 1;
971 last;
972 }
973 }
974 if ($found == 0) {
975 $self->warn_file("unknown variant $name");
976 $ok = 0;
977 }
978 }
979 }
980 }
981
Dieter Baron8a3ea142014-05-09 11:55:31 +0200982 return undef unless ($ok);
983
984 if (defined($test{'stderr-replace'}) && defined($test{stderr})) {
Thomas Klausner276fef42014-12-02 14:43:01 +0100985 $test{stderr} = [ map { $self->stderr_rewrite($test{'stderr-replace'}, $_); } @{$test{stderr}} ];
Dieter Baron8a3ea142014-05-09 11:55:31 +0200986 }
987
988 if (!defined($test{program})) {
989 $test{program} = $self->{default_program};
990 }
991
992 $self->{test} = \%test;
993
994 $self->run_hook('mangle_program');
Thomas Klausnerbc6c7232017-08-14 15:26:22 +0200995
Dieter Baron8a3ea142014-05-09 11:55:31 +0200996 if (!$self->parse_postprocess_files()) {
997 return 0;
998 }
999
1000 return $self->run_hook('post_parse');
1001}
1002
1003
1004sub parse_postprocess_files {
1005 my ($self) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001006
Dieter Baron8a3ea142014-05-09 11:55:31 +02001007 $self->{files} = {};
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001008
Dieter Baron8a3ea142014-05-09 11:55:31 +02001009 my $ok = 1;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001010
Dieter Baron8a3ea142014-05-09 11:55:31 +02001011 for my $file (@{$self->{test}->{file}}) {
1012 $ok = 0 unless ($self->add_file({ source => $file->[1], destination => $file->[0], result => $file->[2] }));
1013 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001014
Dieter Baron8a3ea142014-05-09 11:55:31 +02001015 for my $file (@{$self->{test}->{'file-del'}}) {
1016 $ok = 0 unless ($self->add_file({ source => $file->[1], destination => $file->[0], result => undef }));
1017 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001018
Dieter Baron8a3ea142014-05-09 11:55:31 +02001019 for my $file (@{$self->{test}->{'file-new'}}) {
1020 $ok = 0 unless ($self->add_file({ source => undef, destination => $file->[0], result => $file->[1] }));
1021 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001022
Dieter Baron8a3ea142014-05-09 11:55:31 +02001023 return $ok;
1024}
1025
1026
1027sub print_test_result {
1028 my ($self, $tag, $result, $reason) = @_;
1029
1030 if ($self->{verbose}) {
1031 print "$self->{testname}";
1032 print " ($tag)" if ($tag);
1033 print " -- $result";
1034 print ": $reason" if ($reason);
1035 print "\n";
1036 }
1037}
1038
1039
1040sub run_comparator {
1041 my ($self, $got, $expected) = @_;
1042
1043 return $self->run_file_proc('compare_by_type', $got, $expected);
1044}
1045
1046
1047sub run_copier {
1048 my ($self, $src, $dest) = @_;
1049
1050 return $self->run_file_proc('copy_by_type', $src, $dest);
1051}
1052
1053
1054sub run_file_proc {
1055 my ($self, $proc, $got, $expected) = @_;
1056
1057 my $ext = ($self->get_extension($got)) . '/' . ($self->get_extension($expected));
1058
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001059 if ($self->{variant}) {
1060 if (defined($self->{$proc}->{"$self->{variant}/$ext"})) {
1061 for my $sub (@{$self->{$proc}->{"$self->{variant}/$ext"}}) {
1062 my $ret = $sub->($self, $got, $expected);
1063 return $ret if (defined($ret));
1064 }
1065 }
1066 }
Dieter Baron8a3ea142014-05-09 11:55:31 +02001067 if (defined($self->{$proc}->{$ext})) {
1068 for my $sub (@{$self->{$proc}->{$ext}}) {
1069 my $ret = $sub->($self, $got, $expected);
1070 return $ret if (defined($ret));
1071 }
1072 }
1073
1074 return undef;
1075}
1076
1077
1078sub run_hook {
1079 my ($self, $hook) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001080
Dieter Baron8a3ea142014-05-09 11:55:31 +02001081 my $ok = 1;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001082
1083 my @hooks = ();
1084
1085 if (defined($self->{variant_hooks}) && defined($self->{variant_hooks}->{$hook})) {
1086 push @hooks, $self->{variant_hooks}->{$hook};
1087 }
Dieter Baron8a3ea142014-05-09 11:55:31 +02001088 if (defined($self->{hooks}->{$hook})) {
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001089 push @hooks, @{$self->{hooks}->{$hook}};
1090 }
1091
1092 for my $sub (@hooks) {
1093 unless ($sub->($self, $hook, $self->{variant})) {
1094 $self->warn("hook $hook failed");
1095 $ok = 0;
Dieter Baron8a3ea142014-05-09 11:55:31 +02001096 }
1097 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001098
Dieter Baron8a3ea142014-05-09 11:55:31 +02001099 return $ok;
1100}
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001101
1102
Dieter Baronc57c4e02016-03-03 10:57:52 +01001103sub args_decode {
Dieter Baronc57c4e02016-03-03 10:57:52 +01001104 my ($str, $srcdir) = @_;
Dieter Baron3a0f9382014-12-10 15:19:59 +01001105
1106 if ($str =~ m/\\/) {
1107 $str =~ s/\\a/\a/gi;
1108 $str =~ s/\\b/\b/gi;
1109 $str =~ s/\\f/\f/gi;
1110 $str =~ s/\\n/\n/gi;
1111 $str =~ s/\\r/\r/gi;
1112 $str =~ s/\\t/\t/gi;
1113 $str =~ s/\\v/\cK/gi;
1114 $str =~ s/\\s/ /gi;
1115 # TODO: \xhh, \ooo
1116 $str =~ s/\\(.)/$1/g;
1117 }
1118
Dieter Baronc57c4e02016-03-03 10:57:52 +01001119 if ($srcdir !~ m,^/,) {
1120 $srcdir = "../$srcdir";
1121 }
1122
1123 if ($str =~ m/^\$srcdir(.*)/) {
1124 $str = "$srcdir$1";
1125 }
1126
Dieter Baron3a0f9382014-12-10 15:19:59 +01001127 return $str;
1128}
1129
1130
Dieter Baronb437aba2017-12-13 14:31:51 +01001131sub run_precheck {
1132 my ($self) = @_;
1133
1134 for my $precheck (@{$self->{test}->{precheck}}) {
1135 unless (system(@{$precheck}) == 0) {
1136 $self->print_test_result('SKIP', "precheck failed");
1137 $self->end_test('SKIP');
1138 }
1139 }
1140
1141 return 1;
1142}
1143
1144
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001145sub find_program() {
Dieter Baroned78a6f2020-01-07 15:07:10 +01001146 my ($self, $pname) = @_;
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001147
Dieter Baroned78a6f2020-01-07 15:07:10 +01001148 my @directories = (".");
1149 if ($self->{bin_sub_directory}) {
1150 push @directories, $self->{bin_sub_directory};
1151 }
1152
1153 for my $up (('.', '..', '../..', '../../..')) {
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001154 for my $sub (('.', 'src')) {
Dieter Baroned78a6f2020-01-07 15:07:10 +01001155 for my $dir (@directories) {
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001156 for my $ext (('', '.exe')) {
Dieter Baroned78a6f2020-01-07 15:07:10 +01001157 my $f = "$up/$sub/$dir/$pname$ext";
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001158 return $f if (-f $f);
1159 }
1160 }
1161 }
1162 }
1163
1164 return undef;
1165}
1166
1167
Dieter Baron8a3ea142014-05-09 11:55:31 +02001168sub run_program {
1169 my ($self) = @_;
Dieter Baron8a3ea142014-05-09 11:55:31 +02001170 my ($stdin, $stdout, $stderr);
1171 $stderr = gensym;
Dieter Baron3a0f9382014-12-10 15:19:59 +01001172
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001173 my @cmd = ($self->find_program($self->{test}->{program}), map ({ args_decode($_, $self->{srcdir}); } @{$self->{test}->{args}}));
Dieter Baron3a0f9382014-12-10 15:19:59 +01001174
Dieter Baron8a3ea142014-05-09 11:55:31 +02001175 ### TODO: catch errors?
Thomas Klausner181f50c2017-08-14 11:38:51 +02001176
1177 my $pid;
Dieter Baron4560f772020-05-30 10:30:03 +02001178 if ($self->{test}->{'stdin-file'}) {
1179 open(SPLAT, '<', $self->{test}->{'stdin-file'});
Dieter Baronf7b104a2017-08-14 12:23:14 +02001180 my $is_marked = eof SPLAT; # mark used
Thomas Klausner181f50c2017-08-14 11:38:51 +02001181 $pid = open3("<&SPLAT", $stdout, $stderr, @cmd);
1182 }
1183 else {
1184 $pid = open3($stdin, $stdout, $stderr, @cmd);
1185 }
Dieter Baron8a3ea142014-05-09 11:55:31 +02001186 $self->{stdout} = [];
1187 $self->{stderr} = [];
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001188
Thomas Klausner14a97bd2020-05-27 23:37:38 +02001189 if ($self->{test}->{stdin}) {
1190 foreach my $line (@{$self->{test}->{stdin}}) {
1191 print $stdin $line . "\n";
Dieter Baron8a3ea142014-05-09 11:55:31 +02001192 }
Dieter Baron8a3ea142014-05-09 11:55:31 +02001193 close($stdin);
1194 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001195
Dieter Baron8a3ea142014-05-09 11:55:31 +02001196 while (my $line = <$stdout>) {
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001197 $line =~ s/(\n|\r)//g;
Dieter Baron8a3ea142014-05-09 11:55:31 +02001198 push @{$self->{stdout}}, $line;
1199 }
1200 my $prg = $self->{test}->{program};
1201 $prg =~ s,.*/,,;
1202 while (my $line = <$stderr>) {
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001203 $line =~ s/(\n|\r)//g;
Dieter Baron6660ce22019-10-17 10:14:57 +02001204 $line =~ s/^[^: ]*$prg(\.exe)?: //;
Dieter Baron8a3ea142014-05-09 11:55:31 +02001205 if (defined($self->{test}->{'stderr-replace'})) {
Thomas Klausner276fef42014-12-02 14:43:01 +01001206 $line = $self->stderr_rewrite($self->{test}->{'stderr-replace'}, $line);
Dieter Baron8a3ea142014-05-09 11:55:31 +02001207 }
1208 push @{$self->{stderr}}, $line;
1209 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001210
Dieter Baron8a3ea142014-05-09 11:55:31 +02001211 waitpid($pid, 0);
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001212
Dieter Baron8a3ea142014-05-09 11:55:31 +02001213 $self->{exit_status} = $? >> 8;
1214}
1215
Dieter Baron8a3ea142014-05-09 11:55:31 +02001216sub sandbox_create {
1217 my ($self, $tag) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001218
Dieter Baron8a3ea142014-05-09 11:55:31 +02001219 $tag = ($tag ? "-$tag" : "");
1220 $self->{sandbox_dir} = "sandbox-$self->{testname}$tag.d$$";
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001221
Dieter Baron8a3ea142014-05-09 11:55:31 +02001222 $self->die("sandbox $self->{sandbox_dir} already exists") if (-e $self->{sandbox_dir});
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001223
Dieter Baron8a3ea142014-05-09 11:55:31 +02001224 mkdir($self->{sandbox_dir}) or $self->die("cannot create sandbox $self->{sandbox_dir}: $!");
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001225
Dieter Baron8a3ea142014-05-09 11:55:31 +02001226 return 1;
1227}
1228
1229
1230sub sandbox_enter {
1231 my ($self) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001232
Dieter Baron8a3ea142014-05-09 11:55:31 +02001233 $self->die("internal error: cannot enter sandbox before creating it") unless (defined($self->{sandbox_dir}));
1234
1235 return if ($self->{in_sandbox});
1236
Dieter Baronc1f7e002017-03-31 10:11:49 +02001237 chdir($self->{sandbox_dir}) or $self->die("cannot cd into sandbox $self->{sandbox_dir}: $!");
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001238
Dieter Baron8a3ea142014-05-09 11:55:31 +02001239 $self->{in_sandbox} = 1;
1240}
1241
1242
1243sub sandbox_leave {
1244 my ($self) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001245
Dieter Baron8a3ea142014-05-09 11:55:31 +02001246 return if (!$self->{in_sandbox});
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001247
Dieter Baron8a3ea142014-05-09 11:55:31 +02001248 chdir('..') or $self->die("cannot leave sandbox: $!");
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001249
Dieter Baron8a3ea142014-05-09 11:55:31 +02001250 $self->{in_sandbox} = 0;
1251}
1252
1253
1254sub sandbox_remove {
1255 my ($self) = @_;
1256
Thomas Klausnerea510d42015-09-15 13:54:15 +02001257 remove_tree($self->{sandbox_dir});
1258
Tomáš Malý6ad85d72019-10-07 14:24:26 +02001259 return 1;
Dieter Baron8a3ea142014-05-09 11:55:31 +02001260}
1261
1262
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001263sub strip_tags {
1264 my ($self, $tag, $lines) = @_;
1265
1266 my @stripped = ();
1267
1268 for my $line (@$lines) {
1269 if ($line =~ m/^<([a-zA-Z0-9_]*)> (.*)/) {
1270 if ($1 eq $tag) {
1271 push @stripped, $2;
1272 }
1273 }
1274 else {
1275 push @stripped, $line;
1276 }
1277 }
1278
1279 return \@stripped;
1280}
1281
1282
Dieter Baron8a3ea142014-05-09 11:55:31 +02001283sub touch_files {
1284 my ($self) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001285
Dieter Baron8a3ea142014-05-09 11:55:31 +02001286 my $ok = 1;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001287
Dieter Baron8a3ea142014-05-09 11:55:31 +02001288 if (defined($self->{test}->{touch})) {
1289 for my $args (@{$self->{test}->{touch}}) {
1290 my ($mtime, $fname) = @$args;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001291
Dieter Baron8a3ea142014-05-09 11:55:31 +02001292 if (!-f $fname) {
1293 my $fh;
1294 unless (open($fh, "> $fname") and close($fh)) {
1295 # TODO: error message
1296 $ok = 0;
1297 next;
1298 }
1299 }
1300 unless (utime($mtime, $mtime, $fname) == 1) {
1301 # TODO: error message
1302 $ok = 0;
1303 }
1304 }
1305 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001306
Dieter Baron8a3ea142014-05-09 11:55:31 +02001307 return $ok;
1308}
1309
1310
1311sub warn {
1312 my ($self, $msg) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001313
Dieter Baron8a3ea142014-05-09 11:55:31 +02001314 print STDERR "$0: $msg\n";
1315}
1316
1317
1318sub warn_file {
1319 my ($self, $msg) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001320
Dieter Baron8a3ea142014-05-09 11:55:31 +02001321 $self->warn("$self->{testcase_fname}: $msg");
1322}
1323
1324
1325sub warn_file_line {
1326 my ($self, $msg) = @_;
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001327
Dieter Baron8a3ea142014-05-09 11:55:31 +02001328 $self->warn("$self->{testcase_fname}:$.: $msg");
1329}
1330
1331sub stderr_rewrite {
Thomas Klausner276fef42014-12-02 14:43:01 +01001332 my ($self, $pattern, $line) = @_;
1333 for my $repl (@{$pattern}) {
1334 $line =~ s/$repl->[0]/$repl->[1]/;
1335 }
1336 return $line;
1337}
1338
1339
1340# MARK: array diff
1341
1342sub diff_arrays {
1343 my ($a, $b) = @_;
1344
1345 my ($i, $j);
1346 for ($i = $j = 0; $i < scalar(@$a) || $j < scalar(@$b);) {
1347 if ($i >= scalar(@$a)) {
1348 print "+$b->[$j]\n";
1349 $j++;
1350 }
1351 elsif ($j >= scalar(@$b)) {
1352 print "-$a->[$i]\n";
1353 $i++;
1354 }
1355 elsif ($a->[$i] eq $b->[$j]) {
1356 print " $a->[$i]\n";
1357 $i++;
1358 $j++;
1359 }
1360 else {
1361 my ($off_a, $off_b) = find_best_offsets($a, $i, $b, $j);
1362 my ($off_b_2, $off_a_2) = find_best_offsets($b, $j, $a, $i);
1363
1364 if ($off_a + $off_b > $off_a_2 + $off_b_2) {
1365 $off_a = $off_a_2;
1366 $off_b = $off_b_2;
1367 }
1368
1369 for (my $off = 0; $off < $off_a; $off++) {
1370 print "-$a->[$i]\n";
1371 $i++;
1372 }
1373 for (my $off = 0; $off < $off_b; $off++) {
1374 print "+$b->[$j]\n";
1375 $j++;
1376 }
1377 }
1378 }
1379
1380}
1381
1382sub find_best_offsets {
1383 my ($a, $i, $b, $j) = @_;
1384
1385 my ($best_a, $best_b);
1386
1387 for (my $off_a = 0; $off_a < (defined($best_a) ? $best_a + $best_b : scalar(@$a) - $i); $off_a++) {
1388 my $off_b = find_entry($a->[$i+$off_a], $b, $j, defined($best_a) ? $best_a + $best_b - $off_a : scalar(@$b) - $j);
1389
1390 next unless (defined($off_b));
1391
1392 if (!defined($best_a) || $best_a + $best_b > $off_a + $off_b) {
1393 $best_a = $off_a;
1394 $best_b = $off_b;
1395 }
1396 }
1397
1398 if (!defined($best_a)) {
1399 return (scalar(@$a) - $i, scalar(@$b) - $j);
1400 }
Thomas Klausnerbc6c7232017-08-14 15:26:22 +02001401
Thomas Klausner276fef42014-12-02 14:43:01 +01001402 return ($best_a, $best_b);
1403}
1404
1405sub find_entry {
1406 my ($entry, $array, $start, $max_offset) = @_;
1407
1408 for (my $offset = 0; $offset < $max_offset; $offset++) {
1409 return $offset if ($array->[$start + $offset] eq $entry);
1410 }
1411
1412 return undef;
Dieter Baron8a3ea142014-05-09 11:55:31 +02001413}
1414
14151;