]> git.proxmox.com Git - mirror_qemu.git/blob - scripts/tap-driver.pl
Merge remote-tracking branch 'remotes/kevin/tags/for-upstream' into staging
[mirror_qemu.git] / scripts / tap-driver.pl
1 #! /usr/bin/env perl
2 # Copyright (C) 2011-2013 Free Software Foundation, Inc.
3 # Copyright (C) 2018 Red Hat, Inc.
4 #
5 # This program is free software; you can redistribute it and/or modify
6 # it under the terms of the GNU General Public License as published by
7 # the Free Software Foundation; either version 2, or (at your option)
8 # any later version.
9 #
10 # This program is distributed in the hope that it will be useful,
11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 # GNU General Public License for more details.
14 #
15 # You should have received a copy of the GNU General Public License
16 # along with this program. If not, see <https://www.gnu.org/licenses/>.
17
18 # As a special exception to the GNU General Public License, if you
19 # distribute this file as part of a program that contains a
20 # configuration script generated by Autoconf, you may include it under
21 # the same distribution terms that you use for the rest of that program.
22
23 # ---------------------------------- #
24 # Imports, static data, and setup. #
25 # ---------------------------------- #
26
27 use warnings FATAL => 'all';
28 use strict;
29 use Getopt::Long ();
30 use TAP::Parser;
31 use Term::ANSIColor qw(:constants);
32
33 my $ME = "tap-driver.pl";
34 my $VERSION = "2018-11-30";
35
36 my $USAGE = <<'END';
37 Usage:
38 tap-driver [--test-name=TEST] [--color={always|never|auto}]
39 [--verbose] [--show-failures-only]
40 END
41
42 my $HELP = "$ME: TAP-aware test driver for QEMU testsuite harness." .
43 "\n" . $USAGE;
44
45 # It's important that NO_PLAN evaluates "false" as a boolean.
46 use constant NO_PLAN => 0;
47 use constant EARLY_PLAN => 1;
48 use constant LATE_PLAN => 2;
49
50 use constant DIAG_STRING => "#";
51
52 # ------------------- #
53 # Global variables. #
54 # ------------------- #
55
56 my $testno = 0; # Number of test results seen so far.
57 my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
58 my $failed = 0; # Final exit code
59
60 # Whether the TAP plan has been seen or not, and if yes, which kind
61 # it is ("early" is seen before any test result, "late" otherwise).
62 my $plan_seen = NO_PLAN;
63
64 # ----------------- #
65 # Option parsing. #
66 # ----------------- #
67
68 my %cfg = (
69 "color" => 0,
70 "verbose" => 0,
71 "show-failures-only" => 0,
72 );
73
74 my $color = "auto";
75 my $test_name = undef;
76
77 # Perl's Getopt::Long allows options to take optional arguments after a space.
78 # Prevent --color by itself from consuming other arguments
79 foreach (@ARGV) {
80 if ($_ eq "--color" || $_ eq "-color") {
81 $_ = "--color=$color";
82 }
83 }
84
85 Getopt::Long::GetOptions
86 (
87 'help' => sub { print $HELP; exit 0; },
88 'version' => sub { print "$ME $VERSION\n"; exit 0; },
89 'test-name=s' => \$test_name,
90 'color=s' => \$color,
91 'show-failures-only' => sub { $cfg{"show-failures-only"} = 1; },
92 'verbose' => sub { $cfg{"verbose"} = 1; },
93 ) or exit 1;
94
95 if ($color =~ /^always$/i) {
96 $cfg{'color'} = 1;
97 } elsif ($color =~ /^never$/i) {
98 $cfg{'color'} = 0;
99 } elsif ($color =~ /^auto$/i) {
100 $cfg{'color'} = (-t STDOUT);
101 } else {
102 die "Invalid color mode: $color\n";
103 }
104
105 # ------------- #
106 # Prototypes. #
107 # ------------- #
108
109 sub colored ($$);
110 sub decorate_result ($);
111 sub extract_tap_comment ($);
112 sub handle_tap_bailout ($);
113 sub handle_tap_plan ($);
114 sub handle_tap_result ($);
115 sub is_null_string ($);
116 sub main ();
117 sub report ($;$);
118 sub stringify_result_obj ($);
119 sub testsuite_error ($);
120
121 # -------------- #
122 # Subroutines. #
123 # -------------- #
124
125 # If the given string is undefined or empty, return true, otherwise
126 # return false. This function is useful to avoid pitfalls like:
127 # if ($message) { print "$message\n"; }
128 # which wouldn't print anything if $message is the literal "0".
129 sub is_null_string ($)
130 {
131 my $str = shift;
132 return ! (defined $str and length $str);
133 }
134
135 sub stringify_result_obj ($)
136 {
137 my $result_obj = shift;
138 if ($result_obj->is_unplanned || $result_obj->number != $testno)
139 {
140 return "ERROR";
141 }
142 elsif ($plan_seen == LATE_PLAN)
143 {
144 return "ERROR";
145 }
146 elsif (!$result_obj->directive)
147 {
148 return $result_obj->is_ok ? "PASS" : "FAIL";
149 }
150 elsif ($result_obj->has_todo)
151 {
152 return $result_obj->is_actual_ok ? "XPASS" : "XFAIL";
153 }
154 elsif ($result_obj->has_skip)
155 {
156 return $result_obj->is_ok ? "SKIP" : "FAIL";
157 }
158 die "$ME: INTERNAL ERROR"; # NOTREACHED
159 }
160
161 sub colored ($$)
162 {
163 my ($color_string, $text) = @_;
164 return $color_string . $text . RESET;
165 }
166
167 sub decorate_result ($)
168 {
169 my $result = shift;
170 return $result unless $cfg{"color"};
171 my %color_for_result =
172 (
173 "ERROR" => BOLD.MAGENTA,
174 "PASS" => GREEN,
175 "XPASS" => BOLD.YELLOW,
176 "FAIL" => BOLD.RED,
177 "XFAIL" => YELLOW,
178 "SKIP" => BLUE,
179 );
180 if (my $color = $color_for_result{$result})
181 {
182 return colored ($color, $result);
183 }
184 else
185 {
186 return $result; # Don't colorize unknown stuff.
187 }
188 }
189
190 sub report ($;$)
191 {
192 my ($msg, $result, $explanation) = (undef, @_);
193 if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
194 {
195 # Output on console might be colorized.
196 $msg = decorate_result($result);
197 if ($result =~ /^(?:PASS|XFAIL|SKIP)/)
198 {
199 return if $cfg{"show-failures-only"};
200 }
201 else
202 {
203 $failed = 1;
204 }
205 }
206 elsif ($result eq "#")
207 {
208 $msg = " ";
209 }
210 else
211 {
212 die "$ME: INTERNAL ERROR"; # NOTREACHED
213 }
214 $msg .= " $explanation" if defined $explanation;
215 print $msg . "\n";
216 }
217
218 sub testsuite_error ($)
219 {
220 report "ERROR", "- $_[0]";
221 }
222
223 sub handle_tap_result ($)
224 {
225 $testno++;
226 my $result_obj = shift;
227
228 my $test_result = stringify_result_obj $result_obj;
229 my $string = $result_obj->number;
230
231 my $description = $result_obj->description;
232 $string .= " $test_name" unless is_null_string $test_name;
233 $string .= " $description" unless is_null_string $description;
234
235 if ($plan_seen == LATE_PLAN)
236 {
237 $string .= " # AFTER LATE PLAN";
238 }
239 elsif ($result_obj->is_unplanned)
240 {
241 $string .= " # UNPLANNED";
242 }
243 elsif ($result_obj->number != $testno)
244 {
245 $string .= " # OUT-OF-ORDER (expecting $testno)";
246 }
247 elsif (my $directive = $result_obj->directive)
248 {
249 $string .= " # $directive";
250 my $explanation = $result_obj->explanation;
251 $string .= " $explanation"
252 unless is_null_string $explanation;
253 }
254
255 report $test_result, $string;
256 }
257
258 sub handle_tap_plan ($)
259 {
260 my $plan = shift;
261 if ($plan_seen)
262 {
263 # Error, only one plan per stream is acceptable.
264 testsuite_error "multiple test plans";
265 return;
266 }
267 # The TAP plan can come before or after *all* the TAP results; we speak
268 # respectively of an "early" or a "late" plan. If we see the plan line
269 # after at least one TAP result has been seen, assume we have a late
270 # plan; in this case, any further test result seen after the plan will
271 # be flagged as an error.
272 $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN);
273 # If $testno > 0, we have an error ("too many tests run") that will be
274 # automatically dealt with later, so don't worry about it here. If
275 # $plan_seen is true, we have an error due to a repeated plan, and that
276 # has already been dealt with above. Otherwise, we have a valid "plan
277 # with SKIP" specification, and should report it as a particular kind
278 # of SKIP result.
279 if ($plan->directive && $testno == 0)
280 {
281 my $explanation = is_null_string ($plan->explanation) ?
282 undef : "- " . $plan->explanation;
283 report "SKIP", $explanation;
284 }
285 }
286
287 sub handle_tap_bailout ($)
288 {
289 my ($bailout, $msg) = ($_[0], "Bail out!");
290 $bailed_out = 1;
291 $msg .= " " . $bailout->explanation
292 unless is_null_string $bailout->explanation;
293 testsuite_error $msg;
294 }
295
296 sub extract_tap_comment ($)
297 {
298 my $line = shift;
299 if (index ($line, DIAG_STRING) == 0)
300 {
301 # Strip leading `DIAG_STRING' from `$line'.
302 $line = substr ($line, length (DIAG_STRING));
303 # And strip any leading and trailing whitespace left.
304 $line =~ s/(?:^\s*|\s*$)//g;
305 # Return what is left (if any).
306 return $line;
307 }
308 return "";
309 }
310
311 sub main ()
312 {
313 my $iterator = TAP::Parser::Iterator::Stream->new(\*STDIN);
314 my $parser = TAP::Parser->new ({iterator => $iterator });
315
316 STDOUT->autoflush(1);
317 while (defined (my $cur = $parser->next))
318 {
319 # Parsing of TAP input should stop after a "Bail out!" directive.
320 next if $bailed_out;
321
322 if ($cur->is_plan)
323 {
324 handle_tap_plan ($cur);
325 }
326 elsif ($cur->is_test)
327 {
328 handle_tap_result ($cur);
329 }
330 elsif ($cur->is_bailout)
331 {
332 handle_tap_bailout ($cur);
333 }
334 elsif ($cfg{"verbose"})
335 {
336 my $comment = extract_tap_comment ($cur->raw);
337 report "#", "$comment" if length $comment;
338 }
339 }
340 # A "Bail out!" directive should cause us to ignore any following TAP
341 # error.
342 if (!$bailed_out)
343 {
344 if (!$plan_seen)
345 {
346 testsuite_error "missing test plan";
347 }
348 elsif ($parser->tests_planned != $parser->tests_run)
349 {
350 my ($planned, $run) = ($parser->tests_planned, $parser->tests_run);
351 my $bad_amount = $run > $planned ? "many" : "few";
352 testsuite_error (sprintf "too %s tests run (expected %d, got %d)",
353 $bad_amount, $planned, $run);
354 }
355 }
356 }
357
358 # ----------- #
359 # Main code. #
360 # ----------- #
361
362 main;
363 exit($failed);
364
365 # Local Variables:
366 # perl-indent-level: 2
367 # perl-continued-statement-offset: 2
368 # perl-continued-brace-offset: 0
369 # perl-brace-offset: 0
370 # perl-brace-imaginary-offset: 0
371 # perl-label-offset: -2
372 # cperl-indent-level: 2
373 # cperl-brace-offset: 0
374 # cperl-continued-brace-offset: 0
375 # cperl-label-offset: -2
376 # cperl-extra-newline-before-brace: t
377 # cperl-merge-trailing-else: nil
378 # cperl-continued-statement-offset: 2
379 # End: