selftest/filter-xfail.pl

   1 #!/usr/bin/perl
   2 # Fix fail -> xfail in subunit streams based on a list of regular expressions
   3 # Copyright (C) Jelmer Vernooij <jelmer@samba.org>
   4 # Published under the GNU GPL, v3 or later
   5
   6 =pod
   7
   8 =head1 NAME
   9
  10 filter-xfail - Filter known failures in a subunit stream
  11
  12 =head1 SYNOPSIS
  13
  14 filter-xfail --help
  15
  16 filter-xfail --known-failures=FILE < in-stream > out-stream
  17
  18 =head1 DESCRIPTION
  19
  20 Simple Subunit stream filter that will change failures to known failures
  21 based on a list of regular expressions.
  22
  23 =head1 OPTIONS
  24
  25 =over 4
  26
  27 =item I<--expected-failures>
  28
  29 Specify a file containing a list of tests that are expected to fail. Failures
  30 for these tests will be counted as successes, successes will be counted as
  31 failures.
  32
  33 The format for the file is, one entry per line:
  34
  35 TESTSUITE-NAME.TEST-NAME
  36
  37 The reason for a test can also be specified, by adding a hash sign (#) and the reason
  38 after the test name.
  39
  40 =head1 LICENSE
  41
  42 selftest is licensed under the GNU General Public License L<http://www.gnu.org/licenses/gpl.html>.
  43
  44
  45 =head1 AUTHOR
  46
  47 Jelmer Vernooij
  48
  49 =cut
  50
  51
  52 use Getopt::Long;
  53 use strict;
  54 use FindBin qw($RealBin $Script);
  55 use lib "$RealBin";
  56 use Subunit qw(parse_results);
  57
  58 my $opt_expected_failures = undef;
  59 my $opt_help = 0;
  60 my @expected_failures = ();
  61
  62 my $result = GetOptions(
  63                 'expected-failures=s' => \$opt_expected_failures,
  64                 'help' => \$opt_help,
  65         );
  66 exit(1) if (not $result);
  67
  68 if ($opt_help) {
  69         print "Usage: filter-xfail [--expected-failures=FILE]... < instream > outstream\n";
  70         exit(0);
  71 }
  72
  73 sub read_test_regexes($)
  74 {
  75         my ($name) = @_;
  76         my @ret = ();
  77         open(LF, "<$name") or die("unable to read $name: $!");
  78         while (<LF>) {
  79                 chomp;
  80                 next if (/^#/);
  81                 if (/^(.*?)([ \t]+)\#([\t ]*)(.*?)$/) {
  82                         push (@ret, [$1, $4]);
  83                 } else {
  84                         s/^(.*?)([ \t]+)\#([\t ]*)(.*?)$//;
  85                         push (@ret, [$_, undef]);
  86                 }
  87         }
  88         close(LF);
  89         return @ret;
  90 }
  91
  92 if (defined($opt_expected_failures)) {
  93         @expected_failures = read_test_regexes($opt_expected_failures);
  94 }
  95
  96 sub find_in_list($$)
  97 {
  98         my ($list, $fullname) = @_;
  99
 100         foreach (@$list) {
 101                 if ($fullname =~ /$$_[0]/) {
 102                          return ($$_[1]) if ($$_[1]);
 103                          return "NO REASON SPECIFIED";
 104                 }
 105         }
 106
 107         return undef;
 108 }
 109
 110 sub expecting_failure($)
 111 {
 112         my ($name) = @_;
 113         return find_in_list(\@expected_failures, $name);
 114 }
 115
 116 my $statistics = {
 117         SUITES_FAIL => 0,
 118
 119         TESTS_UNEXPECTED_OK => 0,
 120         TESTS_EXPECTED_OK => 0,
 121         TESTS_UNEXPECTED_FAIL => 0,
 122         TESTS_EXPECTED_FAIL => 0,
 123         TESTS_ERROR => 0,
 124         TESTS_SKIP => 0,
 125 };
 126
 127 sub control_msg()
 128 {
 129         # We regenerate control messages, so ignore this
 130 }
 131
 132 sub report_time($$)
 133 {
 134         my ($self, $time) = @_;
 135         Subunit::report_time($time);
 136 }
 137
 138 sub output_msg($$)
 139 {
 140         my ($self, $msg) = @_;
 141         print $msg;
 142 }
 143
 144 sub start_test($$$)
 145 {
 146         my ($self, $parents, $testname) = @_;
 147
 148         Subunit::start_test($testname);
 149 }
 150
 151 sub end_test($$$$$)
 152 {
 153         my ($self, $parents, $testname, $result, $unexpected, $reason) = @_;
 154
 155         if (($result eq "fail" or $result eq "failure") and not $unexpected) { $result = "xfail"; }
 156         my $fullname = join(".", @$parents) . ".$testname";
 157         if (expecting_failure($fullname) and ($result eq "fail" or $result eq "failure")) {
 158                 $result = "xfail";
 159         }
 160
 161         Subunit::end_test($testname, $result, $reason);
 162 }
 163
 164 my $msg_ops = {};
 165 bless $msg_ops;
 166
 167 parse_results($msg_ops, $statistics, *STDIN, []);
 168
 169 0;