Revision control
Copy as Markdown
#!/usr/bin/env perl
use 5.010;
use strict;
use warnings;
use utf8;
=head1 NAME
10-testrunner.t - basic test for testrunner.pl
=head1 SYNOPSIS
perl ./10-testrunner.t
This test will run the testrunner.pl script with a few different
types of subprocesses and verify that behavior is as expected.
=cut
use Encode;
use English qw( -no_match_vars );
use File::Basename;
use File::Spec::Functions;
use File::chdir;
use FindBin;
use Readonly;
use Test::More;
use Capture::Tiny qw( capture );
use lib "$FindBin::Bin/../../lib/perl5";
use QtQA::Test::More qw( is_or_like );
# 1 if Windows
Readonly my $WINDOWS => ($OSNAME =~ m{win32}i);
# Directory containing some helper scripts
Readonly my $HELPER_DIR => catfile( $FindBin::Bin, 'helpers' );
# perl to print @ARGV unambiguously from a subprocess
# (not used directly)
Readonly my $TESTSCRIPT_BASE
=> q{use Data::Dumper; print Data::Dumper->new( \@ARGV )->Indent( 0 )->Dump( ); };
# perl to print @ARGV unambiguously and exit successfully
Readonly my $TESTSCRIPT_SUCCESS
=> $TESTSCRIPT_BASE . 'exit 0';
# perl to print @ARGV unambiguously and exit normally but unsuccessfully
Readonly my $TESTSCRIPT_FAIL
=> $TESTSCRIPT_BASE . 'exit 3';
# perl to print current working directory and exit normally
Readonly my $TESTSCRIPT_PRINT_CWD
=> q{use File::chdir; use File::Spec::Functions; say canonpath $CWD};
# Pattern matching --verbose 'begin' line, without trailing \n.
# 'label' is captured.
Readonly my $TESTRUNNER_VERBOSE_BEGIN
=> qr{\QQtQA::App::TestRunner: begin \E(?<label>.*?)\s\@.*?\Q: [perl]\E[^\n]*};
# Pattern matching --verbose 'end' line, without trailing \n.
# Ends with [^\n]*, so it can match or not match the exit status portion,
# as appropriate.
# 'label' is captured.
Readonly my $TESTRUNNER_VERBOSE_END
=> qr{\QQtQA::App::TestRunner: end \E(?<label>[^:]+)\Q: \E[^\n]*};
# expected STDERR when a process segfaults;
# note that we have no way to control if the system will create core dumps or not,
# so we will accept either case
Readonly my $TESTERROR_CRASH_VERBOSE
=> qr{\A $TESTRUNNER_VERBOSE_BEGIN \n}xms
.(($WINDOWS)
? qr{
\QQtQA::App::TestRunner: Process exited with exit code 0xC0000005 (STATUS_ACCESS_VIOLATION)\E\n
$TESTRUNNER_VERBOSE_END\Q, exit code 3221225477\E\n
\z}xms
: qr{
\QQtQA::App::TestRunner: Process exited due to signal 11\E(?:;\ dumped\ core)?\n
$TESTRUNNER_VERBOSE_END\Q, signal 11\E\n
\z}xms
);
# expected STDERR when a process divides by zero
Readonly my $TESTERROR_DIVIDE_BY_ZERO
=> ($WINDOWS)
? "QtQA::App::TestRunner: Process exited with exit code 0xC0000094 (STATUS_INTEGER_DIVIDE_BY_ZERO)\n"
: qr{\AQtQA::App::TestRunner: Process exited due to signal 8(?:; dumped core)?\n\z};
# perl to print @ARGV unambiguously and hang
Readonly my $TESTSCRIPT_HANG
=> $TESTSCRIPT_BASE . 'while (1) { sleep(1000) }';
# hardcoded value (seconds) for timeout test
Readonly my $TIMEOUT
=> 2;
# perl to print @ARGV unambiguously and sleep for set period
Readonly my $TESTSCRIPT_TIMEOUT_WARNING
=> $TESTSCRIPT_BASE . 'sleep(4); exit 0';
# hardcoded value (seconds) for timeout warning test
Readonly my $TIMEOUT_WARNING
=> 5;
# Message generated by killing a process when it times out;
# on Unix, we do this by SIGTERM, while on Windows, we expect
# no message because the process appears to exit normally
Readonly my $KILL_MESSAGE =>
$WINDOWS ? q{}
: qr{QtQA::App::TestRunner: Process exited due to signal 15\n}
;
# expected STDERR when wrapping the above
Readonly my $TESTERROR_HANG => qr{
QtQA::App::TestRunner:\ Timed\ out\ after\ \d+\ seconds?\n
$KILL_MESSAGE
}xms;
# expect STDERR when timeout duration warning is issued
Readonly my $TESTSUCCESS_TIMEOUT_WARNING => qr{
\QQtQA::App::TestRunner: warning: test duration (4 seconds) is dangerously close to maximum permitted time (5 seconds)\E\n
\QQtQA::App::TestRunner: warning: Either modify the test to reduce its runtime, or use a higher timeout.\E\n
}xms;
# Various interesting sets of arguments, with their expected serialization from
# the subprocess.
#
# This dataset essentially aims to confirm that there is never any special munging
# of arguments, and arguments are always passed to the subprocess exactly as they
# were passed to the testrunner.
#
# Note that the right hand side of these assignments of course could be generated
# by using Data::Dumper in this test rather than writing it by hand, but this
# is deliberately avoided to reduce the risk of accidentally writing an identical
# bug into both this test script and the test subprocess.
Readonly my %TESTSCRIPT_ARGUMENTS => (
'no args' => [
[
] => q{},
],
'trivial' => [
[
'hello',
] => q{$VAR1 = 'hello';},
],
'whitespace' => [
[
'hello there',
' ',
] => q{$VAR1 = 'hello there';$VAR2 = ' ';},
],
'posix sh metacharacters' => [
[
q{hello |there},
q{how $are "you' !today},
] => q{$VAR1 = 'hello |there';$VAR2 = 'how $are "you\' !today';},
],
'windows cmd metacharacters' => [
[
q{hello %there%},
q{how ^are "you' today},
] => q{$VAR1 = 'hello %there%';$VAR2 = 'how ^are "you\' today';},
],
'non-ascii' => [
[
q{早上好},
q{ä½ å¥½é©¬ï¼Ÿ},
] => encode_utf8( q{$VAR1 = '早上好';$VAR2 = 'ä½ å¥½é©¬ï¼Ÿ';} ),
],
);
# Do a single test of QtQA::App::TestRunner->run( ).
# Returns a hash of the actual output, error and status, in case additional
# testing is desired.
sub test_run
{
my ($params_ref) = @_;
my @args = @{$params_ref->{ args }};
my $expected_stdout = $params_ref->{ expected_stdout };
my $expected_stderr = $params_ref->{ expected_stderr };
my $expected_success = $params_ref->{ expected_success };
my $testname = $params_ref->{ testname } || q{};
my $status;
my ($output, $error) = capture {
$status = system( 'perl', "$FindBin::Bin/../testrunner.pl", @args );
};
if ($expected_success) {
is ( $status, 0, "$testname exits zero" );
}
else {
isnt( $status, 0, "$testname exits non-zero" );
}
is_or_like( $output, $expected_stdout, "$testname output looks correct" );
is_or_like( $error, $expected_stderr, "$testname error looks correct" );
return (
output => $output,
error => $error,
status => $status,
);
}
sub test_success
{
while (my ($testdata_name, $testdata_ref) = each %TESTSCRIPT_ARGUMENTS) {
TODO: {
if ($WINDOWS && $testdata_name =~ m{metacharacters}) {
todo_skip( 'handling of shell metacharacters not yet defined on Windows', 1 );
}
test_run({
args => [ 'perl', '-e', $TESTSCRIPT_SUCCESS, @{$testdata_ref->[0]} ],
expected_stdout => $testdata_ref->[1],
expected_stderr => q{},
expected_success => 1,
testname => "successful $testdata_name",
});
}
}
return;
}
# Basic test of --verbose with passing, failing or hanging test.
# Crashing with --verbose is tested in test_crashing
sub test_verbose
{
my ($args_ref, $stdout) = @{ $TESTSCRIPT_ARGUMENTS{ 'trivial' } };
my @args = @{ $args_ref };
my $stderr_success = qr{
\A
$TESTRUNNER_VERBOSE_BEGIN\n
$TESTRUNNER_VERBOSE_END\Q, exit code 0\E\n
\z
}xms;
my $stderr_fail = qr{
\A
$TESTRUNNER_VERBOSE_BEGIN\n
$TESTRUNNER_VERBOSE_END\Q, exit code 3\E\n
\z
}xms;
my $stderr_hang = qr{
\A
$TESTRUNNER_VERBOSE_BEGIN\n
$TESTERROR_HANG
$TESTRUNNER_VERBOSE_END\n # note, exit status is undefined (thus untested) on hang
}xms;
my $stderr_timeout_warning = qr{
\A
$TESTRUNNER_VERBOSE_BEGIN\n
$TESTSUCCESS_TIMEOUT_WARNING
$TESTRUNNER_VERBOSE_END\n
\z
}xms;
my %result;
%result = test_run({
args => [ '--verbose', '--', 'perl', '-e', $TESTSCRIPT_SUCCESS, @args ],
expected_stdout => $stdout,
expected_stderr => $stderr_success,
expected_success => 1,
testname => "verbose success",
});
ok( $result{ error } =~ $TESTRUNNER_VERBOSE_BEGIN )
&& is( $+{ label }, 'perl', 'label defaults to command name (begin)' );
ok( $result{ error } =~ $TESTRUNNER_VERBOSE_END )
&& is( $+{ label }, 'perl', 'label defaults to command name (end)' );
%result = test_run({
args => [ '--verbose', '--label=failure test', '--', 'perl', '-e', $TESTSCRIPT_FAIL, @args ],
expected_stdout => $stdout,
expected_stderr => $stderr_fail,
expected_success => 0,
testname => "verbose fail",
});
ok( $result{ error } =~ $TESTRUNNER_VERBOSE_BEGIN )
&& is( $+{ label }, 'failure test', 'explicitly setting label works as expected (begin)' );
ok( $result{ error } =~ $TESTRUNNER_VERBOSE_END )
&& is( $+{ label }, 'failure test', 'explicitly setting label works as expected (end)' );
%result = test_run({
args => [ '--verbose', '--label=mytestcase::mytestfunc', '--timeout', $TIMEOUT, '--', 'perl', '-e', $TESTSCRIPT_HANG, @args ],
expected_stdout => undef, # output is undefined when killed from timeout
expected_stderr => $stderr_hang,
expected_success => 0,
testname => "verbose hanging",
});
ok( $result{ error } =~ $TESTRUNNER_VERBOSE_BEGIN )
&& is( $+{ label }, 'mytestcase__mytestfunc', ': is stripped from label (begin)' );
ok( $result{ error } =~ $TESTRUNNER_VERBOSE_END )
&& is( $+{ label }, 'mytestcase__mytestfunc', ': is stripped from label (end)' );
test_run({
args => [ '--verbose', '--timeout', $TIMEOUT_WARNING, '--', 'perl', '-e', $TESTSCRIPT_TIMEOUT_WARNING, @args ],
expected_stdout => $stdout,
expected_stderr => $stderr_timeout_warning,
expected_success => 1,
testname => "timeout warning",
});
return;
}
sub test_normal_nonzero_exitcode
{
while (my ($testdata_name, $testdata_ref) = each %TESTSCRIPT_ARGUMENTS) {
TODO: {
if ($WINDOWS && $testdata_name =~ m{metacharacters}) {
todo_skip( 'handling of shell metacharacters not yet defined on Windows', 1 );
}
test_run({
args => [ 'perl', '-e', $TESTSCRIPT_FAIL, @{$testdata_ref->[0]} ],
expected_stdout => $testdata_ref->[1],
expected_stderr => q{},
expected_success => 0,
testname => "failure $testdata_name",
});
}
}
return;
}
sub test_crashing
{
my $crash_script = catfile( $HELPER_DIR, 'dereference_bad_pointer.pl' );
while (my ($testdata_name, $testdata_ref) = each %TESTSCRIPT_ARGUMENTS) {
test_run({
args => [ '--verbose', '--', 'perl', $crash_script, @{$testdata_ref->[0]} ],
expected_stdout => undef, # output is undefined when crashing
expected_stderr => qr{$TESTERROR_CRASH_VERBOSE},
expected_success => 0,
testname => "crash $testdata_name",
});
}
return;
}
sub test_divide_by_zero
{
my $crash_script = catfile( $HELPER_DIR, 'divide_by_zero.pl' );
while (my ($testdata_name, $testdata_ref) = each %TESTSCRIPT_ARGUMENTS) {
test_run({
args => [ 'perl', $crash_script, @{$testdata_ref->[0]} ],
expected_stdout => undef, # output is undefined when crashing
expected_stderr => $TESTERROR_DIVIDE_BY_ZERO,
expected_success => 0,
testname => "divide by zero $testdata_name",
});
}
return;
}
sub test_hanging
{
while (my ($testdata_name, $testdata_ref) = each %TESTSCRIPT_ARGUMENTS) {
my @args = (
# timeout after some seconds
'--timeout',
$TIMEOUT,
'perl',
'-e',
$TESTSCRIPT_HANG,
@{$testdata_ref->[0]},
);
test_run({
args => \@args,
expected_stdout => undef, # output is undefined when killed from timeout
expected_stderr => qr{\A$TESTERROR_HANG\z},
expected_success => 0,
testname => "hanging $testdata_name",
});
}
return;
}
# Test that testrunner.pl parses its own arguments OK and does not steal arguments
# from the child process
sub test_arg_parsing
{
# basic test: testrunner.pl with no args will fail
test_run({
args => [],
expected_stdout => q{},
expected_stderr => qr{not enough arguments},
expected_success => 0,
testname => "fails with no args",
});
# basic test: testrunner.pl parses --help by itself, and stops
test_run({
args => [ '--help', 'perl', '-e', 'print "Hello\n"' ],
expected_stdout => qr{\A Usage: \s}xms,
expected_stderr => q{},
expected_success => 0,
testname => "--help parsed OK",
});
# test that testrunner.pl does not parse --help if it comes after --
test_run({
args => [ '--', '--help' ],
expected_stdout => q{},
expected_stderr => (
!$WINDOWS
? qr{--help: No such file or directory}
: qr{'--help' is not recognized as }
),
expected_success => 0,
testname => "-- stops argument processing",
});
return;
}
sub test_chdir
{
my (undef, $parentdir) = fileparse( $CWD );
$parentdir = canonpath $parentdir;
my @cmd = ('perl', '-E', $TESTSCRIPT_PRINT_CWD);
# Without chdir, CWD should be the same as parent process
test_run({
args => [ '--', @cmd ],
expected_stdout => "$CWD\n",
expected_stderr => q{},
expected_success => 1,
testname => 'cwd as expected with no chdir',
});
test_run({
args => [ '--chdir', $parentdir, '--', @cmd ],
expected_stdout => "$parentdir\n",
expected_stderr => q{},
expected_success => 1,
testname => 'cwd as expected with --chdir',
});
test_run({
args => [ '-C', $parentdir, '--', @cmd ],
expected_stdout => "$parentdir\n",
expected_stderr => q{},
expected_success => 1,
testname => 'cwd as expected with -C',
});
return;
}
sub run
{
test_arg_parsing;
test_success;
test_verbose;
test_normal_nonzero_exitcode;
test_crashing;
SKIP: {
skip( 'divide by zero is unpredictable on mac', 1 ) if ($OSNAME =~ m{darwin}i);
test_divide_by_zero;
}
test_hanging;
test_chdir;
done_testing;
return;
}
run if (!caller);
1;