nl-unit-test/third_party/nlbuild-autotools/repo/tools/host/share/automake-1.14/tap-driver.pl - nest-guard/1.0/nl-unit-test - Git at Google

 #! /usr/bin/env perl
 # Copyright (C) 2011-2013 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 warnings FATAL => 'all';
 use strict;
 use Getopt::Long ();
 use TAP::Parser;

 my $VERSION = '2012-02-01.19'; # UTC

 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;

 # Keep this in sync with `lib/am/check.am:$(am__tty_colors)'.
 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",
 );

 # 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;

 # ------------------- #
 #  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 $parser;         # TAP parser object (will be initialized later).

 # 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-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 {}, # No-op.
     '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;

 # ------------- #
 #  Prototypes.  #
 # ------------- #

 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 ($);

 # -------------- #
 #  Subroutines.  #
 # -------------- #

 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";
     }
 }

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

 # Convert a boolean to a "yes"/"no" string.
 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;
   }

   # Whether the test script should be re-run by "make recheck".
   sub must_recheck ()
   {
     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_seen);
   }

   # FIXME: this can certainly be improved ...
   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
     {
       # 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. 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 "$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;
   # Otherwise, determine whether it exited with error or was terminated
   # by a signal.
   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"; # NOTREACHED
 }

 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; # Don't colorize unknown stuff.
     }
 }

 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"; # NOTREACHED
     }
   $msg .= " $explanation" if defined $explanation;
   $msg .= "\n";
   # Output on console might be colorized.
   print OLDOUT decorate_result ($result) . $msg;
   # Log the result in the log file too, to help debugging (this is
   # especially true when said result is a TAP error or "Bail out!").
   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)
     {
       # 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 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))
     {
       # Verbatim copy any input line into the log file.
       print $cur->raw . "\n";
       # 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{comments})
         {
           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, as well as a non-zero exit status from the TAP producer.
   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 code. #
 # ----------- #

 main @ARGV;

 # 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:
	#! /usr/bin/env perl
	# Copyright (C) 2011-2013 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 warnings FATAL => 'all';
	use strict;
	use Getopt::Long ();
	use TAP::Parser;

	my $VERSION = '2012-02-01.19'; # UTC

	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;

	# Keep this in sync with `lib/am/check.am:$(am__tty_colors)'.
	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",
	);

	# 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;

	# ------------------- #
	# 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 $parser; # TAP parser object (will be initialized later).

	# 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-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 {}, # No-op.
	'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;

	# ------------- #
	# Prototypes. #
	# ------------- #

	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 ($);

	# -------------- #
	# Subroutines. #
	# -------------- #

	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";
	}
	}

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

	# Convert a boolean to a "yes"/"no" string.
	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;
	}

	# Whether the test script should be re-run by "make recheck".
	sub must_recheck ()
	{
	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_seen);
	}

	# FIXME: this can certainly be improved ...
	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
	{
	# 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. 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 "$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;
	# Otherwise, determine whether it exited with error or was terminated
	# by a signal.
	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"; # NOTREACHED
	}

	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; # Don't colorize unknown stuff.
	}
	}

	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"; # NOTREACHED
	}
	$msg .= " $explanation" if defined $explanation;
	$msg .= "\n";
	# Output on console might be colorized.
	print OLDOUT decorate_result ($result) . $msg;
	# Log the result in the log file too, to help debugging (this is
	# especially true when said result is a TAP error or "Bail out!").
	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)
	{
	# 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 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))
	{
	# Verbatim copy any input line into the log file.
	print $cur->raw . "\n";
	# 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{comments})
	{
	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, as well as a non-zero exit status from the TAP producer.
	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 code. #
	# ----------- #

	main @ARGV;

	# 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: