path: root/qtest/bin/qtest-driver

#!/usr/bin/env perl
#
# This file is part of qtest.
#
# Copyright 1993-2021, Jay Berkenbilt
#
# QTest is distributed under the terms of version 2.0 of the Artistic
# license which may be found in the source distribution.
#
require 5.008;
BEGIN { $^W = 1; }
use strict;
use IO::Handle;
use IO::File;
use IO::Socket;
use Cwd 'abs_path';
use Cwd;
use Config;
use File::Copy;
use File::Basename;
use File::Spec;

my $whoami = basename($0);
my $dirname = dirname(abs_path($0));
my $cwd = getcwd();
my $top = dirname($dirname);
my $module_dir = "$top/module";
my $qtc_dir = "$top/QTC/perl";

unshift(@INC, $module_dir, $qtc_dir);
require QTC;
require TestDriver;

if ((@ARGV == 1) && ($ARGV[0] eq '--version'))
{
    print "$whoami version 1.7\n";
    exit 0;
}
if ((@ARGV == 1) && ($ARGV[0] eq '--print-path'))
{
    print $top, "\n";
    exit 0;
}

my @bindirs = ();
my $datadir = undef;
my $covdir = '.';
my $stdout_tty = (-t STDOUT) ? "1" : "0";
my $junit_suffix = "";

while (@ARGV)
{
    my $arg = shift(@ARGV);
    if ($arg eq '-bindirs')
    {
	usage() unless @ARGV;
	push(@bindirs, split(':', shift(@ARGV)));
    }
    elsif ($arg eq '-datadir')
    {
	usage() unless @ARGV;
	$datadir = shift(@ARGV);
    }
    elsif ($arg eq '-covdir')
    {
	usage() unless @ARGV;
	$covdir = shift(@ARGV);
    }
    elsif ($arg =~ m/^-stdout-tty=([01])$/)
    {
	$stdout_tty = $1;
    }
    elsif ($arg eq '-junit-suffix')
    {
	usage() unless @ARGV;
	$junit_suffix = "-" . shift(@ARGV);
    }
    else
    {
	usage();
    }
}
usage() unless defined($datadir);
if (@bindirs)
{
    my @path = ();
    foreach my $d (@bindirs)
    {
	my $abs = abs_path($d) or
	    fatal("can't canonicalize path to bindir $d: $!");
	push(@path, $abs);
    }
    my $sep = ($^O eq 'MSWin32' ? ';' : ':');
    my $path = join($sep, @path) . $sep . $ENV{'PATH'};
    # Delete and explicitly recreate the PATH environment variable.
    # This seems to be more reliable.  If we just reassign, in some
    # cases, the modified environment is not inherited by the child
    # process.  (This happens when qtest-driver is invoked from ant
    # running from gjc-compat.  I have no idea how or why.)
    delete $ENV{'PATH'};
    $ENV{'PATH'} = $path;
}

if ($stdout_tty)
{
    TestDriver::get_tty_features();
}

my $pid = undef;
my $pid_cleanup = new TestDriver::PidKiller(\$pid);

# $in_testsuite is whether the test driver itself is being run from a
# test suite!  Check before we set the environment variable.
my $in_testsuite = $ENV{'IN_TESTSUITE'} || 0;

$ENV{'IN_TESTSUITE'} = 1;

# Temporary path is intended to be easy to locate so its contents can
# be inspected by impatient test suite runners.  It is not intended to
# be a "secure" (unpredictable) path.
my $tempdir = File::Spec->tmpdir() . "/testtemp.$$";
my $thispid = $$;

END
{
    # We have to make sure we don't call this from the child
    # qtest-driver when fork is called.
    if ((defined $thispid) && ($$ == $thispid) && (defined $tempdir))
    {
	local $?;
	TestDriver::rmrf($tempdir) if -d $tempdir;
    }
}

