regress/NiHTest.pm

   1 package NiHTest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd;
   7 use File::Copy;
   8 use File::Path qw(mkpath remove_tree);
   9 use Getopt::Long qw(:config posix_default bundling no_ignore_case);
  10 use IPC::Open3;
  11 use Symbol 'gensym';
  12 use UNIVERSAL;
  13
  14 use Data::Dumper qw(Dumper);
  15
  16 #  NiHTest -- package to run regression tests
  17 #  Copyright (C) 2002-2016 Dieter Baron and Thomas Klausner
  18 #
  19 #  This file is part of ckmame, a program to check rom sets for MAME.
  20 #  The authors can be contacted at <ckmame@nih.at>
  21 #
  22 #  Redistribution and use in source and binary forms, with or without
  23 #  modification, are permitted provided that the following conditions
  24 #  are met:
  25 #  1. Redistributions of source code must retain the above copyright
  26 #     notice, this list of conditions and the following disclaimer.
  27 #  2. Redistributions in binary form must reproduce the above copyright
  28 #     notice, this list of conditions and the following disclaimer in
  29 #     the documentation and/or other materials provided with the
  30 #     distribution.
  31 #  3. The names of the authors may not be used to endorse or promote
  32 #     products derived from this software without specific prior
  33 #     written permission.
  34 #
  35 #  THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
  36 #  OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  37 #  WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  38 #  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
  39 #  DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  40 #  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  41 #  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  42 #  INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
  43 #  IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  44 #  OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  45 #  IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  46
  47 # runtest TESTNAME
  48 #
  49 # files:
  50 #   TESTNAME.test: test scenario
  51 #
  52 # test scenario:
  53 #    Lines beginning with # are comments.
  54 #
  55 #    The following commands are recognized; return and args must
  56 #    appear exactly once, the others are optional.
  57 #
  58 #       args ARGS
  59 #           run program with command line arguments ARGS
  60 #
  61 #       description TEXT
  62 #           description of what test is for
  63 #
  64 #       features FEATURE ...
  65 #           only run test if all FEATUREs are present, otherwise skip it.
  66 #
  67 #       file TEST IN OUT
  68 #           copy file IN as TEST, compare against OUT after program run.
  69 #
  70 #       file-del TEST IN
  71 #           copy file IN as TEST, check that it is removed by program.
  72 #
  73 #       file-new TEST OUT
  74 #           check that file TEST is created by program and compare
  75 #           against OUT.
  76 #
  77 #       mkdir MODE NAME
  78 #           create directory NAME with permissions MODE.
  79 #
  80 #       pipein COMMAND ARGS ...
  81 #           pipe output of running COMMAND to program's stdin.
  82 #
  83 #       preload LIBRARY
  84 #           pre-load LIBRARY before running program.
  85 #
  86 #       program PRG
  87 #           run PRG instead of ckmame.
  88 #
  89 #       return RET
  90 #           RET is the expected exit code
  91 #
  92 #       setenv VAR VALUE
  93 #           set environment variable VAR to VALUE.
  94 #
  95 #       stderr TEXT
  96 #           program is expected to produce the error message TEXT.  If
  97 #           multiple stderr commands are used, the messages are
  98 #           expected in the order given.
  99 #
 100 #       stderr-replace REGEX REPLACEMENT
 101 #           run regex replacement over expected and got stderr output.
 102 #
 103 #       stdout TEXT
 104 #           program is expected to print TEXT to stdout.  If multiple
 105 #           stdout commands are used, the messages are expected in
 106 #           the order given.
 107 #
 108 #       touch MTIME FILE
 109 #           set last modified timestamp of FILE to MTIME (seconds since epoch).
 110 #           If FILE doesn't exist, an empty file is created.
 111 #
 112 #       ulimit C VALUE
 113 #           set ulimit -C to VALUE while running the program.
 114 #
 115 # exit status
 116 #       runtest uses the following exit codes:
 117 #           0: test passed
 118 #           1: test failed
 119 #           2: other error
 120 #          77: test was skipped
 121 #
 122 # environment variables:
 123 #   RUN_GDB: if set, run gdb on program in test environment
 124 #   KEEP_BROKEN: if set, don't delete test environment if test failed
 125 #   NO_CLEANUP: if set, don't delete test environment
 126 #   SETUP_ONLY: if set, exit after creating test environment
 127 #   VERBOSE: if set, be more verbose (e. g., output diffs)
 128
 129 my %EXIT_CODES = (
 130         PASS => 0,
 131         FAIL => 1,
 132         SKIP => 77,
 133         ERROR => 99
 134     );
 135
 136 sub new {
 137         my $class = UNIVERSAL::isa ($_[0], __PACKAGE__) ? shift : __PACKAGE__;
 138         my $self = bless {}, $class;
 139
 140         my ($opts) = @_;
 141
 142         $self->{default_program} = $opts->{default_program};
 143         $self->{zipcmp} = $opts->{zipcmp} // 'zipcmp';
 144         $self->{zipcmp_flags} = $opts->{zipcmp_flags};
 145
 146         $self->{directives} = {
 147                 args => { type => 'string...', once => 1, required => 1 },
 148                 description => { type => 'string', once => 1 },
 149                 features => { type => 'string...', once => 1 },
 150                 file => { type => 'string string string' },
 151                 'file-del' => { type => 'string string' },
 152                 'file-new' => { type => 'string string' },
 153                 mkdir => { type => 'string string' },
 154                 pipein => { type => 'string', once => 1 },
 155                 preload => { type => 'string', once => 1 },
 156                 program => { type => 'string', once => 1 },
 157                 'return' => { type => 'int', once => 1, required => 1 },
 158                 setenv => { type => 'string string' },
 159                 stderr => { type => 'string' },
 160                 'stderr-replace' => { type => 'string string' },
 161                 stdout => { type => 'string' },
 162                 touch => { type => 'int string' },
 163                 ulimit => { type => 'char string' }
 164         };
 165
 166         $self->{compare_by_type} = {};
 167         $self->{copy_by_type} = {};
 168         $self->{hooks} = {};
 169
 170         $self->add_comparator('zip/zip', \&comparator_zip);
 171
 172         $self->{srcdir} = $opts->{srcdir} // $ENV{srcdir};
 173
 174         if (!defined($self->{srcdir}) || $self->{srcdir} eq '') {
 175                 $self->{srcdir} = `sed -n 's/^srcdir = \(.*\)/\1/p' Makefile`;
 176                 chomp($self->{srcdir});
 177         }
 178
 179         $self->{in_sandbox} = 0;
 180
 181         $self->{verbose} = $ENV{VERBOSE};
 182         $self->{keep_broken} = $ENV{KEEP_BROKEN};
 183         $self->{no_cleanup} = $ENV{NO_CLEANUP};
 184         $self->{setup_only} = $ENV{SETUP_ONLY};
 185
 186         return $self;
 187 }
 188
 189
 190 sub add_comparator {
 191         my ($self, $ext, $sub) = @_;
 192
 193         return $self->add_file_proc('compare_by_type', $ext, $sub);
 194 }
 195
 196
 197 sub add_copier {
 198         my ($self, $ext, $sub) = @_;
 199
 200         return $self->add_file_proc('copy_by_type', $ext, $sub);
 201 }
 202
 203
 204 sub add_directive {
 205         my ($self, $name, $def) = @_;
 206
 207         if (exists($self->{directives}->{$name})) {
 208                 $self->die("directive $name already defined");
 209         }
 210
 211         # TODO: validate $def
 212
 213         $self->{directives}->{$name} = $def;
 214
 215         return 1;
 216 }
 217
 218
 219 sub add_file_proc {
 220         my ($self, $proc, $ext, $sub) = @_;
 221
 222         $self->{$proc}->{$ext} = [] unless (defined($self->{$proc}->{$ext}));
 223         unshift @{$self->{$proc}->{$ext}}, $sub;
 224
 225         return 1;
 226 }
 227
 228
 229 sub add_hook {
 230         my ($self, $hook, $sub) = @_;
 231
 232         $self->{hooks}->{$hook} = [] unless (defined($self->{hooks}->{$hook}));
 233         push @{$self->{hooks}->{$hook}}, $sub;
 234
 235         return 1;
 236 }
 237
 238
 239 sub end {
 240         my ($self, @results) = @_;
 241
 242         my $result = 'PASS';
 243
 244         for my $r (@results) {
 245                 if ($r eq 'ERROR' || ($r eq 'FAIL' && $result ne 'ERROR')) {
 246                         $result = $r;
 247                 }
 248         }
 249
 250         $self->end_test($result);
 251 }
 252
 253
 254 sub run {
 255         my ($self, @argv) = @_;
 256
 257         $self->setup(@argv);
 258
 259         $self->end($self->runtest());
 260 }
 261
 262
 263 sub runtest {
 264         my ($self, $tag) = @_;
 265
 266         $ENV{TZ} = "UTC";
 267         $ENV{LC_CTYPE} = "C";
 268         $self->sandbox_create($tag);
 269         $self->sandbox_enter();
 270
 271         my $ok = 1;
 272         $ok &= $self->copy_files();
 273         $ok &= $self->run_hook('post_copy_files');
 274         $ok &= $self->touch_files();
 275         $ok &= $self->run_hook('prepare_sandbox');
 276         return 'ERROR' unless ($ok);
 277
 278         if ($self->{setup_only}) {
 279                 $self->sandbox_leave();
 280                 return 'SKIP';
 281         }
 282
 283         for my $env (@{$self->{test}->{'setenv'}}) {
 284                 $ENV{$env->[0]} = $env->[1];
 285         }
 286         if (defined($self->{test}->{'preload'})) {
 287                 $ENV{LD_PRELOAD} = cwd() . "/../.libs/$self->{test}->{'preload'}";
 288         }
 289
 290         $self->run_program();
 291
 292         for my $env (@{$self->{test}->{'setenv'}}) {
 293                 delete ${ENV{$env->[0]}};
 294         }
 295         if (defined($self->{test}->{'preload'})) {
 296                 delete ${ENV{LD_PRELOAD}};
 297         }
 298
 299         if ($self->{test}->{stdout}) {
 300                 $self->{expected_stdout} = [ @{$self->{test}->{stdout}} ];
 301         }
 302         else {
 303                 $self->{expected_stdout} = [];
 304         }
 305         if ($self->{test}->{stderr}) {
 306                 $self->{expected_stderr} = [ @{$self->{test}->{stderr}} ];
 307         }
 308         else {
 309                 $self->{expected_stderr} = [];
 310         }
 311
 312         $self->run_hook('post_run_program');
 313
 314         my @failed = ();
 315
 316         if ($self->{exit_status} != ($self->{test}->{return} // 0)) {
 317                 push @failed, 'exit status';
 318                 if ($self->{verbose}) {
 319                         print "Unexpected exit status:\n";
 320                         print "-" . ($self->{test}->{return} // 0) . "\n+$self->{exit_status}\n";
 321                 }
 322         }
 323
 324         if (!$self->compare_arrays($self->{expected_stdout}, $self->{stdout}, 'output')) {
 325                 push @failed, 'output';
 326         }
 327         if (!$self->compare_arrays($self->{expected_stderr}, $self->{stderr}, 'error output')) {
 328                 push @failed, 'error output';
 329         }
 330         if (!$self->compare_files()) {
 331                 push @failed, 'files';
 332         }
 333
 334         $self->{failed} = \@failed;
 335
 336         $self->run_hook('checks');
 337
 338         my $result = scalar(@{$self->{failed}}) == 0 ? 'PASS' : 'FAIL';
 339
 340         $self->sandbox_leave();
 341         if (!($self->{no_cleanup} || ($self->{keep_broken} && $result eq 'FAIL'))) {
 342                 $self->sandbox_remove();
 343         }
 344
 345         $self->print_test_result($tag, $result, join ', ', @{$self->{failed}});
 346
 347         return $result;
 348 }
 349
 350
 351 sub setup {
 352         my ($self, @argv) = @_;
 353
 354         my @save_argv = @ARGV;
 355         @ARGV = @argv;
 356         my $ok = GetOptions(
 357                 'help|h' => \my $help,
 358                 'keep-broken' => \$self->{keep_broken},
 359                 'no-cleanup' => \$self->{no_cleanup},
 360                 # 'run-gdb' => \$self->{run_gdb},
 361                 'setup-only' => \$self->{setup_only},
 362                 'verbose|v' => \$self->{verbose}
 363         );
 364         @argv = @ARGV;
 365         @ARGV = @save_argv;
 366
 367         if (!$ok || scalar(@argv) != 1 || $help) {
 368                 print STDERR "Usage: $0 [-hv] [--keep-broken] [--no-cleanup] [--setup-only] testcase\n";
 369                 exit(1);
 370         }
 371
 372         my $testcase = shift @argv;
 373
 374         $testcase .= '.test' unless ($testcase =~ m/\.test$/);
 375
 376         my $testcase_file = $self->find_file($testcase);
 377
 378         $self->die("cannot find test case $testcase") unless ($testcase_file);
 379
 380         $testcase =~ s,^(?:.*/)?([^/]*)\.test$,$1,;
 381         $self->{testname} = $testcase;
 382
 383         $self->die("error in test case definition") unless $self->parse_case($testcase_file);
 384
 385         $self->check_features_requirement() if ($self->{test}->{features});
 386
 387         $self->end_test('SKIP') if ($self->{test}->{preload} && $^O eq 'darwin');
 388 }
 389
 390
 391 #
 392 # internal methods
 393 #
 394
 395 sub add_file {
 396         my ($self, $file) = @_;
 397
 398         if (defined($self->{files}->{$file->{destination}})) {
 399                 $self->warn("duplicate specification for input file $file->{destination}");
 400                 return undef;
 401         }
 402
 403         $self->{files}->{$file->{destination}} = $file;
 404
 405         return 1;
 406 }
 407
 408
 409 sub check_features_requirement() {
 410         my ($self) = @_;
 411
 412         ### TODO: implement
 413
 414         return 1;
 415 }
 416
 417
 418 sub comparator_zip {
 419         my ($self, $got, $expected) = @_;
 420
 421         my @args = ($self->{zipcmp}, $self->{verbose} ? '-pv' : '-pq');
 422         push @args, $self->{zipcmp_flags} if ($self->{zipcmp_flags});
 423         push @args, ($expected, $got);
 424
 425         my $ret = system(@args);
 426
 427         return $ret == 0;
 428 }
 429
 430
 431 sub compare_arrays() {
 432         my ($self, $a, $b, $tag) = @_;
 433
 434         my $ok = 1;
 435
 436         if (scalar(@$a) != scalar(@$b)) {
 437                 $ok = 0;
 438         }
 439         else {
 440                 for (my $i = 0; $i < scalar(@$a); $i++) {
 441                         if ($a->[$i] ne $b->[$i]) {
 442                                 $ok = 0;
 443                                 last;
 444                         }
 445                 }
 446         }
 447
 448         if (!$ok && $self->{verbose}) {
 449                 print "Unexpected $tag:\n";
 450                 print "--- expected\n+++ got\n";
 451
 452                 diff_arrays($a, $b);
 453         }
 454
 455         return $ok;
 456 }
 457
 458 sub file_cmp($$) {
 459         my ($a, $b) = @_;
 460         my $result = 0;
 461         open my $fha, "< $a";
 462         open my $fhb, "< $b";
 463         binmode $fha;
 464         binmode $fhb;
 465         BYTE: while (!eof $fha && !eof $fhb) {
 466                 if (getc $fha ne getc $fhb) {
 467                         $result = 1;
 468                         last BYTE;
 469                 }
 470         }
 471         $result = 1 if eof $fha != eof $fhb;
 472         close $fha;
 473         close $fhb;
 474         return $result;
 475 }
 476
 477 sub compare_file($$$) {
 478         my ($self, $got, $expected) = @_;
 479
 480         my $real_expected = $self->find_file($expected);
 481         unless ($real_expected) {
 482                 $self->warn("cannot find expected result file $expected");
 483                 return 0;
 484         }
 485
 486         my $ok = $self->run_comparator($got, $real_expected);
 487
 488         if (!defined($ok)) {
 489                 my $ret;
 490                 if ($self->{verbose}) {
 491                         $ret = system('diff', '-u', $real_expected, $got);
 492                 }
 493                 else {
 494                         $ret = file_cmp($real_expected, $got);
 495                 }
 496                 $ok = ($ret == 0);
 497         }
 498
 499         return $ok;
 500 }
 501
 502
 503 sub compare_files() {
 504         my ($self) = @_;
 505
 506         my $ok = 1;
 507
 508         opendir(my $ls, '.');
 509         unless ($ls) {
 510                 # TODO: handle error
 511         }
 512         my @files_got = grep { -f } readdir($ls);
 513         closedir($ls);
 514
 515         @files_got = sort @files_got;
 516         my @files_should = ();
 517
 518         for my $file (sort keys %{$self->{files}}) {
 519                 push @files_should, $file if ($self->{files}->{$file}->{result} || $self->{files}->{$file}->{ignore});
 520         }
 521
 522         $self->{files_got} = \@files_got;
 523         $self->{files_should} = \@files_should;
 524
 525         unless ($self->run_hook('post_list_files')) {
 526                 return 0;
 527         }
 528
 529         $ok = $self->compare_arrays($self->{files_should}, $self->{files_got}, 'files');
 530
 531         for my $file (@{$self->{files_got}}) {
 532                 my $file_def = $self->{files}->{$file};
 533                 next unless ($file_def && $file_def->{result});
 534
 535                 $ok &= $self->compare_file($file, $file_def->{result});
 536         }
 537
 538         return $ok;
 539 }
 540
 541
 542 sub copy_files {
 543         my ($self) = @_;
 544
 545         my $ok = 1;
 546
 547         for my $filename (sort keys %{$self->{files}}) {
 548                 my $file = $self->{files}->{$filename};
 549                 next unless ($file->{source});
 550
 551                 my $src = $self->find_file($file->{source});
 552                 unless ($src) {
 553                         $self->warn("cannot find input file $file->{source}");
 554                         $ok = 0;
 555                         next;
 556                 }
 557
 558                 if ($file->{destination} =~ m,/,) {
 559                         my $dir = $file->{destination};
 560                         $dir =~ s,/[^/]*$,,;
 561                         if (! -d $dir) {
 562                                 mkpath($dir);
 563                         }
 564                 }
 565
 566                 my $this_ok = $self->run_copier($src, $file->{destination});
 567                 if (defined($this_ok)) {
 568                         $ok &= $this_ok;
 569                 }
 570                 else {
 571                         unless (copy($src, $file->{destination})) {
 572                                 $self->warn("cannot copy $src to $file->{destination}: $!");
 573                                 $ok = 0;
 574                         }
 575                 }
 576         }
 577
 578         if (defined($self->{test}->{mkdir})) {
 579                 for my $dir_spec (@{$self->{test}->{mkdir}}) {
 580                         my ($mode, $dir) = @$dir_spec;
 581                         if (! -d $dir) {
 582                                 unless (mkdir($dir, oct($mode))) {
 583                                         $self->warn("cannot create directory $dir: $!");
 584                                         $ok = 0;
 585                                 }
 586                         }
 587                 }
 588         }
 589
 590         $self->die("failed to copy input files") unless ($ok);
 591 }
 592
 593
 594 sub die() {
 595         my ($self, $msg) = @_;
 596
 597         print STDERR "$0: $msg\n" if ($msg);
 598
 599         $self->end_test('ERROR');
 600 }
 601
 602
 603 sub end_test {
 604         my ($self, $status) = @_;
 605
 606         my $exit_code = $EXIT_CODES{$status} // $EXIT_CODES{ERROR};
 607
 608         $self->exit($exit_code);
 609 }
 610
 611
 612
 613 sub exit() {
 614         my ($self, $status) = @_;
 615         ### TODO: cleanup
 616
 617         exit($status);
 618 }
 619
 620
 621 sub find_file() {
 622         my ($self, $fname) = @_;
 623
 624         for my $dir (('', "$self->{srcdir}/")) {
 625                 my $f = "$dir$fname";
 626                 $f = "../$f" if ($self->{in_sandbox} && $dir !~ m,^/,);
 627
 628                 return $f if (-f $f);
 629         }
 630
 631         return undef;
 632 }
 633
 634
 635 sub get_extension {
 636         my ($self, $fname) = @_;
 637
 638         my $ext = $fname;
 639         if ($ext =~ m/\./) {
 640                 $ext =~ s/.*\.//;
 641         }
 642         else {
 643                 $ext = '';
 644         }
 645
 646         return $ext;
 647 }
 648
 649
 650 sub parse_args {
 651         my ($self, $type, $str) = @_;
 652
 653         if ($type eq 'string...') {
 654                 my $args = [];
 655
 656                 while ($str ne '') {
 657                         if ($str =~ m/^\"/) {
 658                                 unless ($str =~ m/^\"([^\"]*)\"\s*(.*)/) {
 659                                         $self->warn_file_line("unclosed quote in [$str]");
 660                                         return undef;
 661                                 }
 662                                 push @$args, $1;
 663                                 $str = $2;
 664                         }
 665                         else {
 666                                 $str =~ m/^(\S+)\s*(.*)/;
 667                                 push @$args, $1;
 668                                 $str = $2;
 669                         }
 670                 }
 671
 672                 return $args;
 673         }
 674         elsif ($type =~ m/(\s|\.\.\.$)/) {
 675                 my $ellipsis = 0;
 676                 if ($type =~ m/(.*)\.\.\.$/) {
 677                         $ellipsis = 1;
 678                         $type = $1;
 679                 }
 680                 my @types = split /\s+/, $type;
 681                 my @strs = split /\s+/, $str;
 682                 my $optional = 0;
 683                 for (my $i = scalar(@types) - 1; $i >= 0; $i--) {
 684                         last unless ($types[$i] =~ m/(.*)\?$/);
 685                         $types[$i] = $1;
 686                         $optional++;
 687                 }
 688
 689                 if ($ellipsis && $optional > 0) {
 690                         # TODO: check this when registering a directive
 691                         $self->warn_file_line("can't use ellipsis together with optional arguments");
 692                         return undef;
 693                 }
 694                 if (!$ellipsis && (scalar(@strs) < scalar(@types) - $optional || scalar(@strs) > scalar(@types))) {
 695                         my $expected = scalar(@types);
 696                         if ($optional > 0) {
 697                                 $expected = ($expected - $optional) . "-$expected";
 698                         }
 699                         $self->warn_file_line("expected $expected arguments, got " . (scalar(@strs)));
 700                         return undef;
 701                 }
 702
 703                 my $args = [];
 704
 705                 my $n = scalar(@types);
 706                 for (my $i=0; $i<scalar(@strs); $i++) {
 707                         my $val = $self->parse_args(($i >= $n ? $types[$n-1] : $types[$i]), $strs[$i]);
 708                         return undef unless (defined($val));
 709                         push @$args, $val;
 710                 }
 711
 712                 return $args;
 713         }
 714         else {
 715                 if ($type eq 'string') {
 716                         return $str;
 717                 }
 718                 elsif ($type eq 'int') {
 719                         if ($str !~ m/^\d+$/) {
 720                                 $self->warn_file_line("illegal int [$str]");
 721                                 return undef;
 722                         }
 723                         return $str+0;
 724                 }
 725                 elsif ($type eq 'char') {
 726                         if ($str !~ m/^.$/) {
 727                                 $self->warn_file_line("illegal char [$str]");
 728                                 return undef;
 729                         }
 730                         return $str;
 731                 }
 732                 else {
 733                         $self->warn_file_line("unknown type $type");
 734                         return undef;
 735                 }
 736         }
 737 }
 738
 739
 740 sub parse_case() {
 741         my ($self, $fname) = @_;
 742
 743         my $ok = 1;
 744
 745         open TST, "< $fname" or $self->die("cannot open test case $fname: $!");
 746
 747         $self->{testcase_fname} = $fname;
 748
 749         my %test = ();
 750
 751         while (my $line = <TST>) {
 752                 chomp $line;
 753
 754                 next if ($line =~ m/^\#/);
 755
 756                 unless ($line =~ m/(\S*)(?:\s(.*))?/) {
 757                         $self->warn_file_line("cannot parse line $line");
 758                         $ok = 0;
 759                         next;
 760                 }
 761                 my ($cmd, $argstring) = ($1, $2//"");
 762
 763                 my $def = $self->{directives}->{$cmd};
 764
 765                 unless ($def) {
 766                         $self->warn_file_line("unknown directive $cmd in test file");
 767                         $ok = 0;
 768                         next;
 769                 }
 770
 771                 my $args = $self->parse_args($def->{type}, $argstring);
 772
 773                 unless (defined($args)) {
 774                         $ok = 0;
 775                         next;
 776                 }
 777
 778                 if ($def->{once}) {
 779                         if (defined($test{$cmd})) {
 780                                 $self->warn_file_line("directive $cmd appeared twice in test file");
 781                         }
 782                         $test{$cmd} = $args;
 783                 }
 784                 else {
 785                         $test{$cmd} = [] unless (defined($test{$cmd}));
 786                         push @{$test{$cmd}}, $args;
 787                 }
 788         }
 789
 790         close TST;
 791
 792         return undef unless ($ok);
 793
 794         for my $cmd (sort keys %test) {
 795                 if ($self->{directives}->{$cmd}->{required} && !defined($test{$cmd})) {
 796                         $self->warn_file("required directive $cmd missing in test file");
 797                         $ok = 0;
 798                 }
 799         }
 800
 801         return undef unless ($ok);
 802
 803         if (defined($test{'stderr-replace'}) && defined($test{stderr})) {
 804                 $test{stderr} = [ map { $self->stderr_rewrite($test{'stderr-replace'}, $_); } @{$test{stderr}} ];
 805         }
 806
 807         if (!defined($test{program})) {
 808                 $test{program} = $self->{default_program};
 809         }
 810
 811         $self->{test} = \%test;
 812
 813         $self->run_hook('mangle_program');
 814
 815         if (!$self->parse_postprocess_files()) {
 816                 return 0;
 817         }
 818
 819         return $self->run_hook('post_parse');
 820 }
 821
 822
 823 sub parse_postprocess_files {
 824         my ($self) = @_;
 825
 826         $self->{files} = {};
 827
 828         my $ok = 1;
 829
 830         for my $file (@{$self->{test}->{file}}) {
 831                 $ok = 0 unless ($self->add_file({ source => $file->[1], destination => $file->[0], result => $file->[2] }));
 832         }
 833
 834         for my $file (@{$self->{test}->{'file-del'}}) {
 835                 $ok = 0 unless ($self->add_file({ source => $file->[1], destination => $file->[0], result => undef }));
 836         }
 837
 838         for my $file (@{$self->{test}->{'file-new'}}) {
 839                 $ok = 0 unless ($self->add_file({ source => undef, destination => $file->[0], result => $file->[1] }));
 840         }
 841
 842         return $ok;
 843 }
 844
 845
 846 sub print_test_result {
 847         my ($self, $tag, $result, $reason) = @_;
 848
 849         if ($self->{verbose}) {
 850                 print "$self->{testname}";
 851                 print " ($tag)" if ($tag);
 852                 print " -- $result";
 853                 print ": $reason" if ($reason);
 854                 print "\n";
 855         }
 856 }
 857
 858
 859 sub run_comparator {
 860         my ($self, $got, $expected) = @_;
 861
 862         return $self->run_file_proc('compare_by_type', $got, $expected);
 863 }
 864
 865
 866 sub run_copier {
 867         my ($self, $src, $dest) = @_;
 868
 869         return $self->run_file_proc('copy_by_type', $src, $dest);
 870 }
 871
 872
 873 sub run_file_proc {
 874         my ($self, $proc, $got, $expected) = @_;
 875
 876         my $ext = ($self->get_extension($got)) . '/' . ($self->get_extension($expected));
 877
 878         if (defined($self->{$proc}->{$ext})) {
 879                 for my $sub (@{$self->{$proc}->{$ext}}) {
 880                         my $ret = $sub->($self, $got, $expected);
 881                         return $ret if (defined($ret));
 882                 }
 883         }
 884
 885         return undef;
 886 }
 887
 888
 889 sub run_hook {
 890         my ($self, $hook) = @_;
 891
 892         my $ok = 1;
 893
 894         if (defined($self->{hooks}->{$hook})) {
 895                 for my $sub (@{$self->{hooks}->{$hook}}) {
 896                         unless ($sub->($self, $hook)) {
 897                                 $self->warn("hook $hook failed");
 898                                 $ok = 0;
 899                         }
 900                 }
 901         }
 902
 903         return $ok;
 904 }
 905 sub args_decode {
 906
 907
 908         my ($str, $srcdir) = @_;
 909
 910         if ($str =~ m/\\/) {
 911                 $str =~ s/\\a/\a/gi;
 912                 $str =~ s/\\b/\b/gi;
 913                 $str =~ s/\\f/\f/gi;
 914                 $str =~ s/\\n/\n/gi;
 915                 $str =~ s/\\r/\r/gi;
 916                 $str =~ s/\\t/\t/gi;
 917                 $str =~ s/\\v/\cK/gi;
 918                 $str =~ s/\\s/ /gi;
 919                 # TODO: \xhh, \ooo
 920                 $str =~ s/\\(.)/$1/g;
 921         }
 922
 923         if ($srcdir !~ m,^/,) {
 924                 $srcdir = "../$srcdir";
 925         }
 926
 927         if ($str =~ m/^\$srcdir(.*)/) {
 928                 $str = "$srcdir$1";
 929         }
 930
 931         return $str;
 932 }
 933
 934
 935 sub run_program {
 936         my ($self) = @_;
 937         goto &pipein_win32 if $^O eq 'MSWin32' && $self->{test}->{pipein};
 938         my ($stdin, $stdout, $stderr);
 939         $stderr = gensym;
 940
 941         my @cmd = ('../' . $self->{test}->{program}, map ({ args_decode($_, $self->{srcdir}); } @{$self->{test}->{args}}));
 942
 943         ### TODO: catch errors?
 944
 945         my $pid = open3($stdin, $stdout, $stderr, @cmd);
 946
 947         $self->{stdout} = [];
 948         $self->{stderr} = [];
 949
 950         if ($self->{test}->{pipein}) {
 951                 my $fh;
 952                 open($fh, "$self->{test}->{pipein} |");
 953                 if (!defined($fh)) {
 954                         $self->die("cannot run pipein command [$self->{test}->{pipein}: $!");
 955                 }
 956                 while (my $line = <$fh>) {
 957                         print $stdin $line;
 958                 }
 959                 close($fh);
 960                 close($stdin);
 961         }
 962
 963         while (my $line = <$stdout>) {
 964                 if ($^O eq 'MSWin32') {
 965                         $line =~ s/[\r\n]+$//;
 966                 }
 967                 else {
 968                         chomp $line;
 969                 }
 970                 push @{$self->{stdout}}, $line;
 971         }
 972         my $prg = $self->{test}->{program};
 973         $prg =~ s,.*/,,;
 974         while (my $line = <$stderr>) {
 975                 if ($^O eq 'MSWin32') {
 976                         $line =~ s/[\r\n]+$//;
 977                 }
 978                 else {
 979                         chomp $line;
 980                 }
 981
 982                 $line =~ s/^[^: ]*$prg: //;
 983                 if (defined($self->{test}->{'stderr-replace'})) {
 984                         $line = $self->stderr_rewrite($self->{test}->{'stderr-replace'}, $line);
 985                 }
 986                 push @{$self->{stderr}}, $line;
 987         }
 988
 989         waitpid($pid, 0);
 990
 991         $self->{exit_status} = $? >> 8;
 992 }
 993
 994 sub pipein_win32() {
 995         my ($self) = @_;
 996
 997         my $cmd = "$self->{test}->{pipein}| ..\\$self->{test}->{program} " . join(' ', map ({ args_decode($_, $self->{srcdir}); } @{$self->{test}->{args}}));
 998         my ($success, $error_message, $full_buf, $stdout_buf, $stderr_buf) = IPC::Cmd::run(command => $cmd);
 999         if (!$success) {
1000                 ### TODO: catch errors?
1001         }
1002
1003         my @stdout = map { s/[\r\n]+$// } @$stdout_buf;
1004         $self->{stdout} = \@stdout;
1005         $self->{stderr} = [];
1006
1007         my $prg = $self->{test}->{program};
1008         $prg =~ s,.*/,,;
1009         foreach my $line (@$stderr_buf) {
1010                 $line =~ s/[\r\n]+$//;
1011
1012                 $line =~ s/^[^: ]*$prg: //;
1013                 if (defined($self->{test}->{'stderr-replace'})) {
1014                         $line = $self->stderr_rewrite($self->{test}->{'stderr-replace'}, $line);
1015                 }
1016                 push @{$self->{stderr}}, $line;
1017         }
1018
1019         $self->{exit_status} = 1;
1020         if ($success) {
1021                 $self->{exit_status} = 0;
1022         }
1023         elsif ($error_message =~ /exited with value ([0-9]+)$/) {
1024                 $self->{exit_status} = $1 + 0;
1025         }
1026 }
1027
1028 sub sandbox_create {
1029         my ($self, $tag) = @_;
1030
1031         $tag = ($tag ? "-$tag" : "");
1032         $self->{sandbox_dir} = "sandbox-$self->{testname}$tag.d$$";
1033
1034         $self->die("sandbox $self->{sandbox_dir} already exists") if (-e $self->{sandbox_dir});
1035
1036         mkdir($self->{sandbox_dir}) or $self->die("cannot create sandbox $self->{sandbox_dir}: $!");
1037
1038         return 1;
1039 }
1040
1041
1042 sub sandbox_enter {
1043         my ($self) = @_;
1044
1045         $self->die("internal error: cannot enter sandbox before creating it") unless (defined($self->{sandbox_dir}));
1046
1047         return if ($self->{in_sandbox});
1048
1049         chdir($self->{sandbox_dir}) or $self->die("cant cd into sandbox $self->{sandbox_dir}: $!");
1050
1051         $self->{in_sandbox} = 1;
1052 }
1053
1054
1055 sub sandbox_leave {
1056         my ($self) = @_;
1057
1058         return if (!$self->{in_sandbox});
1059
1060         chdir('..') or $self->die("cannot leave sandbox: $!");
1061
1062         $self->{in_sandbox} = 0;
1063 }
1064
1065
1066 sub sandbox_remove {
1067         my ($self) = @_;
1068
1069         my $ok = 1;
1070         remove_tree($self->{sandbox_dir});
1071
1072         return $ok;
1073 }
1074
1075
1076 sub touch_files {
1077         my ($self) = @_;
1078
1079         my $ok = 1;
1080
1081         if (defined($self->{test}->{touch})) {
1082                 for my $args (@{$self->{test}->{touch}}) {
1083                         my ($mtime, $fname) = @$args;
1084
1085                         if (!-f $fname) {
1086                                 my $fh;
1087                                 unless (open($fh, "> $fname") and close($fh)) {
1088                                         # TODO: error message
1089                                         $ok = 0;
1090                                         next;
1091                                 }
1092                         }
1093                         unless (utime($mtime, $mtime, $fname) == 1) {
1094                                 # TODO: error message
1095                                 $ok = 0;
1096                         }
1097                 }
1098         }
1099
1100         return $ok;
1101 }
1102
1103
1104 sub warn {
1105         my ($self, $msg) = @_;
1106
1107         print STDERR "$0: $msg\n";
1108 }
1109
1110
1111 sub warn_file {
1112         my ($self, $msg) = @_;
1113
1114         $self->warn("$self->{testcase_fname}: $msg");
1115 }
1116
1117
1118 sub warn_file_line {
1119         my ($self, $msg) = @_;
1120
1121         $self->warn("$self->{testcase_fname}:$.: $msg");
1122 }
1123
1124 sub stderr_rewrite {
1125         my ($self, $pattern, $line) = @_;
1126         for my $repl (@{$pattern}) {
1127                 $line =~ s/$repl->[0]/$repl->[1]/;
1128         }
1129         return $line;
1130 }
1131
1132
1133 # MARK: array diff
1134
1135 sub diff_arrays {
1136         my ($a, $b) = @_;
1137
1138         my ($i, $j);
1139         for ($i = $j = 0; $i < scalar(@$a) || $j < scalar(@$b);) {
1140                 if ($i >= scalar(@$a)) {
1141                         print "+$b->[$j]\n";
1142                         $j++;
1143                 }
1144                 elsif ($j >= scalar(@$b)) {
1145                         print "-$a->[$i]\n";
1146                         $i++;
1147                 }
1148                 elsif ($a->[$i] eq $b->[$j]) {
1149                         print " $a->[$i]\n";
1150                         $i++;
1151                         $j++;
1152                 }
1153                 else {
1154                         my ($off_a, $off_b) = find_best_offsets($a, $i, $b, $j);
1155                         my ($off_b_2, $off_a_2) = find_best_offsets($b, $j, $a, $i);
1156
1157                         if ($off_a + $off_b > $off_a_2 + $off_b_2) {
1158                                 $off_a = $off_a_2;
1159                                 $off_b = $off_b_2;
1160                         }
1161
1162                         for (my $off = 0; $off < $off_a; $off++) {
1163                                 print "-$a->[$i]\n";
1164                                 $i++;
1165                         }
1166                         for (my $off = 0; $off < $off_b; $off++) {
1167                                 print "+$b->[$j]\n";
1168                                 $j++;
1169                         }
1170                 }
1171         }
1172
1173 }
1174
1175 sub find_best_offsets {
1176         my ($a, $i, $b, $j) = @_;
1177
1178         my ($best_a, $best_b);
1179
1180         for (my $off_a = 0; $off_a < (defined($best_a) ? $best_a + $best_b : scalar(@$a) - $i); $off_a++) {
1181                 my $off_b = find_entry($a->[$i+$off_a], $b, $j, defined($best_a) ? $best_a + $best_b - $off_a : scalar(@$b) - $j);
1182
1183                 next unless (defined($off_b));
1184
1185                 if (!defined($best_a) || $best_a + $best_b > $off_a + $off_b) {
1186                         $best_a = $off_a;
1187                         $best_b = $off_b;
1188                 }
1189         }
1190
1191         if (!defined($best_a)) {
1192                 return (scalar(@$a) - $i, scalar(@$b) - $j);
1193         }
1194
1195         return ($best_a, $best_b);
1196 }
1197
1198 sub find_entry {
1199         my ($entry, $array, $start, $max_offset) = @_;
1200
1201         for (my $offset = 0; $offset < $max_offset; $offset++) {
1202                 return $offset if ($array->[$start + $offset] eq $entry);
1203         }
1204
1205         return undef;
1206 }
1207
1208 1;