scripts/tap-driver.pl - third_party/qemu - Git at Google

 #! /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 });

   STDOUT->autoflush(1);
   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:
	#! /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 });

	STDOUT->autoflush(1);
	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: