123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563 |
- use warnings FATAL => 'all';
- use strict;
- use Getopt::Long ();
- use TAP::Parser;
- my $VERSION = '2013-12-24.15';
- my $ME = "tap-driver.pl";
- my $USAGE = <<'END';
- Usage:
- tap-driver --test-name=NAME --log-file=PATH --trs-file=PATH
- [--expect-failure={yes|no}] [--color-tests={yes|no}]
- [--enable-hard-errors={yes|no}] [--ignore-exit]
- [--diagnostic-string=STRING] [--merge|--no-merge]
- [--comments|--no-comments] [--] TEST-COMMAND
- The '--test-name', '--log-file' and '--trs-file' options are mandatory.
- END
- my $HELP = "$ME: TAP-aware test driver for Automake testsuite harness." .
- "\n" . $USAGE;
- my %COLOR = (
- red => "\e[0;31m",
- grn => "\e[0;32m",
- lgn => "\e[1;32m",
- blu => "\e[1;34m",
- mgn => "\e[0;35m",
- brg => "\e[1m",
- std => "\e[m",
- );
- use constant NO_PLAN => 0;
- use constant EARLY_PLAN => 1;
- use constant LATE_PLAN => 2;
- my $testno = 0;
- my $bailed_out = 0;
- my $parser;
- my $plan_seen = NO_PLAN;
- my %cfg = (
- "color-tests" => 0,
- "expect-failure" => 0,
- "merge" => 0,
- "comments" => 0,
- "ignore-exit" => 0,
- );
- my $test_script_name = undef;
- my $log_file = undef;
- my $trs_file = undef;
- my $diag_string = "#";
- Getopt::Long::GetOptions
- (
- 'help' => sub { print $HELP; exit 0; },
- 'version' => sub { print "$ME $VERSION\n"; exit 0; },
- 'test-name=s' => \$test_script_name,
- 'log-file=s' => \$log_file,
- 'trs-file=s' => \$trs_file,
- 'color-tests=s' => \&bool_opt,
- 'expect-failure=s' => \&bool_opt,
- 'enable-hard-errors=s' => sub {},
- 'diagnostic-string=s' => \$diag_string,
- 'comments' => sub { $cfg{"comments"} = 1; },
- 'no-comments' => sub { $cfg{"comments"} = 0; },
- 'merge' => sub { $cfg{"merge"} = 1; },
- 'no-merge' => sub { $cfg{"merge"} = 0; },
- 'ignore-exit' => sub { $cfg{"ignore-exit"} = 1; },
- ) or exit 1;
- sub add_test_result ($);
- sub bool_opt ($$);
- sub colored ($$);
- 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_result ($);
- sub is_null_string ($);
- sub main (@);
- sub must_recheck ();
- sub report ($;$);
- 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 ($);
- sub bool_opt ($$)
- {
- my ($opt, $val) = @_;
- if ($val =~ /^(?:y|yes)\z/i)
- {
- $cfg{$opt} = 1;
- }
- elsif ($val =~ /^(?:n|no)\z/i)
- {
- $cfg{$opt} = 0;
- }
- else
- {
- die "$ME: invalid argument '$val' for option '$opt'\n";
- }
- }
- sub is_null_string ($)
- {
- my $str = shift;
- return ! (defined $str and length $str);
- }
- sub yn ($)
- {
- my $bool = shift;
- return $bool ? "yes" : "no";
- }
- TEST_RESULTS :
- {
- my (@test_results_list, %test_results_seen);
- sub add_test_result ($)
- {
- my $res = shift;
- push @test_results_list, $res;
- $test_results_seen{$res} = 1;
- }
- sub get_test_results ()
- {
- return @test_results_list;
- }
-
- sub must_recheck ()
- {
- return grep { !/^(?:XFAIL|PASS|SKIP)$/ } (keys %test_results_seen);
- }
-
-
- sub copy_in_global_log ()
- {
- return grep { not $_ eq "PASS" } (keys %test_results_seen);
- }
- sub get_global_test_result ()
- {
- 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 "$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";
- foreach my $result (get_test_results)
- {
- print RES ":test-result: $result\n";
- }
- close RES or die "$ME: closing $trs_file: $!\n";
- }
- sub trap_perl_warnings_and_errors ()
- {
- $SIG{__WARN__} = $SIG{__DIE__} = sub
- {
-
-
- open STDERR, ">&OLDERR";
- die @_;
- }
- }
- sub setup_io ()
- {
-
-
-
-
- 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;
- 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 '')
- {
-
-
-
- report "ERROR", "- couldn't execute test script";
- finish;
- }
- }
- sub get_test_exit_message ()
- {
- my $wstatus = $parser->wait;
-
- die "$ME: couldn't get the exit status of the TAP producer"
- unless defined $wstatus;
-
- return unless $wstatus;
-
-
- use POSIX qw (WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
- if (WIFEXITED ($wstatus))
- {
- return sprintf "exited with status %d", WEXITSTATUS ($wstatus);
- }
- elsif (WIFSIGNALED ($wstatus))
- {
- return sprintf "terminated by signal %d", WTERMSIG ($wstatus);
- }
- else
- {
- return "terminated abnormally";
- }
- }
- sub stringify_result_obj ($)
- {
- 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_obj->directive)
- {
- return $result_obj->is_ok ? $COOKED_PASS: $COOKED_FAIL;
- }
- elsif ($result_obj->has_todo)
- {
- return $result_obj->is_actual_ok ? "XPASS" : "XFAIL";
- }
- elsif ($result_obj->has_skip)
- {
- return $result_obj->is_ok ? "SKIP" : $COOKED_FAIL;
- }
- die "$ME: INTERNAL ERROR";
- }
- sub colored ($$)
- {
- my ($color_name, $text) = @_;
- return $COLOR{$color_name} . $text . $COLOR{'std'};
- }
- sub decorate_result ($)
- {
- my $result = shift;
- return $result unless $cfg{"color-tests"};
- my %color_for_result =
- (
- "ERROR" => 'mgn',
- "PASS" => 'grn',
- "XPASS" => 'red',
- "FAIL" => 'red',
- "XFAIL" => 'lgn',
- "SKIP" => 'blu',
- );
- if (my $color = $color_for_result{$result})
- {
- return colored ($color, $result);
- }
- else
- {
- return $result;
- }
- }
- sub report ($;$)
- {
- my ($msg, $result, $explanation) = (undef, @_);
- if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/)
- {
- $msg = ": $test_script_name";
- add_test_result $result;
- }
- elsif ($result eq "#")
- {
- $msg = " $test_script_name:";
- }
- else
- {
- die "$ME: INTERNAL ERROR";
- }
- $msg .= " $explanation" if defined $explanation;
- $msg .= "\n";
-
- print OLDOUT decorate_result ($result) . $msg;
-
-
- print $result . $msg;
- }
- sub testsuite_error ($)
- {
- report "ERROR", "- $_[0]";
- }
- sub handle_tap_result ($)
- {
- $testno++;
- my $result_obj = shift;
- 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;
- if ($plan_seen == LATE_PLAN)
- {
- $string .= " # AFTER LATE PLAN";
- }
- elsif ($result_obj->is_unplanned)
- {
- $string .= " # UNPLANNED";
- }
- elsif ($result_obj->number != $testno)
- {
- $string .= " # OUT-OF-ORDER (expecting $testno)";
- }
- elsif (my $directive = $result_obj->directive)
- {
- $string .= " # $directive";
- my $explanation = $result_obj->explanation;
- $string .= " $explanation"
- unless is_null_string $explanation;
- }
- report $test_result, $string;
- }
- sub handle_tap_plan ($)
- {
- my $plan = shift;
- if ($plan_seen)
- {
-
- testsuite_error "multiple test plans";
- return;
- }
-
-
-
-
-
- $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN);
-
-
-
-
-
-
- if ($plan->directive && $testno == 0)
- {
- my $explanation = is_null_string ($plan->explanation) ?
- undef : "- " . $plan->explanation;
- report "SKIP", $explanation;
- }
- }
- sub handle_tap_bailout ($)
- {
- my ($bailout, $msg) = ($_[0], "Bail out!");
- $bailed_out = 1;
- $msg .= " " . $bailout->explanation
- unless is_null_string $bailout->explanation;
- testsuite_error $msg;
- }
- sub extract_tap_comment ($)
- {
- my $line = shift;
- if (index ($line, $diag_string) == 0)
- {
-
- $line = substr ($line, length ($diag_string));
-
- $line =~ s/(?:^\s*|\s*$)//g;
-
- return $line;
- }
- return "";
- }
- sub finish ()
- {
- write_test_results;
- close LOG or die "$ME: closing $log_file: $!\n";
- exit 0;
- }
- sub main (@)
- {
- setup_io;
- setup_parser @_;
- while (defined (my $cur = $parser->next))
- {
-
- print $cur->raw . "\n";
-
- next if $bailed_out;
- if ($cur->is_plan)
- {
- handle_tap_plan ($cur);
- }
- elsif ($cur->is_test)
- {
- handle_tap_result ($cur);
- }
- elsif ($cur->is_bailout)
- {
- handle_tap_bailout ($cur);
- }
- elsif ($cfg{comments})
- {
- my $comment = extract_tap_comment ($cur->raw);
- report "#", "$comment" if length $comment;
- }
- }
-
-
- if (!$bailed_out)
- {
- if (!$plan_seen)
- {
- testsuite_error "missing test plan";
- }
- elsif ($parser->tests_planned != $parser->tests_run)
- {
- my ($planned, $run) = ($parser->tests_planned, $parser->tests_run);
- my $bad_amount = $run > $planned ? "many" : "few";
- 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;
- }
- }
- finish;
- }
- main @ARGV;
|