selftest: Fix subunit stream to include the right prefixes rather than
[samba.git] / 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, $parents, $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, $parents, $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 my $msg_ops = {};
178 bless $msg_ops;
179
180 parse_results($msg_ops, $statistics, *STDIN, []);
181
182 0;