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
27use warnings FATAL => 'all';
28use strict;
29use Getopt::Long ();
30use TAP::Parser;
31use Term::ANSIColor qw(:constants);
32
33my $ME = "tap-driver.pl";
34my $VERSION = "2018-11-30";
35
36my $USAGE = <<'END';
37Usage:
38  tap-driver [--test-name=TEST] [--color={always|never|auto}]
39             [--verbose] [--show-failures-only]
40END
41
42my $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.
46use constant NO_PLAN => 0;
47use constant EARLY_PLAN => 1;
48use constant LATE_PLAN => 2;
49
50use constant DIAG_STRING => "#";
51
52# ------------------- #
53#  Global variables.  #
54# ------------------- #
55
56my $testno = 0;     # Number of test results seen so far.
57my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
58my $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).
62my $plan_seen = NO_PLAN;
63
64# ----------------- #
65#  Option parsing.  #
66# ----------------- #
67
68my %cfg = (
69  "color" => 0,
70  "verbose" => 0,
71  "show-failures-only" => 0,
72);
73
74my $color = "auto";
75my $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
79foreach (@ARGV) {
80  if ($_ eq "--color" || $_ eq "-color") {
81    $_ = "--color=$color";
82  }
83}
84
85Getopt::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
95if ($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
109sub colored ($$);
110sub decorate_result ($);
111sub extract_tap_comment ($);
112sub handle_tap_bailout ($);
113sub handle_tap_plan ($);
114sub handle_tap_result ($);
115sub is_null_string ($);
116sub main ();
117sub report ($;$);
118sub stringify_result_obj ($);
119sub 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".
129sub is_null_string ($)
130{
131  my $str = shift;
132  return ! (defined $str and length $str);
133}
134
135sub 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
161sub colored ($$)
162{
163  my ($color_string, $text) = @_;
164  return $color_string . $text . RESET;
165}
166
167sub 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
190sub 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
218sub testsuite_error ($)
219{
220  report "ERROR", "$test_name - $_[0]";
221}
222
223sub 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
258sub 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
287sub 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
296sub 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
311sub 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
362main;
363exit($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:
380