2 # Temporary/experimental TAP test driver for Automake.
3 # TODO: should be rewritten portably (e.g., in awk or shell).
5 # ---------------------------------- #
6 # Imports, static data, and setup. #
7 # ---------------------------------- #
9 use warnings FATAL => 'all';
14 my $ME = "tap-driver.pl";
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.
26 my $HELP = "$ME: TAP-aware test driver for Automake testsuite harness." .
29 my $VERSION = '(experimental version)';
31 # Keep this in sync with `lib/am/check.am:$(am__tty_colors)'.
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;
47 # ------------------- #
49 # ------------------- #
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).
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;
65 "expect-failure" => 0,
71 my $test_script_name = undef;
74 my $diag_string = "#";
76 Getopt::Long::GetOptions
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; },
98 sub add_test_result ($);
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 ($);
115 sub stringify_test_result ($);
116 sub testsuite_error ($);
117 sub write_test_results ();
126 my ($opt, $val) = @_;
127 if ($val =~ /^(?:y|yes)\z/i)
131 elsif ($val =~ /^(?:n|no)\z/i)
137 die "invalid argument '$val' for option '$opt'\n";
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 ($)
148 return ! (defined $str and length $str);
151 # Convert a boolean to a "yes"/"no" string.
155 return $bool ? "yes" : "no";
160 my (@test_results, %test_results);
162 sub add_test_result ($)
165 push @test_results, $res;
166 $test_results{$res} = 1;
169 sub get_test_results ()
171 return @test_results;
174 # Whether the test script should be re-run by "make recheck".
177 return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results);
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 ()
184 return grep { not $_ eq "PASS" } (keys %test_results);
187 # FIXME: this can certainly be improved ...
188 sub get_global_test_result ()
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"};
200 sub write_test_results ()
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)
208 print RES ":test-result: $result\n";
210 close RES or die "closing $trs_file: $!\n";
215 # Redirect stderr and stdout to a temporary log file. Save the
216 # original stdout stream, since we need it to print testsuite
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"};
226 sub get_test_exit_message ()
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
236 use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
237 if (WIFEXITED ($wstatus))
239 return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
241 elsif (WIFSIGNALED ($wstatus))
243 return sprintf "terminated by signal %d", WTERMSIG ($wstatus);
247 return "terminated abnormally";
251 sub stringify_test_result ($)
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)
262 elsif (!$result->directive)
264 return $result->is_ok ? $PASS: $FAIL;
266 elsif ($result->has_todo)
268 return $result->is_actual_ok ? "XPASS" : "XFAIL";
270 elsif ($result->has_skip)
272 return $result->is_ok ? "SKIP" : $FAIL;
274 die "INTERNAL ERROR"; # NOTREACHED
279 my ($color_name, $text) = @_;
280 return $COLOR{$color_name} . $text . $COLOR{'std'};
283 sub decorate_result ($)
286 return $result unless $cfg{"color-tests"};
287 my %color_for_result =
296 if (my $color = $color_for_result{$result})
298 return colored ($color, $result);
302 return $result; # Don't colorize unknown stuff.
308 my ($msg, $result, $explanation) = (undef, @_);
309 if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
311 $msg = ": $test_script_name";
312 add_test_result $result;
314 elsif ($result eq "#")
316 $msg = " $test_script_name:";
320 die "INTERNAL ERROR"; # NOTREACHED
322 $msg .= " $explanation" if defined $explanation;
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;
331 sub testsuite_error ($)
333 report "ERROR", "- $_[0]";
336 sub handle_tap_test ($)
341 my $test_result = stringify_test_result $test;
342 my $string = $test->number;
344 my $description = $test->description;
345 $string .= " $description"
346 unless is_null_string $description;
348 if ($plan_seen == LATE_PLAN)
350 $string .= " # AFTER LATE PLAN";
352 elsif ($test->is_unplanned)
354 $string .= " # UNPLANNED";
356 elsif ($test->number != $testno)
358 $string .= " # OUT-OF-ORDER (expecting $testno)";
360 elsif (my $directive = $test->directive)
362 $string .= " # $directive";
363 my $explanation = $test->explanation;
364 $string .= " $explanation"
365 unless is_null_string $explanation;
368 report $test_result, $string;
371 sub handle_tap_plan ($)
376 # Error, only one plan per stream is acceptable.
377 testsuite_error "multiple test plans";
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
392 if ($plan->directive && $testno == 0)
394 my $explanation = is_null_string ($plan->explanation) ?
395 undef : "- " . $plan->explanation;
396 report "SKIP", $explanation;
400 sub handle_tap_bailout ($)
402 my ($bailout, $msg) = ($_[0], "Bail out!");
404 $msg .= " " . $bailout->explanation
405 unless is_null_string $bailout->explanation;
406 testsuite_error $msg;
409 sub extract_tap_comment ($)
412 if (/^\Q$diag_string\E(.*)$/o)
414 (my $comment = $1) =~ s/(?:^\s*|\s*$)//g;
424 while (defined (my $cur = $parser->next))
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.
433 handle_tap_plan ($cur);
435 elsif ($cur->is_test)
437 handle_tap_test ($cur);
439 elsif ($cur->is_bailout)
441 handle_tap_bailout ($cur);
443 elsif ($cfg{comments})
445 my $comment = extract_tap_comment ($cur->raw);
446 report "#", "$comment" if length $comment;
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.
455 testsuite_error "missing test plan";
457 elsif ($parser->tests_planned != $parser->tests_run)
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);
465 if (!$cfg{"ignore-exit"} && !$bailed_out)
467 my $msg = get_test_exit_message ();
468 testsuite_error $msg if $msg;
471 close LOG or die "closing $log_file: $!\n";
481 # vim: ft=perl ts=4 sw=4 et