#! /usr/bin/env perl
-# Temporary/experimental TAP test driver for Automake.
-# TODO: should be rewritten portably (e.g., in awk or shell).
+# Copyright (C) 2011-2012 Free Software Foundation, Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2, or (at your option)
+# any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+# As a special exception to the GNU General Public License, if you
+# distribute this file as part of a program that contains a
+# configuration script generated by Autoconf, you may include it under
+# the same distribution terms that you use for the rest of that program.
+
+# This file is maintained in Automake, please report
+# bugs to <bug-automake@gnu.org> or send patches to
+# <automake-patches@gnu.org>.
# ---------------------------------- #
# Imports, static data, and setup. #
use Getopt::Long ();
use TAP::Parser;
+my $VERSION = '2012-02-01.19'; # UTC
+
my $ME = "tap-driver.pl";
my $USAGE = <<'END';
my $HELP = "$ME: TAP-aware test driver for Automake testsuite harness." .
"\n" . $USAGE;
-my $VERSION = '(experimental version)';
-
# Keep this in sync with `lib/am/check.am:$(am__tty_colors)'.
my %COLOR = (
red => "\e[0;31m",
sub copy_in_global_log ();
sub decorate_result ($);
sub extract_tap_comment ($);
+sub finish ();
sub get_global_test_result ();
sub get_test_exit_message ();
sub get_test_results ();
sub handle_tap_bailout ($);
sub handle_tap_plan ($);
-sub handle_tap_test ($);
+sub handle_tap_result ($);
sub is_null_string ($);
sub main (@);
sub must_recheck ();
sub report ($;$);
-sub start (@);
-sub stringify_test_result ($);
+sub setup_io ();
+sub setup_parser (@);
+sub stringify_result_obj ($);
sub testsuite_error ($);
+sub trap_perl_warnings_and_errors ();
sub write_test_results ();
sub yn ($);
}
else
{
- die "invalid argument '$val' for option '$opt'\n";
+ die "$ME: invalid argument '$val' for option '$opt'\n";
}
}
TEST_RESULTS :
{
- my (@test_results, %test_results);
+ my (@test_results_list, %test_results_seen);
sub add_test_result ($)
{
my $res = shift;
- push @test_results, $res;
- $test_results{$res} = 1;
+ push @test_results_list, $res;
+ $test_results_seen{$res} = 1;
}
sub get_test_results ()
{
- return @test_results;
+ return @test_results_list;
}
# Whether the test script should be re-run by "make recheck".
sub must_recheck ()
{
- return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results);
+ return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results_seen);
}
# Whether the content of the log file associated to this test should
# be copied into the "global" test-suite.log.
sub copy_in_global_log ()
{
- return grep { not $_ eq "PASS" } (keys %test_results);
+ return grep { not $_ eq "PASS" } (keys %test_results_seen);
}
# FIXME: this can certainly be improved ...
sub get_global_test_result ()
{
- my @results = keys %test_results;
- return "ERROR" if exists $test_results{"ERROR"};
- return "SKIP" if @results == 1 && $results[0] eq "SKIP";
- return "FAIL" if exists $test_results{"FAIL"};
- return "FAIL" if exists $test_results{"XPASS"};
+ return "ERROR"
+ if $test_results_seen{"ERROR"};
+ return "FAIL"
+ if $test_results_seen{"FAIL"} || $test_results_seen{"XPASS"};
+ return "SKIP"
+ if scalar keys %test_results_seen == 1 && $test_results_seen{"SKIP"};
return "PASS";
}
sub write_test_results ()
{
- open RES, ">", $trs_file or die "opening $trs_file: $!\n";
+ open RES, ">", $trs_file or die "$ME: opening $trs_file: $!\n";
print RES ":global-test-result: " . get_global_test_result . "\n";
print RES ":recheck: " . yn (must_recheck) . "\n";
print RES ":copy-in-global-log: " . yn (copy_in_global_log) . "\n";
{
print RES ":test-result: $result\n";
}
- close RES or die "closing $trs_file: $!\n";
+ close RES or die "$ME: closing $trs_file: $!\n";
}
-sub start (@)
+sub trap_perl_warnings_and_errors ()
+{
+ $SIG{__WARN__} = $SIG{__DIE__} = sub
+ {
+ # Be sure to send the warning/error message to the original stderr
+ # (presumably the console), not into the log file.
+ open STDERR, ">&OLDERR";
+ die @_;
+ }
+}
+
+sub setup_io ()
{
# Redirect stderr and stdout to a temporary log file. Save the
# original stdout stream, since we need it to print testsuite
- # progress output.
- open LOG, ">", $log_file or die "opening $log_file: $!\n";
- open OLDOUT, ">&STDOUT" or die "duplicating stdout: $!\n";
- open STDOUT, ">&LOG" or die "redirecting stdout: $!\n";
- open STDERR, ">&LOG" or die "redirecting stderr: $!\n";
- $parser = TAP::Parser->new ({ exec => \@_, merge => $cfg{merge} });
- $parser->ignore_exit(1) if $cfg{"ignore-exit"};
+ # progress output. Save original stderr stream, so that we can
+ # redirect warning and error messages from perl there.
+ open LOG, ">", $log_file or die "$ME: opening $log_file: $!\n";
+ open OLDOUT, ">&STDOUT" or die "$ME: duplicating stdout: $!\n";
+ open OLDERR, ">&STDERR" or die "$ME: duplicating stdout: $!\n";
+ *OLDERR = *OLDERR; # To pacify a "used only once" warning.
+ trap_perl_warnings_and_errors;
+ open STDOUT, ">&LOG" or die "$ME: redirecting stdout: $!\n";
+ open STDERR, ">&LOG" or die "$ME: redirecting stderr: $!\n";
+}
+
+sub setup_parser (@)
+{
+ local $@ = '';
+ eval { $parser = TAP::Parser->new ({exec => \@_, merge => $cfg{merge}}) };
+ if ($@ ne '')
+ {
+ # Don't use the error message in $@ as set by TAP::Parser, since
+ # currently it's both too generic (at the point of being basically
+ # useless) and quite long.
+ report "ERROR", "- couldn't execute test script";
+ finish;
+ }
}
sub get_test_exit_message ()
{
my $wstatus = $parser->wait;
# Watch out for possible internal errors.
- die "couldn't get the exit ststus of the TAP producer"
+ die "$ME: couldn't get the exit status of the TAP producer"
unless defined $wstatus;
# Return an undefined value if the producer exited with success.
return unless $wstatus;
# by a signal.
use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
if (WIFEXITED ($wstatus))
- {
- return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
- }
+ {
+ return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
+ }
elsif (WIFSIGNALED ($wstatus))
- {
+ {
return sprintf "terminated by signal %d", WTERMSIG ($wstatus);
- }
+ }
else
- {
- return "terminated abnormally";
- }
+ {
+ return "terminated abnormally";
+ }
}
-sub stringify_test_result ($)
+sub stringify_result_obj ($)
{
- my $result = shift;
- my $PASS = $cfg{"expect-failure"} ? "XPASS": "PASS";
- my $FAIL = $cfg{"expect-failure"} ? "XFAIL": "FAIL";
- if ($result->is_unplanned
- || $result->number != $testno
- || $plan_seen == LATE_PLAN)
+ my $result_obj = shift;
+ my $COOKED_PASS = $cfg{"expect-failure"} ? "XPASS": "PASS";
+ my $COOKED_FAIL = $cfg{"expect-failure"} ? "XFAIL": "FAIL";
+ if ($result_obj->is_unplanned || $result_obj->number != $testno)
+ {
+ return "ERROR";
+ }
+ elsif ($plan_seen == LATE_PLAN)
{
return "ERROR";
}
- elsif (!$result->directive)
+ elsif (!$result_obj->directive)
{
- return $result->is_ok ? $PASS: $FAIL;
+ return $result_obj->is_ok ? $COOKED_PASS: $COOKED_FAIL;
}
- elsif ($result->has_todo)
+ elsif ($result_obj->has_todo)
{
- return $result->is_actual_ok ? "XPASS" : "XFAIL";
+ return $result_obj->is_actual_ok ? "XPASS" : "XFAIL";
}
- elsif ($result->has_skip)
+ elsif ($result_obj->has_skip)
{
- return $result->is_ok ? "SKIP" : $FAIL;
+ return $result_obj->is_ok ? "SKIP" : $COOKED_FAIL;
}
- die "INTERNAL ERROR"; # NOTREACHED
+ die "$ME: INTERNAL ERROR"; # NOTREACHED
}
sub colored ($$)
{
my ($color_name, $text) = @_;
- return $COLOR{$color_name} . $text . $COLOR{'std'};
+ return $COLOR{$color_name} . $text . $COLOR{'std'};
}
sub decorate_result ($)
}
else
{
- die "INTERNAL ERROR"; # NOTREACHED
+ die "$ME: INTERNAL ERROR"; # NOTREACHED
}
$msg .= " $explanation" if defined $explanation;
$msg .= "\n";
report "ERROR", "- $_[0]";
}
-sub handle_tap_test ($)
+sub handle_tap_result ($)
{
$testno++;
- my $test = shift;
+ my $result_obj = shift;
- my $test_result = stringify_test_result $test;
- my $string = $test->number;
-
- my $description = $test->description;
+ my $test_result = stringify_result_obj $result_obj;
+ my $string = $result_obj->number;
+
+ my $description = $result_obj->description;
$string .= " $description"
unless is_null_string $description;
{
$string .= " # AFTER LATE PLAN";
}
- elsif ($test->is_unplanned)
+ elsif ($result_obj->is_unplanned)
{
$string .= " # UNPLANNED";
}
- elsif ($test->number != $testno)
+ elsif ($result_obj->number != $testno)
{
$string .= " # OUT-OF-ORDER (expecting $testno)";
}
- elsif (my $directive = $test->directive)
+ elsif (my $directive = $result_obj->directive)
{
$string .= " # $directive";
- my $explanation = $test->explanation;
+ my $explanation = $result_obj->explanation;
$string .= " $explanation"
unless is_null_string $explanation;
}
sub extract_tap_comment ($)
{
- local $_ = shift;
- if (/^\Q$diag_string\E(.*)$/o)
+ my $line = shift;
+ if (index ($line, $diag_string) == 0)
{
- (my $comment = $1) =~ s/(?:^\s*|\s*$)//g;
- return $comment;
+ # Strip leading `$diag_string' from `$line'.
+ $line = substr ($line, length ($diag_string));
+ # And strip any leading and trailing whitespace left.
+ $line =~ s/(?:^\s*|\s*$)//g;
+ # Return what is left (if any).
+ return $line;
}
return "";
}
+sub finish ()
+{
+ write_test_results;
+ close LOG or die "$ME: closing $log_file: $!\n";
+ exit 0;
+}
+
sub main (@)
{
- start @_;
+ setup_io;
+ setup_parser @_;
while (defined (my $cur = $parser->next))
{
}
elsif ($cur->is_test)
{
- handle_tap_test ($cur);
+ handle_tap_result ($cur);
}
elsif ($cur->is_bailout)
{
testsuite_error (sprintf "too %s tests run (expected %d, got %d)",
$bad_amount, $planned, $run);
}
+ if (!$cfg{"ignore-exit"})
+ {
+ my $msg = get_test_exit_message ();
+ testsuite_error $msg if $msg;
+ }
}
- if (!$cfg{"ignore-exit"} && !$bailed_out)
- {
- my $msg = get_test_exit_message ();
- testsuite_error $msg if $msg;
- }
- write_test_results;
- close LOG or die "closing $log_file: $!\n";
- exit 0;
+ finish;
}
# ----------- #
main @ARGV;
-# vim: ft=perl ts=4 sw=4 et
+# Local Variables:
+# perl-indent-level: 2
+# perl-continued-statement-offset: 2
+# perl-continued-brace-offset: 0
+# perl-brace-offset: 0
+# perl-brace-imaginary-offset: 0
+# perl-label-offset: -2
+# cperl-indent-level: 2
+# cperl-brace-offset: 0
+# cperl-continued-brace-offset: 0
+# cperl-label-offset: -2
+# cperl-extra-newline-before-brace: t
+# cperl-merge-trailing-else: nil
+# cperl-continued-statement-offset: 2
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "my $VERSION = "
+# time-stamp-format: "'%:y-%02m-%02d.%02H'"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
projects / platform / upstream / automake.git / blobdiff