"Fossies" - the Fresh Open Source Software Archive

Member "libzip-1.6.0/regress/NiHTest.pm" (24 Jan 2020, 31590 Bytes) of package /linux/misc/libzip-1.6.0.tar.xz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "NiHTest.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 1.5.2_vs_1.6.0.

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