lib/tap-driver.pl

   1 #! /usr/bin/env perl
   2 # Temporary/experimental TAP test driver for Automake.
   3 # TODO: should be rewritten portably (e.g., in awk or shell).
   4
   5 # ---------------------------------- #
   6 #  Imports, static data, and setup.  #
   7 # ---------------------------------- #
   8
   9 use warnings FATAL => 'all';
  10 use strict;
  11 use Getopt::Long ();
  12 use TAP::Parser;
  13
  14 my $ME = "tap-driver.pl";
  15
  16 my $USAGE = <<'END';
  17 Usage:
  18   tap-driver --test-name=NAME --log-file=PATH --trs-file=PATH
  19              [--expect-failure={yes|no}] [--color-tests={yes|no}]
  20              [--enable-hard-errors={yes|no}] [--ignore-exit]
  21              [--diagnostic-string=STRING] [--merge|--no-merge]
  22              [--comments|--no-comments] [--] TEST-COMMAND
  23 The `--test-name', `--log-file' and `--trs-file' options are mandatory.
  24 END
  25
  26 my $HELP = "$ME: TAP-aware test driver for Automake testsuite harness." .
  27            "\n" . $USAGE;
  28
  29 my $VERSION = '(experimental version)';
  30
  31 # Keep this in sync with `lib/am/check.am:$(am__tty_colors)'.
  32 my %COLOR = (
  33   red => "\e[0;31m",
  34   grn => "\e[0;32m",
  35   lgn => "\e[1;32m",
  36   blu => "\e[1;34m",
  37   mgn => "\e[0;35m",
  38   brg => "\e[1m",
  39   std => "\e[m",
  40 );
  41
  42 # It's important that NO_PLAN evaluates "false" as a boolean.
  43 use constant NO_PLAN => 0;
  44 use constant EARLY_PLAN => 1;
  45 use constant LATE_PLAN => 2;
  46
  47 # ------------------- #
  48 #  Global variables.  #
  49 # ------------------- #
  50
  51 my $testno = 0;     # Number of test results seen so far.
  52 my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
  53 my $parser;         # TAP parser object (will be initialized later).
  54
  55 # Whether the TAP plan has been seen or not, and if yes, which kind
  56 # it is ("early" is seen before any test result, "late" otherwise).
  57 my $plan_seen = NO_PLAN;
  58
  59 # ----------------- #
  60 #  Option parsing.  #
  61 # ----------------- #
  62
  63 my %cfg = (
  64   "color-tests" => 0,
  65   "expect-failure" => 0,
  66   "merge" => 0,
  67   "comments" => 0,
  68   "ignore-exit" => 0,
  69 );
  70
  71 my $test_script_name = undef;
  72 my $log_file = undef;
  73 my $trs_file = undef;
  74 my $diag_string = "#";
  75
  76 Getopt::Long::GetOptions
  77   (
  78     'help' => sub { print $HELP; exit 0; },
  79     'version' => sub { print "$ME $VERSION\n"; exit 0; },
  80     'test-name=s' => \$test_script_name,
  81     'log-file=s' => \$log_file,
  82     'trs-file=s' => \$trs_file,
  83     'color-tests=s'  => \&bool_opt,
  84     'expect-failure=s'  => \&bool_opt,
  85     'enable-hard-errors=s' => sub {}, # No-op.
  86     'diagnostic-string=s' => \$diag_string,
  87     'comments' => sub { $cfg{"comments"} = 1; },
  88     'no-comments' => sub { $cfg{"comments"} = 0; },
  89     'merge' => sub { $cfg{"merge"} = 1; },
  90     'no-merge' => sub { $cfg{"merge"} = 0; },
  91     'ignore-exit' => sub { $cfg{"ignore-exit"} = 1; },
  92   ) or exit 1;
  93
  94 # ------------- #
  95 #  Prototypes.  #
  96 # ------------- #
  97
  98 sub add_test_result ($);
  99 sub bool_opt ($$);
 100 sub colored ($$);
 101 sub copy_in_global_log ();
 102 sub decorate_result ($);
 103 sub extract_tap_comment ($);
 104 sub get_global_test_result ();
 105 sub get_test_exit_message ();
 106 sub get_test_results ();
 107 sub handle_tap_bailout ($);
 108 sub handle_tap_plan ($);
 109 sub handle_tap_test ($);
 110 sub is_null_string ($);
 111 sub main (@);
 112 sub must_recheck ();
 113 sub report ($;$);
 114 sub start (@);
 115 sub stringify_test_result ($);
 116 sub testsuite_error ($);
 117 sub write_test_results ();
 118 sub yn ($);
 119
 120 # -------------- #
 121 #  Subroutines.  #
 122 # -------------- #
 123
 124 sub bool_opt ($$)
 125 {
 126   my ($opt, $val) = @_;
 127   if ($val =~ /^(?:y|yes)\z/i)
 128     {
 129       $cfg{$opt} = 1;
 130     }
 131   elsif ($val =~ /^(?:n|no)\z/i)
 132     {
 133       $cfg{$opt} = 0;
 134     }
 135   else
 136     {
 137       die "invalid argument '$val' for option '$opt'\n";
 138     }
 139 }
 140
 141 # If the given string is undefined or empty, return true, otherwise
 142 # return false.  This function is useful to avoid pitfalls like:
 143 #   if ($message) { print "$message\n"; }
 144 # which wouldn't print anything if $message is the literal "0".
 145 sub is_null_string ($)
 146 {
 147   my $str = shift;
 148   return ! (defined $str and length $str);
 149 }
 150
 151 # Convert a boolean to a "yes"/"no" string.
 152 sub yn ($)
 153 {
 154   my $bool = shift;
 155   return $bool ? "yes" : "no";
 156 }
 157
 158 TEST_RESULTS :
 159 {
 160   my (@test_results, %test_results);
 161
 162   sub add_test_result ($)
 163   {
 164     my $res = shift;
 165     push @test_results, $res;
 166     $test_results{$res} = 1;
 167   }
 168
 169   sub get_test_results ()
 170   {
 171     return @test_results;
 172   }
 173
 174   # Whether the test script should be re-run by "make recheck".
 175   sub must_recheck ()
 176   {
 177     return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results);
 178   }
 179
 180   # Whether the content of the log file associated to this test should
 181   # be copied into the "global" test-suite.log.
 182   sub copy_in_global_log ()
 183   {
 184     return grep { not $_ eq "PASS" } (keys %test_results);
 185   }
 186
 187   # FIXME: this can certainly be improved ...
 188   sub get_global_test_result ()
 189   {
 190     my @results = keys %test_results;
 191     return "ERROR" if exists $test_results{"ERROR"};
 192     return "SKIP" if @results == 1 && $results[0] eq "SKIP";
 193     return "FAIL" if exists $test_results{"FAIL"};
 194     return "FAIL" if exists $test_results{"XPASS"};
 195     return "PASS";
 196   }
 197
 198 }
 199
 200 sub write_test_results ()
 201 {
 202   open RES, ">", $trs_file or die "opening $trs_file: $!\n";
 203   print RES ":global-test-result: " . get_global_test_result . "\n";
 204   print RES ":recheck: " . yn (must_recheck) . "\n";
 205   print RES ":copy-in-global-log: " . yn (copy_in_global_log) . "\n";
 206   foreach my $result (get_test_results)
 207     {
 208       print RES ":test-result: $result\n";
 209     }
 210   close RES or die "closing $trs_file: $!\n";
 211 }
 212
 213 sub start (@)
 214 {
 215   # Redirect stderr and stdout to a temporary log file.  Save the
 216   # original stdout stream, since we need it to print testsuite
 217   # progress output.
 218   open LOG, ">", $log_file or die "opening $log_file: $!\n";
 219   open OLDOUT, ">&STDOUT" or die "duplicating stdout: $!\n";
 220   open STDOUT, ">&LOG" or die "redirecting stdout: $!\n";
 221   open STDERR, ">&LOG" or die "redirecting stderr: $!\n";
 222   $parser = TAP::Parser->new ({ exec => \@_, merge => $cfg{merge} });
 223   $parser->ignore_exit(1) if $cfg{"ignore-exit"};
 224 }
 225
 226 sub get_test_exit_message ()
 227 {
 228   my $wstatus = $parser->wait;
 229   # Watch out for possible internal errors.
 230   die "couldn't get the exit ststus of the TAP producer"
 231     unless defined $wstatus;
 232   # Return an undefined value if the producer exited with success.
 233   return unless $wstatus;
 234   # Otherwise, determine whether it exited with error or was terminated
 235   # by a signal.
 236   use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
 237   if (WIFEXITED ($wstatus))
 238         {
 239       return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
 240         }
 241   elsif (WIFSIGNALED ($wstatus))
 242         {
 243       return sprintf "terminated by signal %d", WTERMSIG ($wstatus);
 244         }
 245   else
 246         {
 247           return "terminated abnormally";
 248         }
 249 }
 250
 251 sub stringify_test_result ($)
 252 {
 253   my $result = shift;
 254   my $PASS = $cfg{"expect-failure"} ? "XPASS": "PASS";
 255   my $FAIL = $cfg{"expect-failure"} ? "XFAIL": "FAIL";
 256   if ($result->is_unplanned
 257        || $result->number != $testno
 258        || $plan_seen == LATE_PLAN)
 259     {
 260       return "ERROR";
 261     }
 262   elsif (!$result->directive)
 263     {
 264       return $result->is_ok ? $PASS: $FAIL;
 265     }
 266   elsif ($result->has_todo)
 267     {
 268       return $result->is_actual_ok ? "XPASS" : "XFAIL";
 269     }
 270   elsif ($result->has_skip)
 271     {
 272       return $result->is_ok ? "SKIP" : $FAIL;
 273     }
 274   die "INTERNAL ERROR"; # NOTREACHED
 275 }
 276
 277 sub colored ($$)
 278 {
 279   my ($color_name, $text) = @_;
 280   return  $COLOR{$color_name} . $text . $COLOR{'std'};
 281 }
 282
 283 sub decorate_result ($)
 284 {
 285   my $result = shift;
 286   return $result unless $cfg{"color-tests"};
 287   my %color_for_result =
 288     (
 289       "ERROR" => 'mgn',
 290       "PASS"  => 'grn',
 291       "XPASS" => 'red',
 292       "FAIL"  => 'red',
 293       "XFAIL" => 'lgn',
 294       "SKIP"  => 'blu',
 295     );
 296   if (my $color = $color_for_result{$result})
 297     {
 298       return colored ($color, $result);
 299     }
 300   else
 301     {
 302       return $result; # Don't colorize unknown stuff.
 303     }
 304 }
 305
 306 sub report ($;$)
 307 {
 308   my ($msg, $result, $explanation) = (undef, @_);
 309   if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
 310     {
 311       $msg = ": $test_script_name";
 312       add_test_result $result;
 313     }
 314   elsif ($result eq "#")
 315     {
 316       $msg = " $test_script_name:";
 317     }
 318   else
 319     {
 320       die "INTERNAL ERROR"; # NOTREACHED
 321     }
 322   $msg .= " $explanation" if defined $explanation;
 323   $msg .= "\n";
 324   # Output on console might be colorized.
 325   print OLDOUT decorate_result ($result) . $msg;
 326   # Log the result in the log file too, to help debugging (this is
 327   # especially true when said result is a TAP error or "Bail out!").
 328   print $result . $msg;
 329 }
 330
 331 sub testsuite_error ($)
 332 {
 333   report "ERROR", "- $_[0]";
 334 }
 335
 336 sub handle_tap_test ($)
 337 {
 338   $testno++;
 339   my $test = shift;
 340
 341   my $test_result = stringify_test_result $test;
 342   my $string = $test->number;
 343
 344   my $description = $test->description;
 345   $string .= " $description"
 346     unless is_null_string $description;
 347
 348   if ($plan_seen == LATE_PLAN)
 349     {
 350       $string .= " # AFTER LATE PLAN";
 351     }
 352   elsif ($test->is_unplanned)
 353     {
 354       $string .= " # UNPLANNED";
 355     }
 356   elsif ($test->number != $testno)
 357     {
 358       $string .= " # OUT-OF-ORDER (expecting $testno)";
 359     }
 360   elsif (my $directive = $test->directive)
 361     {
 362       $string .= " # $directive";
 363       my $explanation = $test->explanation;
 364       $string .= " $explanation"
 365         unless is_null_string $explanation;
 366     }
 367
 368   report $test_result, $string;
 369 }
 370
 371 sub handle_tap_plan ($)
 372 {
 373   my $plan = shift;
 374   if ($plan_seen)
 375     {
 376       # Error, only one plan per stream is acceptable.
 377       testsuite_error "multiple test plans";
 378       return;
 379     }
 380   # The TAP plan can come before or after *all* the TAP results; we speak
 381   # respectively of an "early" or a "late" plan.  If we see the plan line
 382   # after at least one TAP result has been seen, assume we have a late
 383   # plan; in this case, any further test result seen after the plan will
 384   # be flagged as an error.
 385   $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN);
 386   # If $testno > 0, we have an error ("too many tests run") that will be
 387   # automatically dealt with later, so don't worry about it here.  If
 388   # $plan_seen is true, we have an error due to a repeated plan, and that
 389   # has already been dealt with above.  Otherwise, we have a valid "plan
 390   # with SKIP" specification, and should report it as a particular kind
 391   # of SKIP result.
 392   if ($plan->directive && $testno == 0)
 393     {
 394       my $explanation = is_null_string ($plan->explanation) ?
 395                         undef : "- " . $plan->explanation;
 396       report "SKIP", $explanation;
 397     }
 398 }
 399
 400 sub handle_tap_bailout ($)
 401 {
 402   my ($bailout, $msg) = ($_[0], "Bail out!");
 403   $bailed_out = 1;
 404   $msg .= " " . $bailout->explanation
 405     unless is_null_string $bailout->explanation;
 406   testsuite_error $msg;
 407 }
 408
 409 sub extract_tap_comment ($)
 410 {
 411   local $_ = shift;
 412   if (/^\Q$diag_string\E(.*)$/o)
 413     {
 414       (my $comment = $1) =~ s/(?:^\s*|\s*$)//g;
 415       return $comment;
 416     }
 417   return "";
 418 }
 419
 420 sub main (@)
 421 {
 422   start @_;
 423
 424   while (defined (my $cur = $parser->next))
 425     {
 426       # Verbatim copy any input line into the log file.
 427       print $cur->raw . "\n";
 428       # Parsing of TAP input should stop after a "Bail out!" directive.
 429       next if $bailed_out;
 430
 431       if ($cur->is_plan)
 432         {
 433           handle_tap_plan ($cur);
 434         }
 435       elsif ($cur->is_test)
 436         {
 437           handle_tap_test ($cur);
 438         }
 439       elsif ($cur->is_bailout)
 440         {
 441           handle_tap_bailout ($cur);
 442         }
 443       elsif ($cfg{comments})
 444         {
 445           my $comment = extract_tap_comment ($cur->raw);
 446           report "#", "$comment" if length $comment;
 447        }
 448     }
 449   # A "Bail out!" directive should cause us to ignore any following TAP
 450   # error, as well as a non-zero exit status from the TAP producer.
 451   if (!$bailed_out)
 452     {
 453       if (!$plan_seen)
 454         {
 455           testsuite_error "missing test plan";
 456         }
 457       elsif ($parser->tests_planned != $parser->tests_run)
 458         {
 459           my ($planned, $run) = ($parser->tests_planned, $parser->tests_run);
 460           my $bad_amount = $run > $planned ? "many" : "few";
 461           testsuite_error (sprintf "too %s tests run (expected %d, got %d)",
 462                                    $bad_amount, $planned, $run);
 463         }
 464     }
 465   if (!$cfg{"ignore-exit"} && !$bailed_out)
 466     {
 467       my $msg = get_test_exit_message ();
 468       testsuite_error $msg if $msg;
 469     }
 470   write_test_results;
 471   close LOG or die "closing $log_file: $!\n";
 472   exit 0;
 473 }
 474
 475 # ----------- #
 476 #  Main code. #
 477 # ----------- #
 478
 479 main @ARGV;
 480
 481 # vim: ft=perl ts=4 sw=4 et