package NiHTest;
use strict;
use warnings;
use Cwd;
use File::Copy;
use File::Path qw(mkpath remove_tree);
use Getopt::Long qw(:config posix_default bundling no_ignore_case);
use IPC::Open3;
#use IPC::Cmd qw(run);
use Storable qw(dclone);
use Symbol 'gensym';
use UNIVERSAL;
#use Data::Dumper qw(Dumper);
# NiHTest -- package to run regression tests
# Copyright (C) 2002-2016 Dieter Baron and Thomas Klausner
#
# This file is part of ckmame, a program to check rom sets for MAME.
# The authors can be contacted at <[email protected]>
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in
# the documentation and/or other materials provided with the
# distribution.
# 3. The names of the authors may not be used to endorse or promote
# products derived from this software without specific prior
# written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
# GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
# IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
# IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
# runtest TESTNAME
#
# files:
# TESTNAME.test: test scenario
#
# test scenario:
# Lines beginning with # are comments.
#
# The following commands are recognized; return and args must
# appear exactly once, the others are optional.
#
# args ARGS
# run program with command line arguments ARGS
#
# description TEXT
# description of what test is for
#
# features FEATURE ...
# only run test if all FEATUREs are present, otherwise skip it.
#
# file TEST IN OUT
# copy file IN as TEST, compare against OUT after program run.
#
# file-del TEST IN
# copy file IN as TEST, check that it is removed by program.
#
# file-new TEST OUT
# check that file TEST is created by program and compare
# against OUT.
#
# mkdir MODE NAME
# create directory NAME with permissions MODE.
#
# precheck COMMAND ARGS ...
# if COMMAND exits with non-zero status, skip test.
#
# preload LIBRARY
# pre-load LIBRARY before running program.
#
# program PRG
# run PRG instead of ckmame.
#
# return RET
# RET is the expected exit code
#
# setenv VAR VALUE
# set environment variable VAR to VALUE.
#
# stderr TEXT
# program is expected to produce the error message TEXT. If
# multiple stderr commands are used, the messages are
# expected in the order given.
#
# stderr-replace REGEX REPLACEMENT
# run regex replacement over expected and got stderr output.
#
# stdin TEST
# Provide TEXT to program's stdin.
#
# stdin-file FILE
# pipe FILE to program's stdin.
#
# stdout TEXT
# program is expected to print TEXT to stdout. If multiple
# stdout commands are used, the messages are expected in
# the order given.
#
# touch MTIME FILE
# set last modified timestamp of FILE to MTIME (seconds since epoch).
# If FILE doesn't exist, an empty file is created.
#
# ulimit C VALUE
# set ulimit -C to VALUE while running the program.
#
# exit status
# runtest uses the following exit codes:
# 0: test passed
# 1: test failed
# 2: other error
# 77: test was skipped
#
# environment variables:
# RUN_GDB: if set, run gdb on program in test environment
# KEEP_BROKEN: if set, don't delete test environment if test failed
# NO_CLEANUP: if set, don't delete test environment
# SETUP_ONLY: if set, exit after creating test environment
# VERBOSE: if set, be more verbose (e. g., output diffs)
my %EXIT_CODES = (
PASS => 0,
FAIL => 1,
SKIP => 77,
ERROR => 99
);
# MARK: - Public API
sub new {
my $class = UNIVERSAL::isa ($_[0], __PACKAGE__) ? shift : __PACKAGE__;
my $self = bless {}, $class;
my ($opts) = @_;
$self->{default_program} = $opts->{default_program};
$self->{zipcmp} = $opts->{zipcmp} // 'zipcmp';
$self->{zipcmp_flags} = $opts->{zipcmp_flags} // '-p';
$self->{directives} = {
args => { type => 'string...', once => 1, required => 1 },
description => { type => 'string', once => 1 },
features => { type => 'string...', once => 1 },
file => { type => 'string string string' },
'file-del' => { type => 'string string' },
'file-new' => { type => 'string string' },
mkdir => { type => 'string string' },
precheck => { type => 'string...' },
preload => { type => 'string', once => 1 },
program => { type => 'string', once => 1 },
'return' => { type => 'int', once => 1, required => 1 },
setenv => { type => 'string string' },
stderr => { type => 'string' },
'stderr-replace' => { type => 'string string' },
stdin => { type => 'string' },
'stdin-file' => { type => 'string', once => 1 },
stdout => { type => 'string' },
touch => { type => 'int string' },
ulimit => { type => 'char string' }
};
$self->{compare_by_type} = {};
$self->{copy_by_type} = {};
$self->{hooks} = {};
$self->get_variable('srcdir', $opts);
$self->get_variable('top_builddir', $opts);
$self->{in_sandbox} = 0;
$self->{verbose} = $ENV{VERBOSE};
$self->{keep_broken} = $ENV{KEEP_BROKEN};
$self->{no_cleanup} = $ENV{NO_CLEANUP};
$self->{setup_only} = $ENV{SETUP_ONLY};
return $self;
}
sub add_comparator {
my ($self, $ext, $sub) = @_;
return $self->add_file_proc('compare_by_type', $ext, $sub);
}
sub add_copier {
my ($self, $ext, $sub) = @_;
return $self->add_file_proc('copy_by_type', $ext, $sub);
}
sub add_directive {
my ($self, $name, $def) = @_;
if (exists($self->{directives}->{$name})) {
$self->die("directive $name already defined");
}
# TODO: validate $def
$self->{directives}->{$name} = $def;
return 1;
}
sub add_file_proc {
my ($self, $proc, $ext, $sub) = @_;
$self->{$proc}->{$ext} = [] unless (defined($self->{$proc}->{$ext}));
unshift @{$self->{$proc}->{$ext}}, $sub;
return 1;
}
sub add_hook {
my ($self, $hook, $sub) = @_;
$self->{hooks}->{$hook} = [] unless (defined($self->{hooks}->{$hook}));
push @{$self->{hooks}->{$hook}}, $sub;
return 1;
}
sub add_variant {
my ($self, $name, $hooks) = @_;
if (!defined($self->{variants})) {
$self->{variants} = [];
$self->add_directive('variants' => { type => 'string...', once => 1 });
}
for my $variant (@{$self->{variants}}) {
if ($variant->{name} eq $name) {
$self->die("variant $name already defined");
}
}
push @{$self->{variants}}, { name => $name, hooks => $hooks };
return 1;
}
sub end {
my ($self, @results) = @_;
my $result = 'PASS';
for my $r (@results) {
if ($r eq 'ERROR' || ($r eq 'FAIL' && $result ne 'ERROR')) {
$result = $r;
}
}
$self->end_test($result);
}
sub run {
my ($self, @argv) = @_;
$self->setup(@argv);
$self->end($self->runtest());
}
sub runtest {
my ($self) = @_;
if (defined($self->{variants})) {
my @results = ();
$self->{original_test} = $self->{test};
my %variants;
if (defined($self->{test}->{variants})) {
%variants = map { $_ => 1; } @{$self->{test}->{variants}};
}
for my $variant (@{$self->{variants}}) {
next if (defined($self->{test}->{variants}) && !exists($variants{$variant->{name}}));
$self->{variant_hooks} = $variant->{hooks};
$self->{test} = dclone($self->{original_test});
$self->{variant} = $variant->{name};
$self->mangle_test_for_variant();
push @results, $self->runtest_one($variant->{name});
}
return @results;
}
else {
return $self->runtest_one();
}
}
sub runtest_one {
my ($self, $tag) = @_;
$ENV{TZ} = "UTC";
$ENV{LC_CTYPE} = "C";
$ENV{POSIXLY_CORRECT} = 1;
$self->sandbox_create($tag);
$self->sandbox_enter();
my $ok = 1;
$ok &= $self->copy_files();
$ok &= $self->run_hook('post_copy_files');
$ok &= $self->touch_files();
$ok &= $self->run_hook('prepare_sandbox');
return 'ERROR' unless ($ok);
if ($self->{setup_only}) {
$self->sandbox_leave();
return 'SKIP';
}
for my $env (@{$self->{test}->{'setenv'}}) {
$ENV{$env->[0]} = $env->[1];
}
my $preload_env_var = 'LD_PRELOAD';
if ($^O eq 'darwin') {
$preload_env_var = 'DYLD_INSERT_LIBRARIES';
}
if (defined($self->{test}->{'preload'})) {
if (-f cwd() . "/../.libs/$self->{test}->{'preload'}") {
$ENV{$preload_env_var} = cwd() . "/../.libs/$self->{test}->{'preload'}";
} else {
$ENV{$preload_env_var} = cwd() . "/../lib$self->{test}->{'preload'}";
}
}
$self->run_program();
for my $env (@{$self->{test}->{'setenv'}}) {
delete ${ENV{$env->[0]}};
}
if (defined($self->{test}->{'preload'})) {
delete ${ENV{$preload_env_var}};
}
if ($self->{test}->{stdin}) {
$self->{stdin} = [ @{$self->{test}->{stdin}} ];
}
if ($self->{test}->{stdout}) {
$self->{expected_stdout} = [ @{$self->{test}->{stdout}} ];
}
else {
$self->{expected_stdout} = [];
}
if ($self->{test}->{stderr}) {
$self->{expected_stderr} = [ @{$self->{test}->{stderr}} ];
}
else {
$self->{expected_stderr} = [];
}
$self->run_hook('post_run_program');
my @failed = ();
if ($self->{exit_status} != ($self->{test}->{return} // 0)) {
push @failed, 'exit status';
if ($self->{verbose}) {
print "Unexpected exit status:\n";
print "-" . ($self->{test}->{return} // 0) . "\n+$self->{exit_status}\n";
}
}
if (!$self->compare_arrays($self->{expected_stdout}, $self->{stdout}, 'output')) {
push @failed, 'output';
}
if (!$self->compare_arrays($self->{expected_stderr}, $self->{stderr}, 'error output')) {
push @failed, 'error output';
}
if (!$self->compare_files()) {
push @failed, 'files';
}
$self->{failed} = \@failed;
$self->run_hook('checks');
my $result = scalar(@{$self->{failed}}) == 0 ? 'PASS' : 'FAIL';
$self->sandbox_leave();
if (!($self->{no_cleanup} || ($self->{keep_broken} && $result eq 'FAIL'))) {
$self->sandbox_remove();
}
$self->print_test_result($tag, $result, join ', ', @{$self->{failed}});
return $result;
}
sub setup {
my ($self, @argv) = @_;
my @save_argv = @ARGV;
@ARGV = @argv;
my $ok = GetOptions(
'help|h' => \my $help,
'bin-sub-directory=s' => \$self->{bin_sub_directory},
'keep-broken|k' => \$self->{keep_broken},
'no-cleanup' => \$self->{no_cleanup},
# 'run-gdb' => \$self->{run_gdb},
'setup-only' => \$self->{setup_only},
'verbose|v' => \$self->{verbose}
);
@argv = @ARGV;
@ARGV = @save_argv;
if (!$ok || scalar(@argv) != 1 || $help) {
print STDERR "Usage: $0 [-hv] [--bin-sub-directory DIR] [--keep-broken] [--no-cleanup] [--setup-only] testcase\n";
exit(1);
}
my $testcase = shift @argv;
$testcase .= '.test' unless ($testcase =~ m/\.test$/);
my $testcase_file = $self->find_file($testcase);
$self->die("cannot find test case $testcase") unless ($testcase_file);
$testcase =~ s,^(?:.*/)?([^/]*)\.test$,$1,;
$self->{testname} = $testcase;
$self->die("error in test case definition") unless $self->parse_case($testcase_file);
$self->check_features_requirement() if ($self->{test}->{features});
$self->run_precheck() if ($self->{test}->{precheck});
$self->end_test('SKIP') if ($self->{test}->{preload} && ($^O eq 'darwin' || $^O eq 'MSWin32'));
$self->end_test('SKIP') if (($self->{test}->{stdin} || $self->{test}->{'stdin-file'}) && $^O eq 'MSWin32');
}
# MARK: - Internal Methods
sub add_file {
my ($self, $file) = @_;
if (defined($self->{files}->{$file->{destination}})) {
$self->warn("duplicate specification for input file $file->{destination}");
return undef;
}
$self->{files}->{$file->{destination}} = $file;
return 1;
}
sub check_features_requirement() {
my ($self) = @_;
my %features;
my $fh;
unless (open($fh, '<', "$self->{top_builddir}/config.h")) {
$self->die("cannot open config.h in top builddir $self->{top_builddir}");
}
while (my $line = <$fh>) {
if ($line =~ m/^#define HAVE_([A-Z0-9_a-z]*)/) {
$features{$1} = 1;
}
}
close($fh);
my @missing = ();
for my $feature (@{$self->{test}->{features}}) {
if (!$features{$feature}) {
push @missing, $feature;
}
}
if (scalar @missing > 0) {
my $reason = "missing features";
if (scalar(@missing) == 1) {
$reason = "missing feature";
}
$self->print_test_result('SKIP', "$reason: " . (join ' ', @missing));
$self->end_test('SKIP');
}
return 1;
}
sub comparator_zip {
my ($self, $got, $expected) = @_;
my $zipcmp = (-f $self->{zipcmp}) ? $self->{zipcmp} : $self->find_program('zipcmp');
my @args = ($zipcmp, $self->{verbose} ? '-v' : '-q');
push @args, $self->{zipcmp_flags} if ($self->{zipcmp_flags});
push @args, ($expected, $got);
my $ret = system(@args);
return $ret == 0;
}
sub compare_arrays() {
my ($self, $a, $b, $tag) = @_;
my $ok = 1;
if (scalar(@$a) != scalar(@$b)) {
$ok = 0;
}
else {
for (my $i = 0; $i < scalar(@$a); $i++) {
if ($a->[$i] ne $b->[$i]) {
$ok = 0;
last;
}
}
}
if (!$ok && $self->{verbose}) {
print "Unexpected $tag:\n";
print "--- expected\n+++ got\n";
diff_arrays($a, $b);
}
return $ok;
}
sub file_cmp($$) {
my ($a, $b) = @_;
my $result = 0;
open my $fha, "< $a";
open my $fhb, "< $b";
binmode $fha;
binmode $fhb;
BYTE: while (!eof $fha && !eof $fhb) {
if (getc $fha ne getc $fhb) {
$result = 1;
last BYTE;
}
}
$result = 1 if eof $fha != eof $fhb;
close $fha;
close $fhb;
return $result;
}
sub compare_file($$$) {
my ($self, $got, $expected) = @_;
my $real_expected = $self->find_file($expected);
unless ($real_expected) {
$self->warn("cannot find expected result file $expected");
return 0;
}
my $ok = $self->run_comparator($got, $real_expected);
if (!defined($ok)) {
my $ret;
if ($self->{verbose}) {
$ret = system('diff', '-u', $real_expected, $got);
}
else {
$ret = file_cmp($real_expected, $got);
}
$ok = ($ret == 0);
}
return $ok;
}
sub list_files {
my ($root) = @_;
my $ls;
my @files = ();
my @dirs = ($root);
while (scalar(@dirs) > 0) {
my $dir = shift @dirs;
opendir($ls, $dir);
unless ($ls) {
# TODO: handle error
}
while (my $entry = readdir($ls)) {
my $file = "$dir/$entry";
if ($dir eq '.') {
$file = $entry;
}
if (-f $file) {
push @files, "$file";
}
if (-d $file && $entry ne '.' && $entry ne '..') {
push @dirs, "$file";
}
}
closedir($ls);
}
return @files;
}
sub compare_files() {
my ($self) = @_;
my $ok = 1;
my @files_got = sort(list_files("."));
my @files_should = ();
for my $file (sort keys %{$self->{files}}) {
push @files_should, $file if ($self->{files}->{$file}->{result} || $self->{files}->{$file}->{ignore});
}
$self->{files_got} = \@files_got;
$self->{files_should} = \@files_should;
unless ($self->run_hook('post_list_files')) {
return 0;
}
$ok = $self->compare_arrays($self->{files_should}, $self->{files_got}, 'files');
for my $file (@{$self->{files_got}}) {
my $file_def = $self->{files}->{$file};
next unless ($file_def && $file_def->{result});
$ok &= $self->compare_file($file, $file_def->{result});
}
return $ok;
}
sub copy_files {
my ($self) = @_;
my $ok = 1;
for my $filename (sort keys %{$self->{files}}) {
my $file = $self->{files}->{$filename};
next unless ($file->{source});
my $src = $self->find_file($file->{source});
unless ($src) {
$self->warn("cannot find input file $file->{source}");
$ok = 0;
next;
}
if ($file->{destination} =~ m,/,) {
my $dir = $file->{destination};
$dir =~ s,/[^/]*$,,;
if (! -d $dir) {
mkpath($dir);
}
}
my $this_ok = $self->run_copier($src, $file->{destination});
if (defined($this_ok)) {
$ok &= $this_ok;
}
else {
unless (copy($src, $file->{destination})) {
$self->warn("cannot copy $src to $file->{destination}: $!");
$ok = 0;
}
}
}
if (defined($self->{test}->{mkdir})) {
for my $dir_spec (@{$self->{test}->{mkdir}}) {
my ($mode, $dir) = @$dir_spec;
if (! -d $dir) {
unless (mkdir($dir, oct($mode))) {
$self->warn("cannot create directory $dir: $!");
$ok = 0;
}
}
}
}
$self->die("failed to copy input files") unless ($ok);
}
sub die() {
my ($self, $msg) = @_;
print STDERR "$0: $msg\n" if ($msg);
$self->end_test('ERROR');
}
sub end_test {
my ($self, $status) = @_;
my $exit_code = $EXIT_CODES{$status} // $EXIT_CODES{ERROR};
$self->exit($exit_code);
}
sub exit() {
my ($self, $status) = @_;
### TODO: cleanup
exit($status);
}
sub find_file() {
my ($self, $fname) = @_;
for my $dir (('', "$self->{srcdir}/")) {
my $f = "$dir$fname";
$f = "../$f" if ($self->{in_sandbox} && $dir !~ m,^(\w:)?/,);
return $f if (-f $f);
}
return undef;
}
sub get_extension {
my ($self, $fname) = @_;
my $ext = $fname;
if ($ext =~ m/\./) {
$ext =~ s/.*\.//;
}
else {
$ext = '';
}
return $ext;
}
sub get_variable {
my ($self, $name, $opts) = @_;
$self->{$name} = $opts->{$name} // $ENV{$name};
if (!defined($self->{$name}) || $self->{$name} eq '') {
my $fh;
unless (open($fh, '<', 'Makefile')) {
$self->die("cannot open Makefile: $!");
}
while (my $line = <$fh>) {
chomp $line;
if ($line =~ m/^$name = (.*)/) {
$self->{$name} = $1;
last;
}
}
close ($fh);
}
if (!defined($self->{$name}) || $self->{$name} eq '') {
$self->die("cannot get variable $name");
}
}
sub mangle_test_for_variant {
my ($self) = @_;
$self->{test}->{stdout} = $self->strip_tags($self->{variant}, $self->{test}->{stdout});
$self->{test}->{stderr} = $self->strip_tags($self->{variant}, $self->{test}->{stderr});
$self->run_hook('mangle_test');
return 1;
}
sub parse_args {
my ($self, $type, $str) = @_;
if ($type eq 'string...') {
my $args = [];
while ($str ne '') {
if ($str =~ m/^\"/) {
unless ($str =~ m/^\"([^\"]*)\"\s*(.*)/) {
$self->warn_file_line("unclosed quote in [$str]");
return undef;
}
push @$args, $1;
$str = $2;
}
else {
$str =~ m/^(\S+)\s*(.*)/;
push @$args, $1;
$str = $2;
}
}
return $args;
}
elsif ($type =~ m/(\s|\.\.\.$)/) {
my $ellipsis = 0;
if ($type =~ m/(.*)\.\.\.$/) {
$ellipsis = 1;
$type = $1;
}
my @types = split /\s+/, $type;
my @strs = split /\s+/, $str;
my $optional = 0;
for (my $i = scalar(@types) - 1; $i >= 0; $i--) {
last unless ($types[$i] =~ m/(.*)\?$/);
$types[$i] = $1;
$optional++;
}
if ($ellipsis && $optional > 0) {
# TODO: check this when registering a directive
$self->warn_file_line("can't use ellipsis together with optional arguments");
return undef;
}
if (!$ellipsis && (scalar(@strs) < scalar(@types) - $optional || scalar(@strs) > scalar(@types))) {
my $expected = scalar(@types);
if ($optional > 0) {
$expected = ($expected - $optional) . "-$expected";
}
$self->warn_file_line("expected $expected arguments, got " . (scalar(@strs)));
return undef;
}
my $args = [];
my $n = scalar(@types);
for (my $i=0; $i<scalar(@strs); $i++) {
my $val = $self->parse_args(($i >= $n ? $types[$n-1] : $types[$i]), $strs[$i]);
return undef unless (defined($val));
push @$args, $val;
}
return $args;
}
else {
if ($type eq 'string') {
return $str;
}
elsif ($type eq 'int') {
if ($str !~ m/^\d+$/) {
$self->warn_file_line("illegal int [$str]");
return undef;
}
return $str+0;
}
elsif ($type eq 'char') {
if ($str !~ m/^.$/) {
$self->warn_file_line("illegal char [$str]");
return undef;
}
return $str;
}
else {
$self->warn_file_line("unknown type $type");
return undef;
}
}
}
sub parse_case() {
my ($self, $fname) = @_;
my $ok = 1;
open TST, "< $fname" or $self->die("cannot open test case $fname: $!");
$self->{testcase_fname} = $fname;
my %test = ();
while (my $line = <TST>) {
$line =~ s/(\n|\r)//g;
next if ($line =~ m/^\#/);
unless ($line =~ m/(\S*)(?:\s(.*))?/) {
$self->warn_file_line("cannot parse line $line");
$ok = 0;
next;
}
my ($cmd, $argstring) = ($1, $2//"");
my $def = $self->{directives}->{$cmd};
unless ($def) {
$self->warn_file_line("unknown directive $cmd in test file");
$ok = 0;
next;
}
my $args = $self->parse_args($def->{type}, $argstring);
unless (defined($args)) {
$ok = 0;
next;
}
if ($def->{once}) {
if (defined($test{$cmd})) {
$self->warn_file_line("directive $cmd appeared twice in test file");
}
$test{$cmd} = $args;
}
else {
$test{$cmd} = [] unless (defined($test{$cmd}));
push @{$test{$cmd}}, $args;
}
}
close TST;
return undef unless ($ok);
for my $cmd (sort keys %test) {
if ($self->{directives}->{$cmd}->{required} && !defined($test{$cmd})) {
$self->warn_file("required directive $cmd missing in test file");
$ok = 0;
}
}
if ($test{'stdin-file'} && $test{stdin}) {
$self->warn_file("both stdin-file and stdin provided, choose one");
$ok = 0;
}
if (defined($self->{variants})) {
if (defined($test{variants})) {
for my $name (@{$test{variants}}) {
my $found = 0;
for my $variant (@{$self->{variants}}) {
if ($name eq $variant->{name}) {
$found = 1;
last;
}
}
if ($found == 0) {
$self->warn_file("unknown variant $name");
$ok = 0;
}
}
}
}
return undef unless ($ok);
if (defined($test{'stderr-replace'}) && defined($test{stderr})) {
$test{stderr} = [ map { $self->stderr_rewrite($test{'stderr-replace'}, $_); } @{$test{stderr}} ];
}
if (!defined($test{program})) {
$test{program} = $self->{default_program};
}
$self->{test} = \%test;
$self->run_hook('mangle_program');
if (!$self->parse_postprocess_files()) {
return 0;
}
return $self->run_hook('post_parse');
}
sub parse_postprocess_files {
my ($self) = @_;
$self->{files} = {};
my $ok = 1;
for my $file (@{$self->{test}->{file}}) {
$ok = 0 unless ($self->add_file({ source => $file->[1], destination => $file->[0], result => $file->[2] }));
}
for my $file (@{$self->{test}->{'file-del'}}) {
$ok = 0 unless ($self->add_file({ source => $file->[1], destination => $file->[0], result => undef }));
}
for my $file (@{$self->{test}->{'file-new'}}) {
$ok = 0 unless ($self->add_file({ source => undef, destination => $file->[0], result => $file->[1] }));
}
return $ok;
}
sub print_test_result {
my ($self, $tag, $result, $reason) = @_;
if ($self->{verbose}) {
print "$self->{testname}";
print " ($tag)" if ($tag);
print " -- $result";
print ": $reason" if ($reason);
print "\n";
}
}
sub run_comparator {
my ($self, $got, $expected) = @_;
return $self->run_file_proc('compare_by_type', $got, $expected);
}
sub run_copier {
my ($self, $src, $dest) = @_;
return $self->run_file_proc('copy_by_type', $src, $dest);
}
sub run_file_proc {
my ($self, $proc, $got, $expected) = @_;
my $ext = ($self->get_extension($got)) . '/' . ($self->get_extension($expected));
if ($self->{variant}) {
if (defined($self->{$proc}->{"$self->{variant}/$ext"})) {
for my $sub (@{$self->{$proc}->{"$self->{variant}/$ext"}}) {
my $ret = $sub->($self, $got, $expected);
return $ret if (defined($ret));
}
}
}
if (defined($self->{$proc}->{$ext})) {
for my $sub (@{$self->{$proc}->{$ext}}) {
my $ret = $sub->($self, $got, $expected);
return $ret if (defined($ret));
}
}
return undef;
}
sub run_hook {
my ($self, $hook) = @_;
my $ok = 1;
my @hooks = ();
if (defined($self->{variant_hooks}) && defined($self->{variant_hooks}->{$hook})) {
push @hooks, $self->{variant_hooks}->{$hook};
}
if (defined($self->{hooks}->{$hook})) {
push @hooks, @{$self->{hooks}->{$hook}};
}
for my $sub (@hooks) {
unless ($sub->($self, $hook, $self->{variant})) {
$self->warn("hook $hook failed");
$ok = 0;
}
}
return $ok;
}
sub args_decode {
my ($str, $srcdir) = @_;
if ($str =~ m/\\/) {
$str =~ s/\\a/\a/gi;
$str =~ s/\\b/\b/gi;
$str =~ s/\\f/\f/gi;
$str =~ s/\\n/\n/gi;
$str =~ s/\\r/\r/gi;
$str =~ s/\\t/\t/gi;
$str =~ s/\\v/\cK/gi;
$str =~ s/\\s/ /gi;
# TODO: \xhh, \ooo
$str =~ s/\\(.)/$1/g;
}
if ($srcdir !~ m,^/,) {
$srcdir = "../$srcdir";
}
if ($str =~ m/^\$srcdir(.*)/) {
$str = "$srcdir$1";
}
return $str;
}
sub run_precheck {
my ($self) = @_;
for my $precheck (@{$self->{test}->{precheck}}) {
unless (system(@{$precheck}) == 0) {
$self->print_test_result('SKIP', "precheck failed");
$self->end_test('SKIP');
}
}
return 1;
}
sub find_program() {
my ($self, $pname) = @_;
my @directories = (".");
if ($self->{bin_sub_directory}) {
push @directories, $self->{bin_sub_directory};
}
for my $up (('.', '..', '../..', '../../..')) {
for my $sub (('.', 'src')) {
for my $dir (@directories) {
for my $ext (('', '.exe')) {
my $f = "$up/$sub/$dir/$pname$ext";
return $f if (-f $f);
}
}
}
}
return undef;
}
sub run_program {
my ($self) = @_;
my ($stdin, $stdout, $stderr);
$stderr = gensym;
my @cmd = ($self->find_program($self->{test}->{program}), map ({ args_decode($_, $self->{srcdir}); } @{$self->{test}->{args}}));
### TODO: catch errors?
my $pid;
if ($self->{test}->{'stdin-file'}) {
open(SPLAT, '<', $self->{test}->{'stdin-file'});
my $is_marked = eof SPLAT; # mark used
$pid = open3("<&SPLAT", $stdout, $stderr, @cmd);
}
else {
$pid = open3($stdin, $stdout, $stderr, @cmd);
}
$self->{stdout} = [];
$self->{stderr} = [];
if ($self->{test}->{stdin}) {
foreach my $line (@{$self->{test}->{stdin}}) {
print $stdin $line . "\n";
}
close($stdin);
}
while (my $line = <$stdout>) {
$line =~ s/(\n|\r)//g;
push @{$self->{stdout}}, $line;
}
my $prg = $self->{test}->{program};
$prg =~ s,.*/,,;
while (my $line = <$stderr>) {
$line =~ s/(\n|\r)//g;
$line =~ s/^[^: ]*$prg(\.exe)?: //;
if (defined($self->{test}->{'stderr-replace'})) {
$line = $self->stderr_rewrite($self->{test}->{'stderr-replace'}, $line);
}
push @{$self->{stderr}}, $line;
}
waitpid($pid, 0);
$self->{exit_status} = $? >> 8;
}
sub sandbox_create {
my ($self, $tag) = @_;
$tag = ($tag ? "-$tag" : "");
$self->{sandbox_dir} = "sandbox-$self->{testname}$tag.d$$";
$self->die("sandbox $self->{sandbox_dir} already exists") if (-e $self->{sandbox_dir});
mkdir($self->{sandbox_dir}) or $self->die("cannot create sandbox $self->{sandbox_dir}: $!");
return 1;
}
sub sandbox_enter {
my ($self) = @_;
$self->die("internal error: cannot enter sandbox before creating it") unless (defined($self->{sandbox_dir}));
return if ($self->{in_sandbox});
chdir($self->{sandbox_dir}) or $self->die("cannot cd into sandbox $self->{sandbox_dir}: $!");
$self->{in_sandbox} = 1;
}
sub sandbox_leave {
my ($self) = @_;
return if (!$self->{in_sandbox});
chdir('..') or $self->die("cannot leave sandbox: $!");
$self->{in_sandbox} = 0;
}
sub sandbox_remove {
my ($self) = @_;
remove_tree($self->{sandbox_dir});
return 1;
}
sub strip_tags {
my ($self, $tag, $lines) = @_;
my @stripped = ();
for my $line (@$lines) {
if ($line =~ m/^<([a-zA-Z0-9_]*)> (.*)/) {
if ($1 eq $tag) {
push @stripped, $2;
}
}
else {
push @stripped, $line;
}
}
return \@stripped;
}
sub touch_files {
my ($self) = @_;
my $ok = 1;
if (defined($self->{test}->{touch})) {
for my $args (@{$self->{test}->{touch}}) {
my ($mtime, $fname) = @$args;
if (!-f $fname) {
my $fh;
unless (open($fh, "> $fname") and close($fh)) {
# TODO: error message
$ok = 0;
next;
}
}
unless (utime($mtime, $mtime, $fname) == 1) {
# TODO: error message
$ok = 0;
}
}
}
return $ok;
}
sub warn {
my ($self, $msg) = @_;
print STDERR "$0: $msg\n";
}
sub warn_file {
my ($self, $msg) = @_;
$self->warn("$self->{testcase_fname}: $msg");
}
sub warn_file_line {
my ($self, $msg) = @_;
$self->warn("$self->{testcase_fname}:$.: $msg");
}
sub stderr_rewrite {
my ($self, $pattern, $line) = @_;
for my $repl (@{$pattern}) {
$line =~ s/$repl->[0]/$repl->[1]/;
}
return $line;
}
# MARK: array diff
sub diff_arrays {
my ($a, $b) = @_;
my ($i, $j);
for ($i = $j = 0; $i < scalar(@$a) || $j < scalar(@$b);) {
if ($i >= scalar(@$a)) {
print "+$b->[$j]\n";
$j++;
}
elsif ($j >= scalar(@$b)) {
print "-$a->[$i]\n";
$i++;
}
elsif ($a->[$i] eq $b->[$j]) {
print " $a->[$i]\n";
$i++;
$j++;
}
else {
my ($off_a, $off_b) = find_best_offsets($a, $i, $b, $j);
my ($off_b_2, $off_a_2) = find_best_offsets($b, $j, $a, $i);
if ($off_a + $off_b > $off_a_2 + $off_b_2) {
$off_a = $off_a_2;
$off_b = $off_b_2;
}
for (my $off = 0; $off < $off_a; $off++) {
print "-$a->[$i]\n";
$i++;
}
for (my $off = 0; $off < $off_b; $off++) {
print "+$b->[$j]\n";
$j++;
}
}
}
}
sub find_best_offsets {
my ($a, $i, $b, $j) = @_;
my ($best_a, $best_b);
for (my $off_a = 0; $off_a < (defined($best_a) ? $best_a + $best_b : scalar(@$a) - $i); $off_a++) {
my $off_b = find_entry($a->[$i+$off_a], $b, $j, defined($best_a) ? $best_a + $best_b - $off_a : scalar(@$b) - $j);
next unless (defined($off_b));
if (!defined($best_a) || $best_a + $best_b > $off_a + $off_b) {
$best_a = $off_a;
$best_b = $off_b;
}
}
if (!defined($best_a)) {
return (scalar(@$a) - $i, scalar(@$b) - $j);
}
return ($best_a, $best_b);
}
sub find_entry {
my ($entry, $array, $start, $max_offset) = @_;
for (my $offset = 0; $offset < $max_offset; $offset++) {
return $offset if ($array->[$start + $offset] eq $entry);
}
return undef;
}
1;
Codebase Browser
chromium