461 lines
13 KiB
Perl
Executable File
461 lines
13 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
use subs;
|
|
use strict;
|
|
use warnings;
|
|
use File::Basename;
|
|
use Term::ANSIColor;
|
|
|
|
use Cwd;
|
|
|
|
my $has_thread_pool = eval
|
|
{
|
|
# "http://www.cpan.org/authors/id/J/JW/JWU/Thread-Pool-Simple/Thread-Pool-Simple-0.25.tar.gz"
|
|
# Debian/Ubuntu: libthread-pool-simple-perl
|
|
require Thread::Pool::Simple;
|
|
Thread::Pool::Simple->import();
|
|
1;
|
|
};
|
|
|
|
# test.pl
|
|
#
|
|
# runs a test and check its output
|
|
|
|
sub run($$$$$) {
|
|
my ($name, $input, $cmd, $options, $output) = @_;
|
|
my $cmdline = "$cmd $options '$input' >'$output' 2>&1";
|
|
|
|
print LOG "Running $cmdline\n";
|
|
system("bash", "-c", "cd '$name' ; $cmdline");
|
|
my $exit_value = $? >> 8;
|
|
my $signal_num = $? & 127;
|
|
my $dumped_core = $? & 128;
|
|
my $failed = 0;
|
|
|
|
print LOG " Exit: $exit_value\n";
|
|
print LOG " Signal: $signal_num\n";
|
|
print LOG " Core: $dumped_core\n";
|
|
|
|
if($signal_num != 0) {
|
|
print "Killed by signal $signal_num";
|
|
if($dumped_core) {
|
|
print " (code dumped)";
|
|
}
|
|
}
|
|
|
|
open my $FH, ">>$name/$output";
|
|
print $FH "EXIT=$exit_value\n";
|
|
print $FH "SIGNAL=$signal_num\n";
|
|
close $FH;
|
|
|
|
if($signal_num == 2) {
|
|
print "\nProgram under test interrupted; stopping\n";
|
|
exit 1;
|
|
}
|
|
|
|
return $failed;
|
|
}
|
|
|
|
sub load($) {
|
|
my ($fname) = @_;
|
|
|
|
open FILE, "<$fname";
|
|
my @data = grep { !/^\/\// } <FILE>;
|
|
close FILE;
|
|
|
|
chomp @data;
|
|
return @data;
|
|
}
|
|
|
|
sub test($$$$$$$$$$) {
|
|
my ($name, $test, $t_level, $cmd, $ign, $dry_run, $defines, $include_tags, $exclude_tags, $output_suffix) = @_;
|
|
my ($level_and_tags, $input, $options, $grep_options, @results) = load("$test");
|
|
my @keys = keys %{$defines};
|
|
foreach my $key (@keys) {
|
|
my $value = $defines->{$key};
|
|
$options =~ s/(\$$key$|\$$key )/$value /g;
|
|
}
|
|
if (scalar @keys) {
|
|
foreach my $word (split(/\s/, $options)) {
|
|
if ((substr($word, 0, 1) cmp '$') == 0) {
|
|
print "$name: variable \"$word\" not replaced; consider passing \"-D$word\"=...";
|
|
}
|
|
}
|
|
}
|
|
|
|
my @tags = split(/\s/, $level_and_tags);
|
|
my $level = shift @tags;
|
|
my %tags_set = map { $_ => 1 } @tags;
|
|
|
|
# If the user has passes -I (include-tag) or -X (exclude-tag) options, then
|
|
# run the test only if it matches no exclude-tags and either include-tags is
|
|
# not given (implying run all tests) or it matches at least one include-tag.
|
|
|
|
my $include_tags_length = @$include_tags;
|
|
my $passes_tag_tests = ($include_tags_length == 0);
|
|
foreach my $include_tag (@$include_tags) {
|
|
if(exists($tags_set{$include_tag})) {
|
|
$passes_tag_tests = 1;
|
|
}
|
|
}
|
|
|
|
foreach my $exclude_tag (@$exclude_tags) {
|
|
if(exists($tags_set{$exclude_tag})) {
|
|
$passes_tag_tests = 0;
|
|
}
|
|
}
|
|
|
|
# If the 4th line is activate-multi-line-match we enable multi-line checks
|
|
if($grep_options ne "activate-multi-line-match") {
|
|
# No such flag, so we add it back in
|
|
unshift @results, $grep_options;
|
|
$grep_options = "";
|
|
}
|
|
|
|
$options =~ s/$ign//g if(defined($ign));
|
|
|
|
my $descriptor = basename($test);
|
|
my $output = $descriptor;
|
|
$output =~ s/\.[^.]*$//;
|
|
if($output_suffix) {
|
|
$output .= "-";
|
|
$output .= $output_suffix;
|
|
}
|
|
$output .= ".out";
|
|
|
|
if($output eq $input) {
|
|
print("Error in test file -- $test\n");
|
|
return 1;
|
|
}
|
|
|
|
print LOG "Test '$name'\n";
|
|
print LOG " Level: $level\n";
|
|
print LOG " Input: $input\n";
|
|
print LOG " Descriptor: $descriptor\n";
|
|
print LOG " Output: $output\n";
|
|
print LOG " Options: $options\n";
|
|
print LOG " Results:\n";
|
|
foreach my $result (@results) {
|
|
print LOG " $result\n";
|
|
}
|
|
|
|
if($level eq "CORE") {
|
|
$level = 1;
|
|
} elsif($level eq "THOROUGH") {
|
|
$level = 2;
|
|
} elsif($level eq "FUTURE") {
|
|
$level = 4;
|
|
} elsif($level eq "KNOWNBUG") {
|
|
$level = 8;
|
|
} else {
|
|
die "Level must be one of CORE, THOROUGH, FUTURE or KNOWNBUG\n";
|
|
}
|
|
|
|
my $failed = 2;
|
|
if(($level & $t_level) && $passes_tag_tests) {
|
|
|
|
if ($dry_run) {
|
|
return 0;
|
|
}
|
|
|
|
$failed = run($name, $input, $cmd, $options, $output);
|
|
|
|
if(!$failed) {
|
|
print LOG "Execution [OK]\n";
|
|
my $included = 1;
|
|
foreach my $result (@results) {
|
|
last if($included == -1);
|
|
if($result eq "--") {
|
|
$included--;
|
|
} else {
|
|
my $r;
|
|
|
|
my $dir = getcwd();
|
|
my $abs_path = "$dir/$name/$output";
|
|
open(my $fh => $abs_path) || die "Cannot open '$name/$output': $!";
|
|
|
|
# Multi line therefore we run each check across the whole output
|
|
if($grep_options eq "activate-multi-line-match") {
|
|
local $/ = undef;
|
|
binmode $fh;
|
|
my $whole_file = <$fh>;
|
|
$whole_file =~ s/\r\n/\n/g;
|
|
my $is_match = $whole_file =~ /$result/m;
|
|
$r = ($included ? !$is_match : $is_match);
|
|
}
|
|
else
|
|
{
|
|
my $found_line = 0;
|
|
while(my $line = <$fh>) {
|
|
$line =~ s/\r$//;
|
|
if($line =~ /$result/) {
|
|
# We've found the line, therefore if it is included we set
|
|
# the result to 0 (OK) If it is excluded, we set the result
|
|
# to 1 (FAILED)
|
|
$r = !$included;
|
|
$found_line = 1;
|
|
last;
|
|
}
|
|
}
|
|
|
|
if($found_line == 0) {
|
|
# None of the lines matched, therefore the result is set to
|
|
# 0 (OK) if and only if the line was not meant to be included
|
|
$r = $included;
|
|
}
|
|
|
|
}
|
|
close($fh);
|
|
|
|
|
|
if($r) {
|
|
print LOG "$result [FAILED]\n";
|
|
$failed = 1;
|
|
} else {
|
|
print LOG "$result [OK]\n";
|
|
}
|
|
}
|
|
}
|
|
} else {
|
|
print LOG "Execution [FAILED]\n";
|
|
}
|
|
} else {
|
|
print LOG "Execution [SKIPPED]\n";
|
|
return 2;
|
|
}
|
|
|
|
print LOG "\n";
|
|
|
|
# if the test is a KNOWNBUG then the test should fail
|
|
my $should_fail = $level eq 8;
|
|
|
|
return ($should_fail != $failed);
|
|
}
|
|
|
|
sub dirs() {
|
|
my @list;
|
|
|
|
opendir CWD, ".";
|
|
@list = grep { !/^\./ && -d "$_" && !/CVS/ } readdir CWD;
|
|
closedir CWD;
|
|
|
|
@list = sort @list;
|
|
|
|
return @list;
|
|
}
|
|
|
|
sub main::VERSION_MESSAGE($$$$) {
|
|
my ($fh, $getopt, $vers, $opts) = @_;
|
|
print {$fh} << "EOF";
|
|
test.pl version $vers -- run a series of regression tests
|
|
EOF
|
|
}
|
|
|
|
sub main::HELP_MESSAGE($$$$) {
|
|
my ($fh, $getopt, $vers, $opts) = @_;
|
|
print {$fh} << "EOF";
|
|
|
|
Usage: test.pl -c CMD [OPTIONS] [DIRECTORIES ...]
|
|
where OPTIONS are one or more options as listed below; one or more directories
|
|
may be passed as arguments to test only those. Otherwise all directories in
|
|
the current location will be used.
|
|
|
|
-c CMD run tests on CMD - required option
|
|
-i <regex> options in test.desc matching the specified perl regex are ignored
|
|
-j <num> run <num> tests in parallel (requires Thread::Pool::Simple)
|
|
if present, the environment variable TESTPL_JOBS is used as the default
|
|
-n dry-run: print the tests that would be run, but don't actually run them
|
|
-p print logs of each failed test (if any)
|
|
-h show this help and exit
|
|
-C core: run all essential tests (default if none of C/T/F/K are given)
|
|
-T thorough: run expensive tests
|
|
-F future: run checks for future features
|
|
-K known: run tests associated with known bugs
|
|
-D <key=value> Define - replace \$key string with "value" string in
|
|
test descriptors
|
|
-I <tag> run only tests that have the given secondary tag. Can be repeated.
|
|
-X <tag> exclude tests that have the given secondary tag. Can be repeated.
|
|
-s <suffix> append <suffix> to all output and log files. Enables concurrent
|
|
testing of the same desc file with different commands or options,
|
|
as runs with different suffixes will operate independently and keep
|
|
independent logs.
|
|
|
|
test.pl expects a test.desc file in each subdirectory. The file test.desc
|
|
follows the format specified below. Any line starting with // will be ignored.
|
|
|
|
<level> [<tag1> [<tag2>...]]
|
|
<main source>
|
|
<options>
|
|
<activate-multi-line-match>
|
|
<required patterns>
|
|
--
|
|
<disallowed patterns>
|
|
--
|
|
<comment text>
|
|
|
|
where
|
|
<level> is one of CORE, THOROUGH, FUTURE or KNOWNBUG
|
|
<tag1>, <tag2> ... <tagn> are zero or more space-separated secondary tags, for use with the -I and -X parameters
|
|
<main source> is a file with extension .c/.i/.gb/.cpp/.ii/.xml/.class/.jar
|
|
<options> additional options to be passed to CMD
|
|
<activate-multi-line-match> The fourth line can optionally be activate-multi-line-match, if this is the
|
|
case then each of the rules will be matched over multiple lines (so can contain)
|
|
the new line symbol (\\n) inside them.
|
|
<required patterns> one or more lines of regualar expressions that must occur in the output
|
|
<disallowed patterns> one or more lines of expressions that must not occur in output
|
|
<comment text> free form text
|
|
|
|
EOF
|
|
exit 1;
|
|
}
|
|
|
|
use Getopt::Std;
|
|
use Getopt::Long qw(:config pass_through bundling);
|
|
$main::VERSION = 0.1;
|
|
$Getopt::Std::STANDARD_HELP_VERSION = 1;
|
|
our ($opt_c, $opt_i, $opt_j, $opt_n, $opt_p, $opt_h, $opt_C, $opt_T, $opt_F, $opt_K, $opt_s, %defines, @include_tags, @exclude_tags); # the variables for getopt
|
|
GetOptions("D=s" => \%defines, "X=s" => \@exclude_tags, "I=s" => \@include_tags);
|
|
getopts('c:i:j:nphCTFKs:') or &main::HELP_MESSAGE(\*STDOUT, "", $main::VERSION, "");
|
|
$opt_c or &main::HELP_MESSAGE(\*STDOUT, "", $main::VERSION, "");
|
|
$opt_j = $opt_j || $ENV{'TESTPL_JOBS'} || 0;
|
|
if($opt_j && $opt_j != 1 && !$has_thread_pool) {
|
|
warn "Jobs set but thread pool module not found,\n"
|
|
. "install with 'cpan -i Thread::Pool::Simple'\n"
|
|
. "Or avoid setting the -j parameter or the TESTPL_JOBS variable\n";
|
|
}
|
|
$opt_h and &main::HELP_MESSAGE(\*STDOUT, "", $main::VERSION, "");
|
|
my $t_level = 0;
|
|
$t_level += 2 if($opt_T);
|
|
$t_level += 4 if($opt_F);
|
|
$t_level += 8 if($opt_K);
|
|
$t_level += 1 if($opt_C || 0 == $t_level);
|
|
my $dry_run = $opt_n;
|
|
my $log_suffix = $opt_s;
|
|
|
|
my $logfile_name = "tests";
|
|
if($log_suffix) {
|
|
$logfile_name .= "-";
|
|
$logfile_name .= $log_suffix;
|
|
}
|
|
$logfile_name .= ".log";
|
|
|
|
open LOG, (">" . $logfile_name);
|
|
|
|
print "Loading\n";
|
|
my @tests = @ARGV != 0 ? @ARGV : dirs();
|
|
my $count = 0;
|
|
for (@tests){
|
|
my @testfiles = glob "$_/*desc";
|
|
$count += $#testfiles+1;
|
|
}
|
|
print " $count " . (1==$count?"test":"tests") . " found\n\n";
|
|
|
|
use Cwd qw(getcwd);
|
|
my $cwd = getcwd;
|
|
my $failures :shared = 0;
|
|
my $skips :shared = 0;
|
|
my $pool :shared = undef;
|
|
|
|
sub do_test($)
|
|
{
|
|
my ($test) = @_;
|
|
my $failed_skipped = 0;
|
|
my @files = glob "$test/*.desc";
|
|
for (0..$#files){
|
|
defined($pool) or print " Running $files[$_]";
|
|
my $start_time = time();
|
|
$failed_skipped = test(
|
|
$test, $files[$_], $t_level, $opt_c, $opt_i, $dry_run, \%defines, \@include_tags, \@exclude_tags, $log_suffix);
|
|
my $runtime = time() - $start_time;
|
|
|
|
lock($skips);
|
|
defined($pool) and print " Running $test $files[$_]";
|
|
if(2 == $failed_skipped) {
|
|
$skips++;
|
|
print " [SKIPPED]\n";
|
|
} elsif(0 == $failed_skipped) {
|
|
print " [" . colored("OK", "green") . "] in $runtime seconds\n";
|
|
} else {
|
|
$failures++;
|
|
print " [" . colored("FAILED", "red") . "]\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
if($opt_j>1 && $has_thread_pool && $count>1)
|
|
{
|
|
$pool = Thread::Pool::Simple->new(
|
|
min => 2,
|
|
max => $opt_j,
|
|
load => 3,
|
|
do => [\&do_test]
|
|
);
|
|
}
|
|
|
|
print "Running tests\n";
|
|
foreach my $test (@tests) {
|
|
if(defined($pool))
|
|
{
|
|
$pool->add($test);
|
|
}
|
|
else
|
|
{
|
|
do_test($test);
|
|
}
|
|
}
|
|
|
|
defined($pool) and $pool->join();
|
|
|
|
print "\n";
|
|
|
|
if($failures == 0) {
|
|
print colored("All tests were successful", "green");
|
|
} else {
|
|
print colored("Tests failed", "red") . "\n";
|
|
print " $failures of $count " . (1==$count?"test":"tests") . " failed";
|
|
}
|
|
print ", $skips " . (1==$skips?"test":"tests") . " skipped" if($skips > 0);
|
|
print "\n";
|
|
|
|
|
|
close LOG;
|
|
|
|
if($opt_p && $failures != 0) {
|
|
open LOG,"<$logfile_name" or die "Failed to open $logfile_name\n";
|
|
|
|
my $printed_this_test = 1;
|
|
my $current_test = "";
|
|
my $output_file = "";
|
|
my $descriptor_file = "";
|
|
|
|
while (my $line = <LOG>) {
|
|
chomp $line;
|
|
if ($line =~ /^Test '(.+)'/) {
|
|
$current_test = $1;
|
|
$printed_this_test = 0;
|
|
} elsif ($line =~ /Descriptor:\s+([^\s]+)/) {
|
|
$descriptor_file = $1;
|
|
} elsif ($line =~ /Output:\s+([^\s]+)/) {
|
|
$output_file = $1;
|
|
} elsif ($line =~ /\[FAILED\]\s*$/) {
|
|
# print a descriptive header before dumping the test.desc lines that
|
|
# actually weren't matched (and print this header just once)
|
|
if(0 == $printed_this_test) {
|
|
$printed_this_test = 1;
|
|
print "\n\n";
|
|
print "Failed test: $current_test\n";
|
|
open FH, "<$current_test/$output_file";
|
|
while (my $f = <FH>) {
|
|
print $f;
|
|
}
|
|
close FH;
|
|
print "\n\nFailed $descriptor_file lines:\n";
|
|
}
|
|
|
|
print "$line\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
exit $failures;
|