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