mirror of https://github.com/qpdf/qpdf.git
859 lines
20 KiB
Perl
Executable File
859 lines
20 KiB
Perl
Executable File
#!/usr/bin/env perl
|
|
#
|
|
# This file is part of qtest.
|
|
#
|
|
# Copyright 1993-2022, 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;
|
|
|
|
}
|