test.pl

#!/usr/bin/env 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

my $color_output_enabled;
sub with_color {
  my ($text, $color) = @_;
  if ($color_output_enabled) {
    colored($text, $color);
  } else {
    $text;
  }
}

sub run($$$$$) {
  my ($name, $input, $cmd, $options, $output) = @_;
  my $cmdline;
  if(length($input)) {
    $cmdline = "$cmd $options '$input' >'$output' 2>&1";
  } else {
    $cmdline = "$cmd $options >'$output' 2>&1";
  }

  print LOG "Running $cmdline\n";
  # see https://github.com/git-for-windows/msys2-runtime/pull/11/files
  system("bash", "-c", "cd '$name' ; MSYS_NO_PATHCONV=1 $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)";
    }
  }

  system("bash", "-c", "cd '$name' ; echo '\nEXIT=$exit_value\nSIGNAL=$signal_num\n' >> '$output'");

  if($signal_num == 2) {
    print "\nProgram under test interrupted; stopping\n";
    exit 1;
  }

  return $failed;
}

sub load($$) {
  my ($fname, $exit_signal_checks) = @_;

  open FILE, "<$fname";
  my @data = grep { !/^\/\// } <FILE>;
  close FILE;

  s/\R$// for @data;
  if($exit_signal_checks) {
    grep { /^\^EXIT=[\(\|\d]*\d+\)?\$$/ } @data or die "$fname: Missing EXIT test\n";
    grep { /^\^SIGNAL=\d+\$$/ } @data or die "$fname: Missing SIGNAL test\n";
  }
  return @data;
}

sub test($$$$$$$$$$$) {
  my ($name, $test, $t_level, $cmd, $ign, $dry_run, $defines, $include_tags, $exclude_tags, $output_suffix, $exit_signal_checks) = @_;
  my ($level_and_tags, $input, $options, $grep_options, @results) = load("$test", $exit_signal_checks);
  my @keys = keys %{$defines};
  foreach my $key (@keys) {
    my $value = $defines->{$key};
    $options =~ s/(\$$key$|\$$key )/$value /g;
    $options =~ s/\$$key([:;])/$value$1/g; # Variables in --classpath are separated by (semi)colons
  }
  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;
  }
  if(our $opt_f) {
    substr($options, 0, 0) = "$output "
  }
  $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
  -e         require EXIT and SIGNAL patterns in test specifications
  -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.
  -f         forward the test name to CMD

  --[no]color enable/disable color output; enabled by default unless
              TESTPL_COLOR_OUTPUT is set to 0, in which case it is
              disabled by default.

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
                                  if -e is set, the patterns ^EXIT=...\$ and ^SIGNAL=...\$ are mandatory
  <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_e, $opt_f, $opt_i, $opt_j, $opt_n, $opt_p, $opt_h, $opt_C, $opt_T, $opt_F, $opt_K, $opt_s, $opt_S, %defines, @include_tags, @exclude_tags); # the variables for getopt

# this needs to come before GetOptions to ensure the
# default -> environment -> flag override priority
$color_output_enabled = 1;
if (exists $ENV{'TESTPL_COLOR_OUTPUT'}) {
  $color_output_enabled = $ENV{'TESTPL_COLOR_OUTPUT'};
}

GetOptions("D=s" => \%defines, "X=s" => \@exclude_tags, "I=s" => \@include_tags, 'color!' => \$color_output_enabled);
getopts('c:efi:j:nphCTFKs:S:') 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 $exit_signal_checks = defined($opt_e);

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, $exit_signal_checks);
    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 "  [" . with_color("OK", "green") . "] in $runtime seconds\n";
    } else {
      $failures++;
      print "  [" . with_color("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]
  );
}

if ($log_suffix) {
  print "Running tests with log suffix: $log_suffix\n";
}
else
{
  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 with_color("All tests were successful", "green");
} else {
  print with_color("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/$descriptor_file\n";
        open FH, "<$current_test/$output_file";
        while (my $f = <FH>) {
          print $f;
        }
        close FH;
        print "\n\nFailed $current_test/$descriptor_file lines:\n";
      }

      print "$line\n";
    }
  }
}

exit $failures;