diff options
Diffstat (limited to 'scripts/tap-driver.pl')
| -rwxr-xr-x | scripts/tap-driver.pl | 378 |
1 files changed, 0 insertions, 378 deletions
diff --git a/scripts/tap-driver.pl b/scripts/tap-driver.pl deleted file mode 100755 index 5e59b5db49..0000000000 --- a/scripts/tap-driver.pl +++ /dev/null @@ -1,378 +0,0 @@ -#! /usr/bin/env perl -# Copyright (C) 2011-2013 Free Software Foundation, Inc. -# Copyright (C) 2018 Red Hat, 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 <https://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. - -# ---------------------------------- # -# Imports, static data, and setup. # -# ---------------------------------- # - -use warnings FATAL => 'all'; -use strict; -use Getopt::Long (); -use TAP::Parser; -use Term::ANSIColor qw(:constants); - -my $ME = "tap-driver.pl"; -my $VERSION = "2018-11-30"; - -my $USAGE = <<'END'; -Usage: - tap-driver [--test-name=TEST] [--color={always|never|auto}] - [--verbose] [--show-failures-only] -END - -my $HELP = "$ME: TAP-aware test driver for QEMU testsuite harness." . - "\n" . $USAGE; - -# It's important that NO_PLAN evaluates "false" as a boolean. -use constant NO_PLAN => 0; -use constant EARLY_PLAN => 1; -use constant LATE_PLAN => 2; - -use constant DIAG_STRING => "#"; - -# ------------------- # -# Global variables. # -# ------------------- # - -my $testno = 0; # Number of test results seen so far. -my $bailed_out = 0; # Whether a "Bail out!" directive has been seen. -my $failed = 0; # Final exit code - -# Whether the TAP plan has been seen or not, and if yes, which kind -# it is ("early" is seen before any test result, "late" otherwise). -my $plan_seen = NO_PLAN; - -# ----------------- # -# Option parsing. # -# ----------------- # - -my %cfg = ( - "color" => 0, - "verbose" => 0, - "show-failures-only" => 0, -); - -my $color = "auto"; -my $test_name = undef; - -# Perl's Getopt::Long allows options to take optional arguments after a space. -# Prevent --color by itself from consuming other arguments -foreach (@ARGV) { - if ($_ eq "--color" || $_ eq "-color") { - $_ = "--color=$color"; - } -} - -Getopt::Long::GetOptions - ( - 'help' => sub { print $HELP; exit 0; }, - 'version' => sub { print "$ME $VERSION\n"; exit 0; }, - 'test-name=s' => \$test_name, - 'color=s' => \$color, - 'show-failures-only' => sub { $cfg{"show-failures-only"} = 1; }, - 'verbose' => sub { $cfg{"verbose"} = 1; }, - ) or exit 1; - -if ($color =~ /^always$/i) { - $cfg{'color'} = 1; -} elsif ($color =~ /^never$/i) { - $cfg{'color'} = 0; -} elsif ($color =~ /^auto$/i) { - $cfg{'color'} = (-t STDOUT); -} else { - die "Invalid color mode: $color\n"; -} - -# ------------- # -# Prototypes. # -# ------------- # - -sub colored ($$); -sub decorate_result ($); -sub extract_tap_comment ($); -sub handle_tap_bailout ($); -sub handle_tap_plan ($); -sub handle_tap_result ($); -sub is_null_string ($); -sub main (); -sub report ($;$); -sub stringify_result_obj ($); -sub testsuite_error ($); - -# -------------- # -# Subroutines. # -# -------------- # - -# If the given string is undefined or empty, return true, otherwise -# return false. This function is useful to avoid pitfalls like: -# if ($message) { print "$message\n"; } -# which wouldn't print anything if $message is the literal "0". -sub is_null_string ($) -{ - my $str = shift; - return ! (defined $str and length $str); -} - -sub stringify_result_obj ($) -{ - my $result_obj = shift; - 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 ? "PASS" : "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" : "FAIL"; - } - die "$ME: INTERNAL ERROR"; # NOTREACHED -} - -sub colored ($$) -{ - my ($color_string, $text) = @_; - return $color_string . $text . RESET; -} - -sub decorate_result ($) -{ - my $result = shift; - return $result unless $cfg{"color"}; - my %color_for_result = - ( - "ERROR" => BOLD.MAGENTA, - "PASS" => GREEN, - "XPASS" => BOLD.YELLOW, - "FAIL" => BOLD.RED, - "XFAIL" => YELLOW, - "SKIP" => BLUE, - ); - if (my $color = $color_for_result{$result}) - { - return colored ($color, $result); - } - else - { - return $result; # Don't colorize unknown stuff. - } -} - -sub report ($;$) -{ - my ($msg, $result, $explanation) = (undef, @_); - if ($result =~ /^(?:X?(?:PASS|FAIL)|SKIP|ERROR)/) - { - # Output on console might be colorized. - $msg = decorate_result($result); - if ($result =~ /^(?:PASS|XFAIL|SKIP)/) - { - return if $cfg{"show-failures-only"}; - } - else - { - $failed = 1; - } - } - elsif ($result eq "#") - { - $msg = " "; - } - else - { - die "$ME: INTERNAL ERROR"; # NOTREACHED - } - $msg .= " $explanation" if defined $explanation; - print $msg . "\n"; -} - -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 .= " $test_name" unless is_null_string $test_name; - $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) - { - # Error, only one plan per stream is acceptable. - testsuite_error "multiple test plans"; - return; - } - # The TAP plan can come before or after *all* the TAP results; we speak - # respectively of an "early" or a "late" plan. If we see the plan line - # after at least one TAP result has been seen, assume we have a late - # plan; in this case, any further test result seen after the plan will - # be flagged as an error. - $plan_seen = ($testno >= 1 ? LATE_PLAN : EARLY_PLAN); - # If $testno > 0, we have an error ("too many tests run") that will be - # automatically dealt with later, so don't worry about it here. If - # $plan_seen is true, we have an error due to a repeated plan, and that - # has already been dealt with above. Otherwise, we have a valid "plan - # with SKIP" specification, and should report it as a particular kind - # of SKIP result. - 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) - { - # 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 main () -{ - my $iterator = TAP::Parser::Iterator::Stream->new(\*STDIN); - my $parser = TAP::Parser->new ({iterator => $iterator }); - - while (defined (my $cur = $parser->next)) - { - # Parsing of TAP input should stop after a "Bail out!" directive. - 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{"verbose"}) - { - my $comment = extract_tap_comment ($cur->raw); - report "#", "$comment" if length $comment; - } - } - # A "Bail out!" directive should cause us to ignore any following TAP - # error. - 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); - } - } -} - -# ----------- # -# Main code. # -# ----------- # - -main; -exit($failed); - -# 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 -# End: |