selftest/filter-subunit.pl

   1 #!/usr/bin/perl
   2 # Filter a subunit stream
   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-subunit - Filter a subunit stream
  11
  12 =head1 SYNOPSIS
  13
  14 filter-subunit --help
  15
  16 filter-subunit --prefix=PREFIX --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<--prefix>
  28
  29 Add the specified prefix to all test names.
  30
  31 =item I<--expected-failures>
  32
  33 Specify a file containing a list of tests that are expected to fail. Failures
  34 for these tests will be counted as successes, successes will be counted as
  35 failures.
  36
  37 The format for the file is, one entry per line:
  38
  39 TESTSUITE-NAME.TEST-NAME
  40
  41 The reason for a test can also be specified, by adding a hash sign (#) and the reason
  42 after the test name.
  43
  44 =head1 LICENSE
  45
  46 selftest is licensed under the GNU General Public License L<http://www.gnu.org/licenses/gpl.html>.
  47
  48
  49 =head1 AUTHOR
  50
  51 Jelmer Vernooij
  52
  53 =cut
  54
  55
  56 use Getopt::Long;
  57 use strict;
  58 use FindBin qw($RealBin $Script);
  59 use lib "$RealBin";
  60 use Subunit qw(parse_results);
  61
  62 my $opt_expected_failures = undef;
  63 my $opt_help = 0;
  64 my $opt_prefix = undef;
  65 my @expected_failures = ();
  66
  67 my $result = GetOptions(
  68                 'expected-failures=s' => \$opt_expected_failures,
  69                 'prefix=s' => \$opt_prefix,
  70                 'help' => \$opt_help,
  71         );
  72 exit(1) if (not $result);
  73
  74 if ($opt_help) {
  75         print "Usage: filter-subunit [--prefix=PREFIX] [--expected-failures=FILE]... < instream > outstream\n";
  76         exit(0);
  77 }
  78
  79 sub read_test_regexes($)
  80 {
  81         my ($name) = @_;
  82         my @ret = ();
  83         open(LF, "<$name") or die("unable to read $name: $!");
  84         while (<LF>) {
  85                 chomp;
  86                 next if (/^#/);
  87                 if (/^(.*?)([ \t]+)\#([\t ]*)(.*?)$/) {
  88                         push (@ret, [$1, $4]);
  89                 } else {
  90                         s/^(.*?)([ \t]+)\#([\t ]*)(.*?)$//;
  91                         push (@ret, [$_, undef]);
  92                 }
  93         }
  94         close(LF);
  95         return @ret;
  96 }
  97
  98 if (defined($opt_expected_failures)) {
  99         @expected_failures = read_test_regexes($opt_expected_failures);
 100 }
 101
 102 sub find_in_list($$)
 103 {
 104         my ($list, $fullname) = @_;
 105
 106         foreach (@$list) {
 107                 if ($fullname =~ /$$_[0]/) {
 108                          return ($$_[1]) if ($$_[1]);
 109                          return "NO REASON SPECIFIED";
 110                 }
 111         }
 112
 113         return undef;
 114 }
 115
 116 sub expecting_failure($)
 117 {
 118         my ($name) = @_;
 119         return find_in_list(\@expected_failures, $name);
 120 }
 121
 122 my $statistics = {
 123         SUITES_FAIL => 0,
 124
 125         TESTS_UNEXPECTED_OK => 0,
 126         TESTS_EXPECTED_OK => 0,
 127         TESTS_UNEXPECTED_FAIL => 0,
 128         TESTS_EXPECTED_FAIL => 0,
 129         TESTS_ERROR => 0,
 130         TESTS_SKIP => 0,
 131 };
 132
 133 sub control_msg()
 134 {
 135         # We regenerate control messages, so ignore this
 136 }
 137
 138 sub report_time($$)
 139 {
 140         my ($self, $time) = @_;
 141         Subunit::report_time($time);
 142 }
 143
 144 sub output_msg($$)
 145 {
 146         my ($self, $msg) = @_;
 147         print $msg;
 148 }
 149
 150 sub start_test($$)
 151 {
 152         my ($self, $testname) = @_;
 153
 154         if (defined($opt_prefix)) {
 155                 $testname = $opt_prefix.$testname;
 156         }
 157
 158         Subunit::start_test($testname);
 159 }
 160
 161 sub end_test($$$$$)
 162 {
 163         my ($self, $testname, $result, $unexpected, $reason) = @_;
 164
 165         if (defined($opt_prefix)) {
 166                 $testname = $opt_prefix.$testname;
 167         }
 168
 169         if (($result eq "fail" or $result eq "failure") and not $unexpected) { $result = "xfail"; }
 170         if (expecting_failure($testname) and ($result eq "fail" or $result eq "failure")) {
 171                 $result = "xfail";
 172         }
 173
 174         Subunit::end_test($testname, $result, $reason);
 175 }
 176
 177 sub skip_testsuite($;$)
 178 {
 179         Subunit::skip_testsuite(@_);
 180 }
 181
 182 sub start_testsuite($;$)
 183 {
 184         my ($self, $name) = @_;
 185         Subunit::start_testsuite($name);
 186 }
 187
 188 sub end_testsuite($$;$)
 189 {
 190         my ($self, $name, $result, $reason) = @_;
 191         Subunit::end_testsuite($name, $result, $reason);
 192 }
 193
 194 sub testsuite_count($$)
 195 {
 196         my ($self, $count) = @_;
 197         Subunit::testsuite_count($count);
 198 }
 199
 200 my $msg_ops = {};
 201 bless $msg_ops;
 202
 203 parse_results($msg_ops, $statistics, *STDIN, []);
 204
 205 0;