$| = 1;
$SIG{'PIPE'} = 'IGNORE';
$SIG{'INT'} = $SIG{'HUP'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub { exit 2 };

TestDriver::rmrf($tempdir);
fatal("removal of $tempdir failed") if -e "$tempdir";

mkdir($tempdir, 0777) || die "mkdir $tempdir: $!\n";
$tempdir = abs_path($tempdir) or
    fatal("can't canonicalize path to $tempdir: $!");

my $errors = 0;

my $tc_input = undef;
my $tc_scope = undef;
my @testcov = (<$covdir/*.testcov>);
if (@testcov > 1)
{
    fatal("more than one testcov file exists");
}
elsif (@testcov)
{
    &QTC::TC("testdriver", "coverage directory",
	     ($covdir eq '.' ? 1 : 0));
    $tc_input = $testcov[0];
    $tc_input =~ s,^\./,,;
    $tc_scope = basename($tc_input);
    $tc_scope =~ s/\.testcov$// or
	fatal("can't get scope from testcov filename");
}

my $testlogfile = 'qtest.log';
my $testxmlfile = 'qtest-results.xml';
my $testjunitfile = "TEST-qtest$junit_suffix.xml";
unlink $testlogfile;
unlink $testxmlfile;
unlink $testjunitfile;

my $totmissing = 0;
my $totextra = 0;
my $tottests = 0;
my $totpasses = 0;
my $totfails = 0;
my $totxpasses = 0;
my $totxfails = 0;

my $now = ($in_testsuite ? '---timestamp---' : localtime(time));
my $msg = "STARTING TESTS on $now";
print "\n";
print_and_log(('*' x length($msg)) . "\n$msg\n" .
	      ('*' x length($msg)) . "\n\n");

my $tc_log = undef;
my $tc_winlog = undef;
my %tc_cases = ();
my %tc_ignored_scopes = ();
parse_tc_file();
tc_do_initial_checks();

my $tests_to_run;
defined($tests_to_run = $ENV{"TESTS"}) or $tests_to_run = "";
my @tests = ();
if ($tests_to_run ne "")
{
    @tests = split(/\s+/, $tests_to_run);
    for (@tests)
    {
	&QTC::TC("testdriver", "driver tests specified");
	$_ = "$datadir/$_.test";
    }
}
else
{
    &QTC::TC("testdriver", "driver tests not specified");
    @tests = <$datadir/*.test>;
}

print_xml("<?xml version=\"1.0\"?>\n" .
	  "<qtest-results version=\"1\" timestamp=\"$now\"");
if (defined $tc_log)
{
    print_xml(" coverage-scope=\"$tc_scope\"");
}
print_xml(">\n");
print_junit("<?xml version=\"1.0\"?>\n" .
            "<testsuites>\n");
foreach my $test (@tests)
{
    print_and_log("\nRunning $test\n");
    print_xml(" <testsuite file=\"$test\">\n");
    print_junit(" <testsuite name=\"$test\">\n");
    my @results = run_test($test);
    if (scalar(@results) != 5)
    {
	error("test driver $test returned invalid results");
    }
    else
    {
	my ($ntests, $passes, $fails, $xpasses, $xfails) = @results;
	my $actual = $passes + $fails + $xpasses + $xfails;
	my $extra = 0;
	my $missing = 0;
	if ($actual > $ntests)
	{
	    &QTC::TC("testdriver", "driver extra tests");
	    my $n = ($actual - $ntests);
	    print_and_log(sprintf("\n*** WARNING: saw $n extra test%s\n\n",
				  ($n == 1 ? "" : "s")));
	    $extra = $n;
	}
	elsif ($actual < $ntests)
	{
	    &QTC::TC("testdriver", "driver missing tests");
	    my $n = ($ntests - $actual);
	    print_and_log(sprintf("\n*** WARNING: missing $n test%s\n\n",
				  ($n == 1 ? "" : "s")));
	    $missing = $n;
	}

	$totmissing += $missing;
	$totextra += $extra;
	$totpasses += $passes;
	$totfails += $fails;
	$totxpasses += $xpasses;
	$totxfails += $xfails;
	$tottests += ($passes + $fails + $xpasses + $xfails);

	my $passed = (($extra == 0) && ($missing == 0) &&
		      ($fails == 0) && ($xpasses == 0));

	print_xml("  <testsummary\n" .
		  "   overall-outcome=\"" .($passed ? 'pass' : 'fail') . "\"\n".
		  "   total-cases=\"$actual\"\n" .
		  "   passes=\"$passes\"\n" .
		  "   failures=\"$fails\"\n" .
		  "   unexpected-passes=\"$xpasses\"\n" .
		  "   expected-failures=\"$xfails\"\n" .
		  "   missing-cases=\"$missing\"\n" .
		  "   extra-cases=\"$extra\"\n");
	print_xml("  />\n");
    }
    print_xml(" </testsuite>\n");
    print_junit(" </testsuite>\n");
}

my $coverage_okay = 1;
tc_do_final_checks();

my $okay = ((($totpasses + $totxfails) == $tottests) &&
	    ($errors == 0) && ($totmissing == 0) && ($totextra == 0) &&
	    ($coverage_okay));

print "\n";
print_and_pad("Overall test suite");
if ($okay)
{
    &QTC::TC("testdriver", "driver overall pass");
    print_results(pass(), pass());
}
else
{
    &QTC::TC("testdriver", "driver overall fail");
    print_results(fail(), pass());
    print "\nFailure summary may be found in $testlogfile\n";
}

my $summary = "\nTESTS COMPLETE.  Summary:\n\n";
$summary .=
    sprintf("Total tests: %d\n" .
	    "Passes: %d\n" .
	    "Failures: %d\n" .
	    "Unexpected Passes: %d\n" .
	    "Expected Failures: %d\n" .
	    "Missing Tests: %d\n" .
	    "Extra Tests: %d\n",
	    $tottests, $totpasses, $totfails, $totxpasses, $totxfails,
	    $totmissing, $totextra);

print_and_log($summary);
print "\n";

print_xml(" <testsummary\n" .
	  "  overall-outcome=\"" . ($okay ? 'pass' : 'fail') . "\"\n" .
	  "  total-cases=\"$tottests\"\n" .
	  "  passes=\"$totpasses\"\n" .
	  "  failures=\"$totfails\"\n" .
	  "  unexpected-passes=\"$totxpasses\"\n" .
	  "  expected-failures=\"$totxfails\"\n" .
	  "  missing-cases=\"$totmissing\"\n" .
	  "  extra-cases=\"$totextra\"\n");
if (defined $tc_log)
{
    print_xml("  coverage-outcome=\"" .
	      ($coverage_okay ? 'pass' : 'fail') . "\"\n");
}
print_xml(" />\n" .
	  "</qtest-results>\n");
print_junit("</testsuites>\n");

exit ($okay ? 0 : 2);

sub run_test
{
    my $prog = shift;
    my @results = ();

    # Open a socket for communication with subsidiary test drivers.
    # Exchange some handshaking information over this socket.  When
    # the subsidiary test suite exits, it reports its results over the
    # socket.

    my $use_socketpair = (defined $Config{d_sockpair});
    if ($Config{'osname'} eq 'cygwin')
    {
	$use_socketpair = 0;
    }

    my $listensock;
    my $for_parent;
    my $for_child;

    my @comm_args = ();

    if ($use_socketpair)
    {
	socketpair($for_child, $for_parent, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
	    or fatal("socketpair: $!");
	my $fd = fileno($for_child);
	close($for_child);
	close($for_parent);
	local $^F = $fd; # prevent control fd from being closed on exec
	socketpair($for_child, $for_parent, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
	    or fatal("socketpair: $!");
	if (fileno($for_child) != $fd)
	{
	    fatal("FOR_CHILD socket has wrong file descriptor number: got " .
		  fileno($for_child) . "; wanted $fd");
	}
	$for_parent->autoflush(1);
	$for_child->autoflush(1);
	binmode $for_parent;
	binmode $for_child;
	@comm_args = ('-fd', $fd);
    }
    else
    {
	$listensock = IO::Socket::INET->new(
	    Listen => 1, Proto => 'tcp', LocalPort => 0) or
	    fatal("listen: $!");
	my ($s_port, $s_addr) = unpack_sockaddr_in($listensock->sockname());
	@comm_args = ('-port', $s_port);
    }

    my $pid = fork;
    fatal("fork failed: $!") unless defined $pid;
    if ($pid == 0)
    {
	if ($use_socketpair)
	{
	    close($for_parent);
	}
	chdir($datadir) or fatal("chdir $datadir failed: $!");

	if (defined $tc_log)
	{
	    # Set these environment variables in the child process so
	    # that we can actually use the coverage system
	    # successfully to test the test driver itself.
	    $ENV{'TC_SCOPE'} = $tc_scope;
	    $ENV{'TC_FILENAME'} = $tc_log;
	    if (defined $tc_winlog)
	    {
		$ENV{'TC_WIN_FILENAME'} = $tc_winlog;
	    }
	}

	# Clear this environment variable so that nested test suites
	# don't inherit the value from this test suite.  Note that as
	# of perl 5.8.7 in cygwin, deleting an environment variable
	# doesn't work.
	$ENV{'TESTS'} = "";

	exec +('perl', '-I', $module_dir, '-I', $qtc_dir,
	       basename($prog),
	       @comm_args,
	       '-origdir', $cwd,
	       '-tempdir', $tempdir,
	       '-testlog', "$cwd/$testlogfile",
	       '-testxml', "$cwd/$testxmlfile",
	       '-testjunit', "$cwd/$testjunitfile",
	       "-stdout-tty=$stdout_tty") or
		   fatal("exec $prog failed: $!");
    }
    if ($use_socketpair)
    {
	close($for_child);
    }
    else
    {
	$for_parent = $listensock->accept() or die $!;
	$for_parent->autoflush();
	$listensock->close();
    }

    eval
    {
	# Either CHLD or PIPE here indicates premature exiting of
	# subsidiary process which will be detected by either a
	# protocol error or a timeout on the select below.
	local $SIG{'CHLD'} = local $SIG{'PIPE'} = 'IGNORE';
	print $for_parent "TEST_DRIVER 1\n"
	    or die "--child--\n";
	my $rin = '';
	vec($rin, fileno($for_parent), 1) = 1;
	my $nfound = select($rin, '', '', 60);
	if ($nfound == 0)
	{
	    fatal("timed out waiting for input on $for_parent");
	}
	# Setting to DEFAULT should be unnecessary because of "local"
	# above, but there seems to be a race condition that this
	# helps to correct.
	$SIG{'CHLD'} = $SIG{'PIPE'} = 'DEFAULT';
    };
    if ($@)
    {
	if ($@ =~ m/--child--/)
	{
	    error("subsidiary test driver exited");
	}
	else
	{
	    die $@;
	}
    }
    else
    {
	my $line = <$for_parent>;
	if (! ((defined $line) && ($line =~ m/^TEST_DRIVER_CLIENT 1$/)))
	{
	    error("invalid protocol with subdiary test driver");
	    kill 1, $pid;
	}
	waitpid $pid, 0;
	my $results = <$for_parent>;
	close($for_parent);
	if (! ((defined $results) && ($results =~ m/^\d+(?: \d+){4}$/)))
	{
	    &QTC::TC("testdriver", "driver test returned invalid results");
	    error("invalid results from subsidiary test driver");
	}
	else
	{
	    @results = split(/ /, $results);
	}
    }
    @results;
}

sub parse_tc_file
{
    return unless defined $tc_input;

    my $tc = new IO::File("<$tc_input") or fatal("can't read $tc_input: $!");
    binmode $tc;
    while (<$tc>)
    {
	s/\r?\n$//s;
	next if m/^\#/;
	next if m/^\s*$/;
	if (m/^ignored-scope: (\S+)$/)
	{
	    $tc_ignored_scopes{$1} = 1;
	}
	elsif (m/^\s*?(\S.+?)\s+(\d+)\s*$/)
	{
	    my ($case, $n) = ($1, $2);
	    if (exists $tc_cases{$case})
	    {
		&QTC::TC("testdriver", "driver duplicate coverage case");
		error("$tc_input:$.: duplicate case");
	    }
	    $tc_cases{$case} = $n;
	}
	else
	{
	    error("$tc_input:$.: invalid syntax");
	}
    }
    $tc->close();
}

sub tc_do_initial_checks
{
    return unless defined $tc_input;

    if (! exists $ENV{'TC_SRCS'})
    {
	fatal("TC_SRCS must be set");
    }

    my @tc_srcs = (grep { m/\S/ } (split(/\s+/, $ENV{'TC_SRCS'})));

    my %seen_cases = ();
    foreach my $src (@tc_srcs)
    {
	my $s = new IO::File("<$src") or die "$whoami: open $src: $!\n";
	binmode $s;
	while (<$s>)
	{
	    # Look for coverage calls in the source subject to certain
	    # lexical constraints
	    my ($lscope, $case);
	    if (m/^\s*\&?(?:QTC|qtc)(?:::|\.)TC\(\"([^\"]+)\",\s*\"([^\"]+)\"/)
	    {
		# C++, Java, Perl, etc.
		($lscope, $case) = ($1, $2);
	    }
	    elsif (m/^[^\#]*\$\(call QTC.TC,([^,]+),([^,\)]+)/)
	    {
		# make
		($lscope, $case) = ($1, $2);
	    }
	    if ((defined $lscope) && (defined $case))
	    {
		if ($lscope eq $tc_scope)
		{
		    push(@{$seen_cases{$case}}, [$src, $.]);
		}
		elsif (exists $tc_ignored_scopes{$lscope})
		{
		    &QTC::TC("testdriver", "driver ignored scope");
		}
		else
		{
		    &QTC::TC("testdriver", "driver out-of-scope case");
		    error("$src:$.: out-of-scope coverage case");
		}
	    }
	}
	$s->close();
    }

    my %wanted_cases = %tc_cases;
    foreach my $case (sort keys %seen_cases)
    {
	my $wanted = 1;
	my $whybad = undef;
	if (exists $wanted_cases{$case})
	{
	    delete $wanted_cases{$case};
	}
	else
	{
	    &QTC::TC("testdriver", "driver unregistered coverage case");
	    $wanted = 0;
	    $whybad = "unregistered";
	}
	if (scalar(@{$seen_cases{$case}}) > $wanted)
	{
	    $whybad = $whybad || "duplicate";
	    foreach my $d (@{$seen_cases{$case}})
	    {
		my ($file, $lineno) = @$d;
		&QTC::TC("testdriver", "driver coverage error in src",
			 ($whybad eq 'unregistered' ? 0 :
			  $whybad eq 'duplicate' ? 1 :
			  9999));
		error("$file:$lineno: $whybad coverage case \"$case\"");
	    }
	}
    }
    foreach my $case (sort keys %wanted_cases)
    {
	&QTC::TC("testdriver", "driver unseen coverage case");
	error("$whoami: coverage case \"$case\" was not seen");
    }

    fatal("errors detected; exiting") if $errors;

    $tc_log = "$cwd/$tc_scope.cov_out";
    if ($^O eq 'cygwin')
    {
	chop(my $f = `cygpath --windows $tc_log`);
	$tc_winlog = $f;
    }
    elsif ($^O =~ m/^MSWin32|msys$/)
    {
	$tc_winlog = $tc_log;
    }
    unlink $tc_log;
    print_and_log("Test coverage active in scope $tc_scope\n");
}

sub tc_do_final_checks
{
    return unless (defined $tc_log);

    my %seen_cases = ();
    my $tc = new IO::File("<$tc_log");
    binmode $tc;
    if ($tc)
    {
	binmode $tc;
	while (<$tc>)
	{
	    s/\r?\n$//s;
	    next if m/^\#/;
	    next if m/^\s*$/;
	    if (m/^(.+) (\d+)\s*$/)
	    {
		$seen_cases{$1}{$2} = 1;
	    }
	}
	$tc->close();
    }

    my $testlog = open_log();

    $testlog->print("\nTest coverage results:\n");

    my @problems = ();
    foreach my $c (sort keys %tc_cases)
    {
	my ($case, $n) = ($c, $tc_cases{$c});
	for (my $i = 0; $i <= $n; ++$i)
	{
	    if (exists $seen_cases{$c}{$i})
	    {
		delete $seen_cases{$c}{$i};
	    }
	    else
	    {
		&QTC::TC("testdriver", "driver missing coverage case");
		push(@problems, "missing: $c $i");
	    }
	}
    }
    foreach my $c (sort keys %seen_cases)
    {
	foreach my $n (sort { $a <=> $b } (keys %{$seen_cases{$c}}))
	{
	    &QTC::TC("testdriver", "driver extra coverage case");
	    push(@problems, "extra: $c $n");
	}
    }

    if (@problems)
    {
	my $testxml = open_xml();
        my $testjunit = open_junit();
	$testxml->print(" <coverage-errors count=\"" .
			scalar(@problems) . "\">\n");
        $testjunit->print(" <testsuite name=\"coverage\">\n");
	foreach my $p (@problems)
	{
	    $testlog->print("$p\n");
	    $testxml->print("  <coverage-error case=\"$p\"/>\n");
            $testjunit->print("  <testcase name=\"$p\">\n" .
                              "   <failure message=\"$p\"/>\n" .
                              "  </testcase>\n");
	}
	$testxml->print(" </coverage-errors>\n");
	$testxml->close();
        $testjunit->print(" </testsuite>\n");
        $testjunit->close();
	$testlog->print("coverage errors: " . scalar(@problems) . "\n");
    }
    my $passed = (@problems == 0);
    $testlog->print("\nCoverage analysis: ", ($passed ? 'PASSED' : 'FAILED'),
		    "\n");
    $testlog->close();

    print "\n";
    print_and_pad("Coverage analysis");
    if ($passed)
    {
	print_results(pass(), pass());
	my $passlog = $tc_log;
	$passlog =~ s/(\.[^\.]+)$/-passed$1/;
	copy($tc_log, $passlog);
    }
    else
    {
	$coverage_okay = 0;
	print_results(fail(), pass());
    }
}

sub open_binary
{
    my $file = shift;
    my $fh = new IO::File(">>$file") or fatal("can't open $file: $!");
    binmode $fh;
    $fh;
}

sub open_log
{
    open_binary($testlogfile);
}

sub open_xml
{
    open_binary($testxmlfile);
}

sub open_junit
{
    open_binary($testjunitfile);
}

sub print_and_log
{
    my $fh = open_log();
    print @_;
    print $fh @_;
    $fh->close();
}

sub print_xml
{
    my $fh = open_xml();
    print $fh @_;
    $fh->close();
}

sub print_junit
{
    my $fh = open_junit();
    print $fh @_;
    $fh->close();
}

sub print_and_pad
{
    TestDriver::print_and_pad(@_);
}

sub print_results
{
    TestDriver::print_results(@_);
}

sub pass
{
    TestDriver->PASS;
}

sub fail
{
    TestDriver->FAIL;
}

sub error
{
    my $msg = shift;
    warn $msg, "\n";
    ++$errors;
}

sub fatal
{
    my $msg = shift;
    warn "$whoami: $msg\n";
    exit 2;
}

sub usage
{
    warn "
Usage: $whoami --print-path

Prints full path to ${whoami}'s installation directory and exits.

 - OR -

Usage: $whoami options

Options include:

  -datadir datadir
  -bindirs bindir[:bindir...]
  [ -covdir [coverage-dir] ]
  [ -stdout-tty=[01] ]
  [ -junit-suffix suffix ]

Subsidiary test programs are run with the -bindirs argument (a
colon-separated list of directories, which may be relative but will be
internally converted to absolute) prepended to the path and with the
-datadir argument set as the current working directory.

By default, this program runs datadir/*.test as subsidiary test
suites.  If the TESTS environment variable is set, it is taken to be a
space-separated list of test suite names.  For each name n,
datadir/n.test is run.

Test coverage support is built in.  If a file whose name matches
*.testcov in the coverage directory (which defaults to \".\") that is
a valid test coverage file, the full path to the file into which test
coverage results are written will be placed in the TC_FILENAME
environment variable.  (If running under cygwin, the Windows path will
be in TC_WIN_FILENAME.)  The test coverage scope, which is equal to
the part of the testcov file name excluding the extension, is placed
in the TC_SCOPE environment variable.

If the -stdout-tty option is passed, its value overrides ${whoami}'s
determination of whether standard output is a terminal.  This can be
useful for cases in which another program is invoking ${whoami} and
passing its output through a pipe to a terminal.

Qtest writes its results to qtest.log, qtest-results.xml, and
TEST-qtest.xml. The TEST-qtest.xml file is compatible with JUnit's
test ouput, which makes it useful for many continuous integration
systems. The test output information in that file is not quite as rich
as in qtest-results.xml, but it is good enough for most purposes. If
you want your JUnit-compatible results file to have a different name,
pass -junit-suffix yoursuffix. This will change the name to
TEST-qtest-yoursuffix.xml.

";
    exit 2;

}