23c3f81ed7
This timeout is used to wait for the server to finish writing its logs before checking them against the expected values. An overloaded machine could take more than the two seconds previously allocated, so increase the timeout to 5 seconds. Ref: #11328 Closes #11834
1468 lines
46 KiB
Perl
1468 lines
46 KiB
Perl
#***************************************************************************
|
|
# _ _ ____ _
|
|
# Project ___| | | | _ \| |
|
|
# / __| | | | |_) | |
|
|
# | (__| |_| | _ <| |___
|
|
# \___|\___/|_| \_\_____|
|
|
#
|
|
# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
|
|
#
|
|
# This software is licensed as described in the file COPYING, which
|
|
# you should have received as part of this distribution. The terms
|
|
# are also available at https://curl.se/docs/copyright.html.
|
|
#
|
|
# You may opt to use, copy, modify, merge, publish, distribute and/or sell
|
|
# copies of the Software, and permit persons to whom the Software is
|
|
# furnished to do so, under the terms of the COPYING file.
|
|
#
|
|
# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
|
|
# KIND, either express or implied.
|
|
#
|
|
# SPDX-License-Identifier: curl
|
|
#
|
|
###########################################################################
|
|
|
|
# This module contains entry points to run a single test. runner_init
|
|
# determines whether they will run in a separate process or in the process of
|
|
# the caller. The relevant interface is asynchronous so it will work in either
|
|
# case. Program arguments are marshalled and then written to the end of a pipe
|
|
# (in controlleripccall) which is later read from and the arguments
|
|
# unmarshalled (in ipcrecv) before the desired function is called normally.
|
|
# The function return values are then marshalled and written into another pipe
|
|
# (again in ipcrecv) when is later read from and unmarshalled (in runnerar)
|
|
# before being returned to the caller.
|
|
|
|
package runner;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use 5.006;
|
|
|
|
BEGIN {
|
|
use base qw(Exporter);
|
|
|
|
our @EXPORT = qw(
|
|
checktestcmd
|
|
prepro
|
|
readtestkeywords
|
|
restore_test_env
|
|
runner_init
|
|
runnerac_clearlocks
|
|
runnerac_shutdown
|
|
runnerac_stopservers
|
|
runnerac_test_preprocess
|
|
runnerac_test_run
|
|
runnerar
|
|
runnerar_ready
|
|
stderrfilename
|
|
stdoutfilename
|
|
$DBGCURL
|
|
$gdb
|
|
$gdbthis
|
|
$gdbxwin
|
|
$shallow
|
|
$tortalloc
|
|
$valgrind_logfile
|
|
$valgrind_tool
|
|
);
|
|
|
|
# these are for debugging only
|
|
our @EXPORT_OK = qw(
|
|
singletest_preprocess
|
|
);
|
|
}
|
|
|
|
use B qw(
|
|
svref_2object
|
|
);
|
|
use Storable qw(
|
|
freeze
|
|
thaw
|
|
);
|
|
|
|
use pathhelp qw(
|
|
exe_ext
|
|
);
|
|
use processhelp qw(
|
|
portable_sleep
|
|
);
|
|
use servers qw(
|
|
checkcmd
|
|
clearlocks
|
|
initserverconfig
|
|
serverfortest
|
|
stopserver
|
|
stopservers
|
|
subvariables
|
|
);
|
|
use getpart;
|
|
use globalconfig;
|
|
use testutil qw(
|
|
clearlogs
|
|
logmsg
|
|
runclient
|
|
shell_quote
|
|
subbase64
|
|
subnewlines
|
|
);
|
|
use valgrind;
|
|
|
|
|
|
#######################################################################
|
|
# Global variables set elsewhere but used only by this package
|
|
# These may only be set *before* runner_init is called
|
|
our $DBGCURL=$CURL; #"../src/.libs/curl"; # alternative for debugging
|
|
our $valgrind_logfile="--log-file"; # the option name for valgrind >=3
|
|
our $valgrind_tool="--tool=memcheck";
|
|
our $gdb = checktestcmd("gdb");
|
|
our $gdbthis; # run test case with gdb debugger
|
|
our $gdbxwin; # use windowed gdb when using gdb
|
|
|
|
# torture test variables
|
|
our $shallow;
|
|
our $tortalloc;
|
|
|
|
# local variables
|
|
my %oldenv; # environment variables before test is started
|
|
my $UNITDIR="./unit";
|
|
my $CURLLOG="$LOGDIR/commands.log"; # all command lines run
|
|
my $defserverlogslocktimeout = 5; # timeout to await server logs lock removal
|
|
my $defpostcommanddelay = 0; # delay between command and postcheck sections
|
|
my $multiprocess; # nonzero with a separate test runner process
|
|
|
|
# pipes
|
|
my $runnerr; # pipe that runner reads from
|
|
my $runnerw; # pipe that runner writes to
|
|
|
|
# per-runner variables, indexed by runner ID; these are used by controller only
|
|
my %controllerr; # pipe that controller reads from
|
|
my %controllerw; # pipe that controller writes to
|
|
|
|
# redirected stdout/stderr to these files
|
|
sub stdoutfilename {
|
|
my ($logdir, $testnum)=@_;
|
|
return "$logdir/stdout$testnum";
|
|
}
|
|
|
|
sub stderrfilename {
|
|
my ($logdir, $testnum)=@_;
|
|
return "$logdir/stderr$testnum";
|
|
}
|
|
|
|
#######################################################################
|
|
# Initialize the runner and prepare it to run tests
|
|
# The runner ID returned by this function must be passed into the other
|
|
# runnerac_* functions
|
|
# Called by controller
|
|
sub runner_init {
|
|
my ($logdir, $jobs)=@_;
|
|
|
|
$multiprocess = !!$jobs;
|
|
|
|
# enable memory debugging if curl is compiled with it
|
|
$ENV{'CURL_MEMDEBUG'} = "$logdir/$MEMDUMP";
|
|
$ENV{'CURL_ENTROPY'}="12345678";
|
|
$ENV{'CURL_FORCETIME'}=1; # for debug NTLM magic
|
|
$ENV{'CURL_GLOBAL_INIT'}=1; # debug curl_global_init/cleanup use
|
|
$ENV{'HOME'}=$pwd;
|
|
$ENV{'CURL_HOME'}=$ENV{'HOME'};
|
|
$ENV{'XDG_CONFIG_HOME'}=$ENV{'HOME'};
|
|
$ENV{'COLUMNS'}=79; # screen width!
|
|
|
|
# Incorporate the $logdir into the random seed and re-seed the PRNG.
|
|
# This gives each runner a unique yet consistent seed which provides
|
|
# more unique port number selection in each runner, yet is deterministic
|
|
# across runs.
|
|
$randseed += unpack('%16C*', $logdir);
|
|
srand $randseed;
|
|
|
|
# create pipes for communication with runner
|
|
my ($thisrunnerr, $thiscontrollerw, $thiscontrollerr, $thisrunnerw);
|
|
pipe $thisrunnerr, $thiscontrollerw;
|
|
pipe $thiscontrollerr, $thisrunnerw;
|
|
|
|
my $thisrunnerid;
|
|
if($multiprocess) {
|
|
# Create a separate process in multiprocess mode
|
|
my $child = fork();
|
|
if(0 == $child) {
|
|
# TODO: set up better signal handlers
|
|
$SIG{INT} = 'IGNORE';
|
|
$SIG{TERM} = 'IGNORE';
|
|
eval {
|
|
# some msys2 perl versions don't define SIGUSR1
|
|
$SIG{USR1} = 'IGNORE';
|
|
};
|
|
|
|
$thisrunnerid = $$;
|
|
print "Runner $thisrunnerid starting\n" if($verbose);
|
|
|
|
# Here we are the child (runner).
|
|
close($thiscontrollerw);
|
|
close($thiscontrollerr);
|
|
$runnerr = $thisrunnerr;
|
|
$runnerw = $thisrunnerw;
|
|
|
|
# Set this directory as ours
|
|
$LOGDIR = $logdir;
|
|
mkdir("$LOGDIR/$PIDDIR", 0777);
|
|
mkdir("$LOGDIR/$LOCKDIR", 0777);
|
|
|
|
# Initialize various server variables
|
|
initserverconfig();
|
|
|
|
# handle IPC calls
|
|
event_loop();
|
|
|
|
# Can't rely on logmsg here in case it's buffered
|
|
print "Runner $thisrunnerid exiting\n" if($verbose);
|
|
|
|
# To reach this point, either the controller has sent
|
|
# runnerac_stopservers() and runnerac_shutdown() or we have called
|
|
# runnerabort(). In both cases, there are no more of our servers
|
|
# running and we can safely exit.
|
|
exit 0;
|
|
}
|
|
|
|
# Here we are the parent (controller).
|
|
close($thisrunnerw);
|
|
close($thisrunnerr);
|
|
|
|
$thisrunnerid = $child;
|
|
|
|
} else {
|
|
# Create our pid directory
|
|
mkdir("$LOGDIR/$PIDDIR", 0777);
|
|
|
|
# Don't create a separate process
|
|
$thisrunnerid = "integrated";
|
|
}
|
|
|
|
$controllerw{$thisrunnerid} = $thiscontrollerw;
|
|
$runnerr = $thisrunnerr;
|
|
$runnerw = $thisrunnerw;
|
|
$controllerr{$thisrunnerid} = $thiscontrollerr;
|
|
|
|
return $thisrunnerid;
|
|
}
|
|
|
|
#######################################################################
|
|
# Loop to execute incoming IPC calls until the shutdown call
|
|
sub event_loop {
|
|
while () {
|
|
if(ipcrecv()) {
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
#######################################################################
|
|
# Check for a command in the PATH of the machine running curl.
|
|
#
|
|
sub checktestcmd {
|
|
my ($cmd)=@_;
|
|
my @testpaths=("$LIBDIR/.libs", "$LIBDIR");
|
|
return checkcmd($cmd, @testpaths);
|
|
}
|
|
|
|
# See if Valgrind should actually be used
|
|
sub use_valgrind {
|
|
if($valgrind) {
|
|
my @valgrindoption = getpart("verify", "valgrind");
|
|
if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) {
|
|
return 1;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
# Massage the command result code into a useful form
|
|
sub normalize_cmdres {
|
|
my $cmdres = $_[0];
|
|
my $signal_num = $cmdres & 127;
|
|
my $dumped_core = $cmdres & 128;
|
|
|
|
if(!$anyway && ($signal_num || $dumped_core)) {
|
|
$cmdres = 1000;
|
|
}
|
|
else {
|
|
$cmdres >>= 8;
|
|
$cmdres = (2000 + $signal_num) if($signal_num && !$cmdres);
|
|
}
|
|
return ($cmdres, $dumped_core);
|
|
}
|
|
|
|
# 'prepro' processes the input array and replaces %-variables in the array
|
|
# etc. Returns the processed version of the array
|
|
sub prepro {
|
|
my $testnum = shift;
|
|
my (@entiretest) = @_;
|
|
my $show = 1;
|
|
my @out;
|
|
my $data_crlf;
|
|
my @pshow;
|
|
my @altshow;
|
|
my $plvl;
|
|
my $line;
|
|
for my $s (@entiretest) {
|
|
my $f = $s;
|
|
$line++;
|
|
if($s =~ /^ *%if (.*)/) {
|
|
my $cond = $1;
|
|
my $rev = 0;
|
|
|
|
if($cond =~ /^!(.*)/) {
|
|
$cond = $1;
|
|
$rev = 1;
|
|
}
|
|
$rev ^= $feature{$cond} ? 1 : 0;
|
|
push @pshow, $show; # push the previous state
|
|
$plvl++;
|
|
if($show) {
|
|
# only if this was showing before we can allow the alternative
|
|
# to go showing as well
|
|
push @altshow, $rev ^ 1; # push the reversed show state
|
|
}
|
|
else {
|
|
push @altshow, 0; # the alt should still hide
|
|
}
|
|
if($show) {
|
|
# we only allow show if already showing
|
|
$show = $rev;
|
|
}
|
|
next;
|
|
}
|
|
elsif($s =~ /^ *%else/) {
|
|
if(!$plvl) {
|
|
print STDERR "error: test$testnum:$line: %else no %if\n";
|
|
last;
|
|
}
|
|
$show = pop @altshow;
|
|
push @altshow, $show; # put it back for consistency
|
|
next;
|
|
}
|
|
elsif($s =~ /^ *%endif/) {
|
|
if(!$plvl--) {
|
|
print STDERR "error: test$testnum:$line: %endif had no %if\n";
|
|
last;
|
|
}
|
|
$show = pop @pshow;
|
|
pop @altshow; # not used here but we must pop it
|
|
next;
|
|
}
|
|
if($show) {
|
|
# The processor does CRLF replacements in the <data*> sections if
|
|
# necessary since those parts might be read by separate servers.
|
|
if($s =~ /^ *<data(.*)\>/) {
|
|
if($1 =~ /crlf="yes"/ ||
|
|
($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) {
|
|
$data_crlf = 1;
|
|
}
|
|
}
|
|
elsif(($s =~ /^ *<\/data/) && $data_crlf) {
|
|
$data_crlf = 0;
|
|
}
|
|
subvariables(\$s, $testnum, "%");
|
|
subbase64(\$s);
|
|
subnewlines(0, \$s) if($data_crlf);
|
|
push @out, $s;
|
|
}
|
|
}
|
|
return @out;
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Load test keywords into %keywords hash
|
|
#
|
|
sub readtestkeywords {
|
|
my @info_keywords = getpart("info", "keywords");
|
|
|
|
# Clear the list of keywords from the last test
|
|
%keywords = ();
|
|
for my $k (@info_keywords) {
|
|
chomp $k;
|
|
$keywords{$k} = 1;
|
|
}
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Return a list of log locks that still exist
|
|
#
|
|
sub logslocked {
|
|
opendir(my $lockdir, "$LOGDIR/$LOCKDIR");
|
|
my @locks;
|
|
foreach (readdir $lockdir) {
|
|
if(/^(.*)\.lock$/) {
|
|
push @locks, $1;
|
|
}
|
|
}
|
|
return @locks;
|
|
}
|
|
|
|
#######################################################################
|
|
# Memory allocation test and failure torture testing.
|
|
#
|
|
sub torture {
|
|
my ($testcmd, $testnum, $gdbline) = @_;
|
|
|
|
# remove memdump first to be sure we get a new nice and clean one
|
|
unlink("$LOGDIR/$MEMDUMP");
|
|
|
|
# First get URL from test server, ignore the output/result
|
|
runclient($testcmd);
|
|
|
|
logmsg " CMD: $testcmd\n" if($verbose);
|
|
|
|
# memanalyze -v is our friend, get the number of allocations made
|
|
my $count=0;
|
|
my @out = `$memanalyze -v "$LOGDIR/$MEMDUMP"`;
|
|
for(@out) {
|
|
if(/^Operations: (\d+)/) {
|
|
$count = $1;
|
|
last;
|
|
}
|
|
}
|
|
if(!$count) {
|
|
logmsg " found no functions to make fail\n";
|
|
return 0;
|
|
}
|
|
|
|
my @ttests = (1 .. $count);
|
|
if($shallow && ($shallow < $count)) {
|
|
my $discard = scalar(@ttests) - $shallow;
|
|
my $percent = sprintf("%.2f%%", $shallow * 100 / scalar(@ttests));
|
|
logmsg " $count functions found, but only fail $shallow ($percent)\n";
|
|
while($discard) {
|
|
my $rm;
|
|
do {
|
|
# find a test to discard
|
|
$rm = rand(scalar(@ttests));
|
|
} while(!$ttests[$rm]);
|
|
$ttests[$rm] = undef;
|
|
$discard--;
|
|
}
|
|
}
|
|
else {
|
|
logmsg " $count functions to make fail\n";
|
|
}
|
|
|
|
for (@ttests) {
|
|
my $limit = $_;
|
|
my $fail;
|
|
my $dumped_core;
|
|
|
|
if(!defined($limit)) {
|
|
# --shallow can undefine them
|
|
next;
|
|
}
|
|
if($tortalloc && ($tortalloc != $limit)) {
|
|
next;
|
|
}
|
|
|
|
if($verbose) {
|
|
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
|
|
localtime(time());
|
|
my $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
|
|
logmsg "Fail function no: $limit at $now\r";
|
|
}
|
|
|
|
# make the memory allocation function number $limit return failure
|
|
$ENV{'CURL_MEMLIMIT'} = $limit;
|
|
|
|
# remove memdump first to be sure we get a new nice and clean one
|
|
unlink("$LOGDIR/$MEMDUMP");
|
|
|
|
my $cmd = $testcmd;
|
|
if($valgrind && !$gdbthis) {
|
|
my @valgrindoption = getpart("verify", "valgrind");
|
|
if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) {
|
|
my $valgrindcmd = "$valgrind ";
|
|
$valgrindcmd .= "$valgrind_tool " if($valgrind_tool);
|
|
$valgrindcmd .= "--quiet --leak-check=yes ";
|
|
$valgrindcmd .= "--suppressions=$srcdir/valgrind.supp ";
|
|
# $valgrindcmd .= "--gen-suppressions=all ";
|
|
$valgrindcmd .= "--num-callers=16 ";
|
|
$valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum";
|
|
$cmd = "$valgrindcmd $testcmd";
|
|
}
|
|
}
|
|
logmsg "*** Function number $limit is now set to fail ***\n" if($gdbthis);
|
|
|
|
my $ret = 0;
|
|
if($gdbthis) {
|
|
runclient($gdbline);
|
|
}
|
|
else {
|
|
$ret = runclient($cmd);
|
|
}
|
|
#logmsg "$_ Returned " . ($ret >> 8) . "\n";
|
|
|
|
# Now clear the variable again
|
|
delete $ENV{'CURL_MEMLIMIT'} if($ENV{'CURL_MEMLIMIT'});
|
|
|
|
if(-r "core") {
|
|
# there's core file present now!
|
|
logmsg " core dumped\n";
|
|
$dumped_core = 1;
|
|
$fail = 2;
|
|
}
|
|
|
|
if($valgrind) {
|
|
my @e = valgrindparse("$LOGDIR/valgrind$testnum");
|
|
if(@e && $e[0]) {
|
|
if($automakestyle) {
|
|
logmsg "FAIL: torture $testnum - valgrind\n";
|
|
}
|
|
else {
|
|
logmsg " valgrind ERROR ";
|
|
logmsg @e;
|
|
}
|
|
$fail = 1;
|
|
}
|
|
}
|
|
|
|
# verify that it returns a proper error code, doesn't leak memory
|
|
# and doesn't core dump
|
|
if(($ret & 255) || ($ret >> 8) >= 128) {
|
|
logmsg " system() returned $ret\n";
|
|
$fail=1;
|
|
}
|
|
else {
|
|
my @memdata=`$memanalyze "$LOGDIR/$MEMDUMP"`;
|
|
my $leak=0;
|
|
for(@memdata) {
|
|
if($_ ne "") {
|
|
# well it could be other memory problems as well, but
|
|
# we call it leak for short here
|
|
$leak=1;
|
|
}
|
|
}
|
|
if($leak) {
|
|
logmsg "** MEMORY FAILURE\n";
|
|
logmsg @memdata;
|
|
logmsg `$memanalyze -l "$LOGDIR/$MEMDUMP"`;
|
|
$fail = 1;
|
|
}
|
|
}
|
|
if($fail) {
|
|
logmsg " $testnum: torture FAILED: function number $limit in test.\n",
|
|
" invoke with \"-t$limit\" to repeat this single case.\n";
|
|
stopservers($verbose);
|
|
return 1;
|
|
}
|
|
}
|
|
|
|
logmsg "\n" if($verbose);
|
|
logmsg "torture OK\n";
|
|
return 0;
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# restore environment variables that were modified in test
|
|
sub restore_test_env {
|
|
my $deleteoldenv = $_[0]; # 1 to delete the saved contents after restore
|
|
foreach my $var (keys %oldenv) {
|
|
if($oldenv{$var} eq 'notset') {
|
|
delete $ENV{$var} if($ENV{$var});
|
|
}
|
|
else {
|
|
$ENV{$var} = $oldenv{$var};
|
|
}
|
|
if($deleteoldenv) {
|
|
delete $oldenv{$var};
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Start the servers needed to run this test case
|
|
sub singletest_startservers {
|
|
my ($testnum, $testtimings) = @_;
|
|
|
|
# remove old test server files before servers are started/verified
|
|
unlink("$LOGDIR/$SERVERCMD");
|
|
unlink("$LOGDIR/$SERVERIN");
|
|
unlink("$LOGDIR/$PROXYIN");
|
|
|
|
# timestamp required servers verification start
|
|
$$testtimings{"timesrvrini"} = Time::HiRes::time();
|
|
|
|
my $why;
|
|
my $error;
|
|
if (!$listonly) {
|
|
my @what = getpart("client", "server");
|
|
if(!$what[0]) {
|
|
warn "Test case $testnum has no server(s) specified";
|
|
$why = "no server specified";
|
|
$error = -1;
|
|
} else {
|
|
my $err;
|
|
($why, $err) = serverfortest(@what);
|
|
if($err == 1) {
|
|
# Error indicates an actual problem starting the server
|
|
$error = -2;
|
|
} else {
|
|
$error = -1;
|
|
}
|
|
}
|
|
}
|
|
|
|
# timestamp required servers verification end
|
|
$$testtimings{"timesrvrend"} = Time::HiRes::time();
|
|
|
|
return ($why, $error);
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Generate preprocessed test file
|
|
sub singletest_preprocess {
|
|
my $testnum = $_[0];
|
|
|
|
# Save a preprocessed version of the entire test file. This allows more
|
|
# "basic" test case readers to enjoy variable replacements.
|
|
my @entiretest = fulltest();
|
|
my $otest = "$LOGDIR/test$testnum";
|
|
|
|
@entiretest = prepro($testnum, @entiretest);
|
|
|
|
# save the new version
|
|
open(my $fulltesth, ">", "$otest") || die "Failure writing test file";
|
|
foreach my $bytes (@entiretest) {
|
|
print $fulltesth pack('a*', $bytes) or die "Failed to print '$bytes': $!";
|
|
}
|
|
close($fulltesth) || die "Failure writing test file";
|
|
|
|
# in case the process changed the file, reload it
|
|
loadtest("$LOGDIR/test${testnum}");
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Set up the test environment to run this test case
|
|
sub singletest_setenv {
|
|
my @setenv = getpart("client", "setenv");
|
|
foreach my $s (@setenv) {
|
|
chomp $s;
|
|
if($s =~ /([^=]*)=(.*)/) {
|
|
my ($var, $content) = ($1, $2);
|
|
# remember current setting, to restore it once test runs
|
|
$oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset';
|
|
# set new value
|
|
if(!$content) {
|
|
delete $ENV{$var} if($ENV{$var});
|
|
}
|
|
else {
|
|
if($var =~ /^LD_PRELOAD/) {
|
|
if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) {
|
|
logmsg "Skipping LD_PRELOAD due to lack of OS support\n" if($verbose);
|
|
next;
|
|
}
|
|
if($feature{"debug"} || !$has_shared) {
|
|
logmsg "Skipping LD_PRELOAD due to no release shared build\n" if($verbose);
|
|
next;
|
|
}
|
|
}
|
|
$ENV{$var} = "$content";
|
|
logmsg "setenv $var = $content\n" if($verbose);
|
|
}
|
|
}
|
|
}
|
|
if($proxy_address) {
|
|
$ENV{http_proxy} = $proxy_address;
|
|
$ENV{HTTPS_PROXY} = $proxy_address;
|
|
}
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Check that test environment is fine to run this test case
|
|
sub singletest_precheck {
|
|
my $testnum = $_[0];
|
|
my $why;
|
|
my @precheck = getpart("client", "precheck");
|
|
if(@precheck) {
|
|
my $cmd = $precheck[0];
|
|
chomp $cmd;
|
|
if($cmd) {
|
|
my @p = split(/ /, $cmd);
|
|
if($p[0] !~ /\//) {
|
|
# the first word, the command, does not contain a slash so
|
|
# we will scan the "improved" PATH to find the command to
|
|
# be able to run it
|
|
my $fullp = checktestcmd($p[0]);
|
|
|
|
if($fullp) {
|
|
$p[0] = $fullp;
|
|
}
|
|
$cmd = join(" ", @p);
|
|
}
|
|
|
|
my @o = `$cmd 2> $LOGDIR/precheck-$testnum`;
|
|
if($o[0]) {
|
|
$why = $o[0];
|
|
$why =~ s/[\r\n]//g;
|
|
}
|
|
elsif($?) {
|
|
$why = "precheck command error";
|
|
}
|
|
logmsg "prechecked $cmd\n" if($verbose);
|
|
}
|
|
}
|
|
return $why;
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Prepare the test environment to run this test case
|
|
sub singletest_prepare {
|
|
my ($testnum) = @_;
|
|
|
|
if($feature{"TrackMemory"}) {
|
|
unlink("$LOGDIR/$MEMDUMP");
|
|
}
|
|
unlink("core");
|
|
|
|
# remove server output logfiles after servers are started/verified
|
|
unlink("$LOGDIR/$SERVERIN");
|
|
unlink("$LOGDIR/$PROXYIN");
|
|
|
|
# if this section exists, it might be FTP server instructions:
|
|
my @ftpservercmd = getpart("reply", "servercmd");
|
|
push @ftpservercmd, "Testnum $testnum\n";
|
|
# write the instructions to file
|
|
writearray("$LOGDIR/$SERVERCMD", \@ftpservercmd);
|
|
|
|
# create (possibly-empty) files before starting the test
|
|
for my $partsuffix (('', '1', '2', '3', '4')) {
|
|
my @inputfile=getpart("client", "file".$partsuffix);
|
|
my %fileattr = getpartattr("client", "file".$partsuffix);
|
|
my $filename=$fileattr{'name'};
|
|
if(@inputfile || $filename) {
|
|
if(!$filename) {
|
|
logmsg " $testnum: IGNORED: section client=>file has no name attribute\n";
|
|
return -1;
|
|
}
|
|
my $fileContent = join('', @inputfile);
|
|
|
|
# make directories if needed
|
|
my $path = $filename;
|
|
# cut off the file name part
|
|
$path =~ s/^(.*)\/[^\/]*/$1/;
|
|
my $nparts = scalar(split(/\//, $LOGDIR));
|
|
my @parts = split(/\//, $path);
|
|
if(join("/", @parts[0..$nparts-1]) eq $LOGDIR) {
|
|
# the file is in $LOGDIR/
|
|
my $d = shift @parts;
|
|
for(@parts) {
|
|
$d .= "/$_";
|
|
mkdir $d; # 0777
|
|
}
|
|
}
|
|
if (open(my $outfile, ">", "$filename")) {
|
|
binmode $outfile; # for crapage systems, use binary
|
|
if($fileattr{'nonewline'}) {
|
|
# cut off the final newline
|
|
chomp($fileContent);
|
|
}
|
|
print $outfile $fileContent;
|
|
close($outfile);
|
|
} else {
|
|
logmsg "ERROR: cannot write $filename\n";
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Run the test command
|
|
sub singletest_run {
|
|
my ($testnum, $testtimings) = @_;
|
|
|
|
# get the command line options to use
|
|
my ($cmd, @blaha)= getpart("client", "command");
|
|
if($cmd) {
|
|
# make some nice replace operations
|
|
$cmd =~ s/\n//g; # no newlines please
|
|
# substitute variables in the command line
|
|
}
|
|
else {
|
|
# there was no command given, use something silly
|
|
$cmd="-";
|
|
}
|
|
|
|
my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout
|
|
|
|
# if stdout section exists, we verify that the stdout contained this:
|
|
my $out="";
|
|
my %cmdhash = getpartattr("client", "command");
|
|
if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-output/)) {
|
|
#We may slap on --output!
|
|
if (!partexists("verify", "stdout") ||
|
|
($cmdhash{'option'} && $cmdhash{'option'} =~ /force-output/)) {
|
|
$out=" --output $CURLOUT ";
|
|
}
|
|
}
|
|
|
|
my @codepieces = getpart("client", "tool");
|
|
my $tool="";
|
|
if(@codepieces) {
|
|
$tool = $codepieces[0];
|
|
chomp $tool;
|
|
$tool .= exe_ext('TOOL');
|
|
}
|
|
|
|
my $disablevalgrind;
|
|
my $CMDLINE="";
|
|
my $cmdargs;
|
|
my $cmdtype = $cmdhash{'type'} || "default";
|
|
my $fail_due_event_based = $run_event_based;
|
|
if($cmdtype eq "perl") {
|
|
# run the command line prepended with "perl"
|
|
$cmdargs ="$cmd";
|
|
$CMDLINE = "$perl ";
|
|
$tool=$CMDLINE;
|
|
$disablevalgrind=1;
|
|
}
|
|
elsif($cmdtype eq "shell") {
|
|
# run the command line prepended with "/bin/sh"
|
|
$cmdargs ="$cmd";
|
|
$CMDLINE = "/bin/sh ";
|
|
$tool=$CMDLINE;
|
|
$disablevalgrind=1;
|
|
}
|
|
elsif(!$tool && !$keywords{"unittest"}) {
|
|
# run curl, add suitable command line options
|
|
my $inc="";
|
|
if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-include/)) {
|
|
$inc = " --include";
|
|
}
|
|
$cmdargs = "$out$inc ";
|
|
|
|
if($cmdhash{'option'} && ($cmdhash{'option'} =~ /binary-trace/)) {
|
|
$cmdargs .= "--trace $LOGDIR/trace$testnum ";
|
|
}
|
|
else {
|
|
$cmdargs .= "--trace-ascii $LOGDIR/trace$testnum ";
|
|
}
|
|
$cmdargs .= "--trace-time ";
|
|
if($run_event_based) {
|
|
$cmdargs .= "--test-event ";
|
|
$fail_due_event_based--;
|
|
}
|
|
$cmdargs .= $cmd;
|
|
if ($proxy_address) {
|
|
$cmdargs .= " --proxy $proxy_address ";
|
|
}
|
|
}
|
|
else {
|
|
$cmdargs = " $cmd"; # $cmd is the command line for the test file
|
|
$CURLOUT = stdoutfilename($LOGDIR, $testnum); # sends received data to stdout
|
|
|
|
# Default the tool to a unit test with the same name as the test spec
|
|
if($keywords{"unittest"} && !$tool) {
|
|
$tool="unit$testnum";
|
|
}
|
|
|
|
if($tool =~ /^lib/) {
|
|
$CMDLINE="$LIBDIR/$tool";
|
|
}
|
|
elsif($tool =~ /^unit/) {
|
|
$CMDLINE="$UNITDIR/$tool";
|
|
}
|
|
|
|
if(! -f $CMDLINE) {
|
|
logmsg " $testnum: IGNORED: The tool set in the test case for this: '$tool' does not exist\n";
|
|
return (-1, 0, 0, "", "", 0);
|
|
}
|
|
$DBGCURL=$CMDLINE;
|
|
}
|
|
|
|
if($fail_due_event_based) {
|
|
logmsg " $testnum: IGNORED: This test cannot run event based\n";
|
|
return (-1, 0, 0, "", "", 0);
|
|
}
|
|
|
|
if($gdbthis) {
|
|
# gdb is incompatible with valgrind, so disable it when debugging
|
|
# Perhaps a better approach would be to run it under valgrind anyway
|
|
# with --db-attach=yes or --vgdb=yes.
|
|
$disablevalgrind=1;
|
|
}
|
|
|
|
my @stdintest = getpart("client", "stdin");
|
|
|
|
if(@stdintest) {
|
|
my $stdinfile="$LOGDIR/stdin-for-$testnum";
|
|
|
|
my %hash = getpartattr("client", "stdin");
|
|
if($hash{'nonewline'}) {
|
|
# cut off the final newline from the final line of the stdin data
|
|
chomp($stdintest[-1]);
|
|
}
|
|
|
|
writearray($stdinfile, \@stdintest);
|
|
|
|
$cmdargs .= " <$stdinfile";
|
|
}
|
|
|
|
if(!$tool) {
|
|
$CMDLINE=shell_quote($CURL);
|
|
}
|
|
|
|
if(use_valgrind() && !$disablevalgrind) {
|
|
my $valgrindcmd = "$valgrind ";
|
|
$valgrindcmd .= "$valgrind_tool " if($valgrind_tool);
|
|
$valgrindcmd .= "--quiet --leak-check=yes ";
|
|
$valgrindcmd .= "--suppressions=$srcdir/valgrind.supp ";
|
|
# $valgrindcmd .= "--gen-suppressions=all ";
|
|
$valgrindcmd .= "--num-callers=16 ";
|
|
$valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum";
|
|
$CMDLINE = "$valgrindcmd $CMDLINE";
|
|
}
|
|
|
|
$CMDLINE .= "$cmdargs > " . stdoutfilename($LOGDIR, $testnum) .
|
|
" 2> " . stderrfilename($LOGDIR, $testnum);
|
|
|
|
if($verbose) {
|
|
logmsg "$CMDLINE\n";
|
|
}
|
|
|
|
open(my $cmdlog, ">", $CURLLOG) || die "Failure writing log file";
|
|
print $cmdlog "$CMDLINE\n";
|
|
close($cmdlog) || die "Failure writing log file";
|
|
|
|
my $dumped_core;
|
|
my $cmdres;
|
|
|
|
if($gdbthis) {
|
|
my $gdbinit = "$TESTDIR/gdbinit$testnum";
|
|
open(my $gdbcmd, ">", "$LOGDIR/gdbcmd") || die "Failure writing gdb file";
|
|
print $gdbcmd "set args $cmdargs\n";
|
|
print $gdbcmd "show args\n";
|
|
print $gdbcmd "source $gdbinit\n" if -e $gdbinit;
|
|
close($gdbcmd) || die "Failure writing gdb file";
|
|
}
|
|
|
|
# Flush output.
|
|
$| = 1;
|
|
|
|
# timestamp starting of test command
|
|
$$testtimings{"timetoolini"} = Time::HiRes::time();
|
|
|
|
# run the command line we built
|
|
if ($torture) {
|
|
$cmdres = torture($CMDLINE,
|
|
$testnum,
|
|
"$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " -x $LOGDIR/gdbcmd");
|
|
}
|
|
elsif($gdbthis) {
|
|
my $GDBW = ($gdbxwin) ? "-w" : "";
|
|
runclient("$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " $GDBW -x $LOGDIR/gdbcmd");
|
|
$cmdres=0; # makes it always continue after a debugged run
|
|
}
|
|
else {
|
|
# Convert the raw result code into a more useful one
|
|
($cmdres, $dumped_core) = normalize_cmdres(runclient("$CMDLINE"));
|
|
}
|
|
|
|
# timestamp finishing of test command
|
|
$$testtimings{"timetoolend"} = Time::HiRes::time();
|
|
|
|
return (0, $cmdres, $dumped_core, $CURLOUT, $tool, use_valgrind() && !$disablevalgrind);
|
|
}
|
|
|
|
|
|
#######################################################################
|
|
# Clean up after test command
|
|
sub singletest_clean {
|
|
my ($testnum, $dumped_core, $testtimings)=@_;
|
|
|
|
if(!$dumped_core) {
|
|
if(-r "core") {
|
|
# there's core file present now!
|
|
$dumped_core = 1;
|
|
}
|
|
}
|
|
|
|
if($dumped_core) {
|
|
logmsg "core dumped\n";
|
|
if(0 && $gdb) {
|
|
logmsg "running gdb for post-mortem analysis:\n";
|
|
open(my $gdbcmd, ">", "$LOGDIR/gdbcmd2") || die "Failure writing gdb file";
|
|
print $gdbcmd "bt\n";
|
|
close($gdbcmd) || die "Failure writing gdb file";
|
|
runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch " . shell_quote($DBGCURL) . " core ");
|
|
# unlink("$LOGDIR/gdbcmd2");
|
|
}
|
|
}
|
|
|
|
# If a server logs advisor read lock file exists, it is an indication
|
|
# that the server has not yet finished writing out all its log files,
|
|
# including server request log files used for protocol verification.
|
|
# So, if the lock file exists the script waits here a certain amount
|
|
# of time until the server removes it, or the given time expires.
|
|
my $serverlogslocktimeout = $defserverlogslocktimeout;
|
|
my %cmdhash = getpartattr("client", "command");
|
|
if($cmdhash{'timeout'}) {
|
|
# test is allowed to override default server logs lock timeout
|
|
if($cmdhash{'timeout'} =~ /(\d+)/) {
|
|
$serverlogslocktimeout = $1 if($1 >= 0);
|
|
}
|
|
}
|
|
if($serverlogslocktimeout) {
|
|
my $lockretry = $serverlogslocktimeout * 20;
|
|
my @locks;
|
|
while((@locks = logslocked()) && $lockretry--) {
|
|
portable_sleep(0.05);
|
|
}
|
|
if(($lockretry < 0) &&
|
|
($serverlogslocktimeout >= $defserverlogslocktimeout)) {
|
|
logmsg "Warning: server logs lock timeout ",
|
|
"($serverlogslocktimeout seconds) expired (locks: " .
|
|
join(", ", @locks) . ")\n";
|
|
}
|
|
}
|
|
|
|
# Test harness ssh server does not have this synchronization mechanism,
|
|
# this implies that some ssh server based tests might need a small delay
|
|
# once that the client command has run to avoid false test failures.
|
|
#
|
|
# gnutls-serv also lacks this synchronization mechanism, so gnutls-serv
|
|
# based tests might need a small delay once that the client command has
|
|
# run to avoid false test failures.
|
|
my $postcommanddelay = $defpostcommanddelay;
|
|
if($cmdhash{'delay'}) {
|
|
# test is allowed to specify a delay after command is executed
|
|
if($cmdhash{'delay'} =~ /(\d+)/) {
|
|
$postcommanddelay = $1 if($1 > 0);
|
|
}
|
|
}
|
|
|
|
portable_sleep($postcommanddelay) if($postcommanddelay);
|
|
|
|
# timestamp removal of server logs advisor read lock
|
|
$$testtimings{"timesrvrlog"} = Time::HiRes::time();
|
|
|
|
# test definition might instruct to stop some servers
|
|
# stop also all servers relative to the given one
|
|
|
|
my @killtestservers = getpart("client", "killserver");
|
|
if(@killtestservers) {
|
|
foreach my $server (@killtestservers) {
|
|
chomp $server;
|
|
if(stopserver($server)) {
|
|
logmsg " $testnum: killserver FAILED\n";
|
|
return 1; # normal error if asked to fail on unexpected alive
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
#######################################################################
|
|
# Verify that the postcheck succeeded
|
|
sub singletest_postcheck {
|
|
my ($testnum)=@_;
|
|
|
|
# run the postcheck command
|
|
my @postcheck= getpart("client", "postcheck");
|
|
if(@postcheck) {
|
|
my $cmd = join("", @postcheck);
|
|
chomp $cmd;
|
|
if($cmd) {
|
|
logmsg "postcheck $cmd\n" if($verbose);
|
|
my $rc = runclient("$cmd");
|
|
# Must run the postcheck command in torture mode in order
|
|
# to clean up, but the result can't be relied upon.
|
|
if($rc != 0 && !$torture) {
|
|
logmsg " $testnum: postcheck FAILED\n";
|
|
return -1;
|
|
}
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
|
|
|
|
###################################################################
|
|
# Get ready to run a single test case
|
|
sub runner_test_preprocess {
|
|
my ($testnum)=@_;
|
|
my %testtimings;
|
|
|
|
if(clearlogs()) {
|
|
logmsg "Warning: log messages were lost\n";
|
|
}
|
|
|
|
# timestamp test preparation start
|
|
# TODO: this metric now shows only a portion of the prep time; better would
|
|
# be to time singletest_preprocess below instead
|
|
$testtimings{"timeprepini"} = Time::HiRes::time();
|
|
|
|
###################################################################
|
|
# Load test metadata
|
|
# ignore any error here--if there were one, it would have been
|
|
# caught during the selection phase and this test would not be
|
|
# running now
|
|
loadtest("${TESTDIR}/test${testnum}");
|
|
readtestkeywords();
|
|
|
|
###################################################################
|
|
# Restore environment variables that were modified in a previous run.
|
|
# Test definition may instruct to (un)set environment vars.
|
|
restore_test_env(1);
|
|
|
|
###################################################################
|
|
# Start the servers needed to run this test case
|
|
my ($why, $error) = singletest_startservers($testnum, \%testtimings);
|
|
|
|
if(!$why) {
|
|
|
|
###############################################################
|
|
# Generate preprocessed test file
|
|
# This must be done after the servers are started so server
|
|
# variables are available for substitution.
|
|
singletest_preprocess($testnum);
|
|
|
|
###############################################################
|
|
# Set up the test environment to run this test case
|
|
singletest_setenv();
|
|
|
|
###############################################################
|
|
# Check that the test environment is fine to run this test case
|
|
if (!$listonly) {
|
|
$why = singletest_precheck($testnum);
|
|
$error = -1;
|
|
}
|
|
}
|
|
return ($why, $error, clearlogs(), \%testtimings);
|
|
}
|
|
|
|
|
|
###################################################################
|
|
# Run a single test case with an environment that already been prepared
|
|
# Returns 0=success, -1=skippable failure, -2=permanent error,
|
|
# 1=unskippable test failure, as first integer, plus any log messages,
|
|
# plus more return values when error is 0
|
|
sub runner_test_run {
|
|
my ($testnum)=@_;
|
|
|
|
if(clearlogs()) {
|
|
logmsg "Warning: log messages were lost\n";
|
|
}
|
|
|
|
#######################################################################
|
|
# Prepare the test environment to run this test case
|
|
my $error = singletest_prepare($testnum);
|
|
if($error) {
|
|
return (-2, clearlogs());
|
|
}
|
|
|
|
#######################################################################
|
|
# Run the test command
|
|
my %testtimings;
|
|
my $cmdres;
|
|
my $dumped_core;
|
|
my $CURLOUT;
|
|
my $tool;
|
|
my $usedvalgrind;
|
|
($error, $cmdres, $dumped_core, $CURLOUT, $tool, $usedvalgrind) = singletest_run($testnum, \%testtimings);
|
|
if($error) {
|
|
return (-2, clearlogs(), \%testtimings);
|
|
}
|
|
|
|
#######################################################################
|
|
# Clean up after test command
|
|
$error = singletest_clean($testnum, $dumped_core, \%testtimings);
|
|
if($error) {
|
|
return ($error, clearlogs(), \%testtimings);
|
|
}
|
|
|
|
#######################################################################
|
|
# Verify that the postcheck succeeded
|
|
$error = singletest_postcheck($testnum);
|
|
if($error) {
|
|
return ($error, clearlogs(), \%testtimings);
|
|
}
|
|
|
|
#######################################################################
|
|
# restore environment variables that were modified
|
|
restore_test_env(0);
|
|
|
|
return (0, clearlogs(), \%testtimings, $cmdres, $CURLOUT, $tool, $usedvalgrind);
|
|
}
|
|
|
|
# Async call runner_clearlocks
|
|
# Called by controller
|
|
sub runnerac_clearlocks {
|
|
return controlleripccall(\&runner_clearlocks, @_);
|
|
}
|
|
|
|
# Async call runner_shutdown
|
|
# This call does NOT generate an IPC response and must be the last IPC call
|
|
# received.
|
|
# Called by controller
|
|
sub runnerac_shutdown {
|
|
my ($runnerid)=$_[0];
|
|
my $err = controlleripccall(\&runner_shutdown, @_);
|
|
|
|
# These have no more use
|
|
close($controllerw{$runnerid});
|
|
undef $controllerw{$runnerid};
|
|
close($controllerr{$runnerid});
|
|
undef $controllerr{$runnerid};
|
|
return $err;
|
|
}
|
|
|
|
# Async call of runner_stopservers
|
|
# Called by controller
|
|
sub runnerac_stopservers {
|
|
return controlleripccall(\&runner_stopservers, @_);
|
|
}
|
|
|
|
# Async call of runner_test_preprocess
|
|
# Called by controller
|
|
sub runnerac_test_preprocess {
|
|
return controlleripccall(\&runner_test_preprocess, @_);
|
|
}
|
|
|
|
# Async call of runner_test_run
|
|
# Called by controller
|
|
sub runnerac_test_run {
|
|
return controlleripccall(\&runner_test_run, @_);
|
|
}
|
|
|
|
###################################################################
|
|
# Call an arbitrary function via IPC
|
|
# The first argument is the function reference, the second is the runner ID
|
|
# Returns 0 on success, -1 on error writing to runner
|
|
# Called by controller (indirectly, via a more specific function)
|
|
sub controlleripccall {
|
|
my $funcref = shift @_;
|
|
my $runnerid = shift @_;
|
|
# Get the name of the function from the reference
|
|
my $cv = svref_2object($funcref);
|
|
my $gv = $cv->GV;
|
|
# Prepend the name to the function arguments so it's marshalled along with them
|
|
unshift @_, $gv->NAME;
|
|
# Marshall the arguments into a flat string
|
|
my $margs = freeze \@_;
|
|
|
|
# Send IPC call via pipe
|
|
my $err;
|
|
while(! defined ($err = syswrite($controllerw{$runnerid}, (pack "L", length($margs)) . $margs)) || $err <= 0) {
|
|
if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
|
|
# Runner has likely died
|
|
return -1;
|
|
}
|
|
# system call was interrupted, probably by ^C; restart it so we stay in sync
|
|
}
|
|
|
|
if(!$multiprocess) {
|
|
# Call the remote function here in single process mode
|
|
ipcrecv();
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
###################################################################
|
|
# Receive async response of a previous call via IPC
|
|
# The first return value is the runner ID or undef on error
|
|
# Called by controller
|
|
sub runnerar {
|
|
my ($runnerid) = @_;
|
|
my $err;
|
|
my $datalen;
|
|
while(! defined ($err = sysread($controllerr{$runnerid}, $datalen, 4)) || $err <= 0) {
|
|
if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
|
|
# Runner is likely dead and closed the pipe
|
|
return undef;
|
|
}
|
|
# system call was interrupted, probably by ^C; restart it so we stay in sync
|
|
}
|
|
my $len=unpack("L", $datalen);
|
|
my $buf;
|
|
while(! defined ($err = sysread($controllerr{$runnerid}, $buf, $len)) || $err <= 0) {
|
|
if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
|
|
# Runner is likely dead and closed the pipe
|
|
return undef;
|
|
}
|
|
# system call was interrupted, probably by ^C; restart it so we stay in sync
|
|
}
|
|
|
|
# Decode response values
|
|
my $resarrayref = thaw $buf;
|
|
|
|
# First argument is runner ID
|
|
# TODO: remove this; it's unneeded since it's passed in
|
|
unshift @$resarrayref, $runnerid;
|
|
return @$resarrayref;
|
|
}
|
|
|
|
###################################################################
|
|
# Returns runner ID if a response from an async call is ready or error
|
|
# First value is ready, second is error, however an error case shows up
|
|
# as ready in Linux, so you can't trust it.
|
|
# argument is 0 for nonblocking, undef for blocking, anything else for timeout
|
|
# Called by controller
|
|
sub runnerar_ready {
|
|
my ($blocking) = @_;
|
|
my $rin = "";
|
|
my %idbyfileno;
|
|
my $maxfileno=0;
|
|
foreach my $p (keys(%controllerr)) {
|
|
my $fd = fileno($controllerr{$p});
|
|
vec($rin, $fd, 1) = 1;
|
|
$idbyfileno{$fd} = $p; # save the runner ID for each pipe fd
|
|
if($fd > $maxfileno) {
|
|
$maxfileno = $fd;
|
|
}
|
|
}
|
|
$maxfileno || die "Internal error: no runners are available to wait on\n";
|
|
|
|
# Wait for any pipe from any runner to be ready
|
|
# This may be interrupted and return EINTR, but this is ignored and the
|
|
# caller will need to later call this function again.
|
|
# TODO: this is relatively slow with hundreds of fds
|
|
my $ein = $rin;
|
|
if(select(my $rout=$rin, undef, my $eout=$ein, $blocking) >= 1) {
|
|
for my $fd (0..$maxfileno) {
|
|
# Return an error condition first in case it's both
|
|
if(vec($eout, $fd, 1)) {
|
|
return (undef, $idbyfileno{$fd});
|
|
}
|
|
if(vec($rout, $fd, 1)) {
|
|
return ($idbyfileno{$fd}, undef);
|
|
}
|
|
}
|
|
die "Internal pipe readiness inconsistency\n";
|
|
}
|
|
return (undef, undef);
|
|
}
|
|
|
|
|
|
###################################################################
|
|
# Cleanly abort and exit the runner
|
|
# This uses print since there is no longer any controller to write logs.
|
|
sub runnerabort{
|
|
print "Controller is gone: runner $$ for $LOGDIR exiting\n";
|
|
my ($error, $logs) = runner_stopservers();
|
|
print $logs;
|
|
runner_shutdown();
|
|
}
|
|
|
|
###################################################################
|
|
# Receive an IPC call in the runner and execute it
|
|
# The IPC is read from the $runnerr pipe and the response is
|
|
# written to the $runnerw pipe
|
|
# Returns 0 if more IPC calls are expected or 1 if the runner should exit
|
|
sub ipcrecv {
|
|
my $err;
|
|
my $datalen;
|
|
while(! defined ($err = sysread($runnerr, $datalen, 4)) || $err <= 0) {
|
|
if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
|
|
# pipe has closed; controller is gone and we must exit
|
|
runnerabort();
|
|
# Special case: no response will be forthcoming
|
|
return 1;
|
|
}
|
|
# system call was interrupted, probably by ^C; restart it so we stay in sync
|
|
}
|
|
my $len=unpack("L", $datalen);
|
|
my $buf;
|
|
while(! defined ($err = sysread($runnerr, $buf, $len)) || $err <= 0) {
|
|
if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
|
|
# pipe has closed; controller is gone and we must exit
|
|
runnerabort();
|
|
# Special case: no response will be forthcoming
|
|
return 1;
|
|
}
|
|
# system call was interrupted, probably by ^C; restart it so we stay in sync
|
|
}
|
|
|
|
# Decode the function name and arguments
|
|
my $argsarrayref = thaw $buf;
|
|
|
|
# The name of the function to call is the first argument
|
|
my $funcname = shift @$argsarrayref;
|
|
|
|
# print "ipcrecv $funcname\n";
|
|
# Synchronously call the desired function
|
|
my @res;
|
|
if($funcname eq "runner_clearlocks") {
|
|
@res = runner_clearlocks(@$argsarrayref);
|
|
}
|
|
elsif($funcname eq "runner_shutdown") {
|
|
runner_shutdown(@$argsarrayref);
|
|
# Special case: no response will be forthcoming
|
|
return 1;
|
|
}
|
|
elsif($funcname eq "runner_stopservers") {
|
|
@res = runner_stopservers(@$argsarrayref);
|
|
}
|
|
elsif($funcname eq "runner_test_preprocess") {
|
|
@res = runner_test_preprocess(@$argsarrayref);
|
|
}
|
|
elsif($funcname eq "runner_test_run") {
|
|
@res = runner_test_run(@$argsarrayref);
|
|
} else {
|
|
die "Unknown IPC function $funcname\n";
|
|
}
|
|
# print "ipcrecv results\n";
|
|
|
|
# Marshall the results to return
|
|
$buf = freeze \@res;
|
|
|
|
while(! defined ($err = syswrite($runnerw, (pack "L", length($buf)) . $buf)) || $err <= 0) {
|
|
if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
|
|
# pipe has closed; controller is gone and we must exit
|
|
runnerabort();
|
|
# Special case: no response will be forthcoming
|
|
return 1;
|
|
}
|
|
# system call was interrupted, probably by ^C; restart it so we stay in sync
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
###################################################################
|
|
# Kill the server processes that still have lock files in a directory
|
|
sub runner_clearlocks {
|
|
my ($lockdir)=@_;
|
|
if(clearlogs()) {
|
|
logmsg "Warning: log messages were lost\n";
|
|
}
|
|
clearlocks($lockdir);
|
|
return clearlogs();
|
|
}
|
|
|
|
|
|
###################################################################
|
|
# Kill all server processes
|
|
sub runner_stopservers {
|
|
my $error = stopservers($verbose);
|
|
my $logs = clearlogs();
|
|
return ($error, $logs);
|
|
}
|
|
|
|
###################################################################
|
|
# Shut down this runner
|
|
sub runner_shutdown {
|
|
close($runnerr);
|
|
undef $runnerr;
|
|
close($runnerw);
|
|
undef $runnerw;
|
|
}
|
|
|
|
|
|
1;
|