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: