--- /dev/null
+#! /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:
--- /dev/null
+#! /usr/bin/env perl
+# Copyright (C) 2018 Red Hat, Inc.
+#
+# Author: Paolo Bonzini <pbonzini@redhat.com>
+#
+# 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/>.
+
+# ---------------------------------- #
+# Imports, static data, and setup. #
+# ---------------------------------- #
+
+use warnings FATAL => 'all';
+use strict;
+use Getopt::Long ();
+use TAP::Parser;
+
+my $ME = "tap-merge.pl";
+my $VERSION = "2018-11-30";
+
+my $HELP = "$ME: merge multiple TAP inputs from stdin.";
+
+use constant DIAG_STRING => "#";
+
+# ----------------- #
+# Option parsing. #
+# ----------------- #
+
+Getopt::Long::GetOptions
+ (
+ 'help' => sub { print $HELP; exit 0; },
+ 'version' => sub { print "$ME $VERSION\n"; exit 0; },
+ );
+
+# -------------- #
+# Subroutines. #
+# -------------- #
+
+sub main ()
+{
+ my $iterator = TAP::Parser::Iterator::Stream->new(\*STDIN);
+ my $parser = TAP::Parser->new ({iterator => $iterator });
+ my $testno = 0; # Number of test results seen so far.
+ my $bailed_out = 0; # Whether a "Bail out!" directive has been seen.
+
+ while (defined (my $cur = $parser->next))
+ {
+ if ($cur->is_bailout)
+ {
+ $bailed_out = 1;
+ print DIAG_STRING . " " . $cur->as_string . "\n";
+ next;
+ }
+ elsif ($cur->is_plan)
+ {
+ $bailed_out = 0;
+ next;
+ }
+ elsif ($cur->is_test)
+ {
+ $bailed_out = 0 if $cur->number == 1;
+ $testno++;
+ $cur = TAP::Parser::Result::Test->new({
+ ok => $cur->ok,
+ test_num => $testno,
+ directive => $cur->directive,
+ explanation => $cur->explanation,
+ description => $cur->description
+ });
+ }
+ elsif ($cur->is_version)
+ {
+ next if $testno > 0;
+ }
+ print $cur->as_string . "\n" unless $bailed_out;
+ }
+ print "1..$testno\n";
+}
+
+# ----------- #
+# Main code. #
+# ----------- #
+
+main;
+
+# 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:
tests/test-qga$(EXESUF): tests/test-qga.o $(qtest-obj-y)
SPEED = quick
-GTESTER_OPTIONS = -k $(if $(V),--verbose,-q)
-GCOV_OPTIONS = -n $(if $(V),-f,)
# gtester tests, possibly with verbose output
+# do_test_tap runs all tests, even if some of them fail, while do_test_human
+# stops at the first failure unless -k is given on the command line
+
+define do_test_human_k
+ $(quiet-@)rc=0; $(foreach COMMAND, $1, \
+ $(call quiet-command-run, \
+ export MALLOC_PERTURB_=$${MALLOC_PERTURB_:-$$(( $${RANDOM:-0} % 255 + 1))} $2; \
+ $(COMMAND) -m=$(SPEED) -k --tap < /dev/null \
+ | ./scripts/tap-driver.pl --test-name="$(notdir $(COMMAND))" $(if $(V),, --show-failures-only) \
+ || rc=$$?;, "TEST", "$@: $(COMMAND)")) exit $$rc
+endef
+define do_test_human_no_k
+ $(foreach COMMAND, $1, \
+ $(call quiet-command, \
+ MALLOC_PERTURB_=$${MALLOC_PERTURB_:-$$(( $${RANDOM:-0} % 255 + 1))} $2 \
+ $(COMMAND) -m=$(SPEED) -k --tap < /dev/null \
+ | ./scripts/tap-driver.pl --test-name="$(notdir $(COMMAND))" $(if $(V),, --show-failures-only), \
+ "TEST", "$@: $(COMMAND)")
+)
+endef
+do_test_human = \
+ $(if $(findstring k, $(MAKEFLAGS)), $(do_test_human_k), $(do_test_human_no_k))
+
+define do_test_tap
+ $(call quiet-command, \
+ { export MALLOC_PERTURB_=$${MALLOC_PERTURB_:-$$(( $${RANDOM:-0} % 255 + 1))} $2; \
+ $(foreach COMMAND, $1, \
+ $(COMMAND) -m=$(SPEED) -k --tap < /dev/null \
+ | sed "s/^[a-z][a-z]* [0-9]* /&$(notdir $(COMMAND)) /" || true; ) } \
+ | ./scripts/tap-merge.pl | tee "$@" \
+ | ./scripts/tap-driver.pl $(if $(V),, --show-failures-only), \
+ "TAP","$@")
+endef
.PHONY: $(patsubst %, check-qtest-%, $(QTEST_TARGETS))
$(patsubst %, check-qtest-%, $(QTEST_TARGETS)): check-qtest-%: subdir-%-softmmu $(check-qtest-y)
- $(call quiet-command,QTEST_QEMU_BINARY=$*-softmmu/qemu-system-$* \
- QTEST_QEMU_IMG=qemu-img$(EXESUF) \
- MALLOC_PERTURB_=$${MALLOC_PERTURB_:-$$(( $${RANDOM:-0} % 255 + 1))} \
- gtester $(GTESTER_OPTIONS) -m=$(SPEED) $(check-qtest-$*-y) $(check-qtest-generic-y),"GTESTER","$@")
+ $(call do_test_human,$(check-qtest-$*-y) $(check-qtest-generic-y), \
+ QTEST_QEMU_BINARY=$*-softmmu/qemu-system-$* \
+ QTEST_QEMU_IMG=qemu-img$(EXESUF))
-.PHONY: $(patsubst %, check-%, $(check-unit-y) $(check-speed-y))
-$(patsubst %, check-%, $(check-unit-y) $(check-speed-y)): check-%: %
- $(call quiet-command, \
- MALLOC_PERTURB_=$${MALLOC_PERTURB_:-$$(( $${RANDOM:-0} % 255 + 1))} \
- gtester $(GTESTER_OPTIONS) -m=$(SPEED) $*,"GTESTER","$*")
+check-unit: $(check-unit-y)
+ $(call do_test_human, $^)
-# gtester tests with XML output
+check-speed: $(check-speed-y)
+ $(call do_test_human, $^)
-$(patsubst %, check-report-qtest-%.xml, $(QTEST_TARGETS)): check-report-qtest-%.xml: $(check-qtest-y)
- $(call quiet-command,QTEST_QEMU_BINARY=$*-softmmu/qemu-system-$* \
- QTEST_QEMU_IMG=qemu-img$(EXESUF) \
- gtester -q $(GTESTER_OPTIONS) -o $@ -m=$(SPEED) $(check-qtest-$*-y) $(check-qtest-generic-y),"GTESTER","$@")
+# gtester tests with TAP output
-check-report-unit.xml: $(check-unit-y)
- $(call quiet-command,gtester -q $(GTESTER_OPTIONS) -o $@ -m=$(SPEED) $^,"GTESTER","$@")
+$(patsubst %, check-report-qtest-%.tap, $(QTEST_TARGETS)): check-report-qtest-%.tap: $(check-qtest-y)
+ $(call do_test_tap, $(check-qtest-$*-y) $(check-qtest-generic-y), \
+ QTEST_QEMU_BINARY=$*-softmmu/qemu-system-$* \
+ QTEST_QEMU_IMG=qemu-img$(EXESUF))
-# Reports and overall runs
+check-report-unit.tap: $(check-unit-y)
+ $(call do_test_tap,$^)
-check-report.xml: $(patsubst %,check-report-qtest-%.xml, $(QTEST_TARGETS)) check-report-unit.xml
- $(call quiet-command,$(SRC_PATH)/scripts/gtester-cat $^ > $@,"GEN","$@")
+# Reports and overall runs
-check-report.html: check-report.xml
- $(call quiet-command,gtester-report $< > $@,"GEN","$@")
+check-report.tap: $(patsubst %,check-report-qtest-%.tap, $(QTEST_TARGETS)) check-report-unit.tap
+ $(call quiet-command,./scripts/tap-merge.py $^ > $@,"GEN","$@")
# Per guest TCG tests
.PHONY: check-qapi-schema check-qtest check-unit check check-clean
check-qapi-schema: $(patsubst %,check-%, $(check-qapi-schema-y)) check-tests/qapi-schema/doc-good.texi
check-qtest: $(patsubst %,check-qtest-%, $(QTEST_TARGETS))
-check-unit: $(patsubst %,check-%, $(check-unit-y))
-check-speed: $(patsubst %,check-%, $(check-speed-y))
check-block: $(patsubst %,check-%, $(check-block-y))
check: check-qapi-schema check-unit check-qtest check-decodetree
check-clean:
projects / qemu-nvme.git / commitdiff