Newer
Older
# don't retry if the server doesn't work
if ($doesntrun{$pidfile}) {
return (0,0);
}
my $pid = checkserver($pidfile);
if($pid >= 0) {
stopserver($pid);
}
# start our server:
my $flag=$debugprotocol?"-v ":"";
$flag .= "-s \"$srcdir\" ";
if($id) {
$flag .="--id $id ";
}
if($ipv6) {
$flag .="--ipv6 ";
}
$cmd="./server/tftpd --pidfile $pidfile $flag $port";
my ($tftppid, $pid2) = startnew($cmd, $pidfile, 15, 0);
if($tftppid <= 0 || !kill(0, $tftppid)) {
logmsg "RUN: failed to start the TFTP$id$nameext server\n";
$doesntrun{$pidfile} = 1;
return (0,0);
}
# Server is up. Verify that we can speak to it.
if(!verifyserver("tftp", $ip, $port)) {
logmsg "RUN: TFTP$id$nameext server failed verification\n";
# failed to talk to it properly. Kill the server and return failure
stopserver("$tftppid $pid2");
$doesntrun{$pidfile} = 1;
logmsg "RUN: TFTP$id$nameext server is now running PID $tftppid\n";
#######################################################################
# Start the scp/sftp server
#
sub runsshserver {
my ($id, $verbose, $ipv6) = @_;
my $ip=$HOSTIP;
my $port = $SSHPORT;
my $socksport = $SOCKSPORT;
my $pidfile = $SSHPIDFILE;
# don't retry if the server doesn't work
if ($doesntrun{$pidfile}) {
logmsg "TRACESSH:runsshserver: ssh server previously failed to start with pidfile: $pidfile\n";
return (0,0);
}
my $pid = checkserver($pidfile);
logmsg "TRACESSH:runsshserver: checkserver on pidfile: $pidfile returns pid: $pid\n";
if($pid > 0) {
stopserver($pid);
}
my $flag=$verbose?'-v ':'';
$flag .= '-d ' if($debugprotocol);
my $cmd="$perl $srcdir/sshserver.pl ${flag}-u $USER -l $ip -p $port -s $socksport";
logmsg "TRACESSH:runsshserver: calling startnew with cmd: $cmd\n";
my ($sshpid, $pid2) = startnew($cmd, $pidfile, 60, 0);
logmsg "TRACESSH:runsshserver: startnew returns sshpid: $sshpid pid2: $pid2\n";
if($sshpid <= 0 || !kill(0, $sshpid)) {
# it is NOT alive
logmsg "RUN: failed to start the SSH server\n";
logmsg "TRACESSH:runsshserver: calling stopserver with pid2: $pid2\n";
stopserver("$pid2");
$doesntrun{$pidfile} = 1;
logmsg "TRACESSH:runsshserver: later dont try to start a server with pidfile: $pidfile\n";
return (0,0);
}
if (!verifyserver('ssh',$ip,$port)) {
logmsg "RUN: SSH server failed verification\n";
# failed to talk to it properly. Kill the server and return failure
logmsg "TRACESSH:runsshserver: calling stopserver with sshpid: $sshpid pid2: $pid2\n";
stopserver("$sshpid $pid2");
$doesntrun{$pidfile} = 1;
logmsg "TRACESSH:runsshserver: later dont try to start a server with pidfile: $pidfile\n";
return (0,0);
}
if($verbose) {
logmsg "RUN: SSH server is now running PID $sshpid\n";
}
return ($pid2, $sshpid);
}
#######################################################################
# Start the socks server
#
sub runsocksserver {
my ($id, $verbose, $ipv6) = @_;
my $ip=$HOSTIP;
my $port = $SOCKSPORT;
my $pidfile = $SOCKSPIDFILE;
# don't retry if the server doesn't work
if ($doesntrun{$pidfile}) {
return (0,0);
}
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
my $pid = checkserver($pidfile);
logmsg "TRACESSH:runsocksserver: checkserver on pidfile: $pidfile returns pid: $pid\n";
if($pid > 0) {
stopserver($pid);
}
unlink($pidfile);
# The ssh server must be already running
if(!$run{'ssh'}) {
logmsg "RUN: SOCKS server cannot find running SSH server\n";
$doesntrun{$pidfile} = 1;
return (0,0);
}
# Find out ssh client canonical file name
my $ssh = find_ssh();
if(!$ssh) {
logmsg "RUN: SOCKS server cannot find $sshexe\n";
$doesntrun{$pidfile} = 1;
return (0,0);
}
# Find out ssh client version info
($sshid, $sshvernum, $sshverstr, $ssherror) = sshversioninfo($ssh);
if(!$sshid) {
# Not an OpenSSH or SunSSH ssh client
logmsg "$ssherror\n" if($verbose);
logmsg "SCP, SFTP and SOCKS tests require OpenSSH 2.9.9 or later\n";
$doesntrun{$pidfile} = 1;
return (0,0);
}
# Verify minimum ssh client version
if((($sshid =~ /OpenSSH/) && ($sshvernum < 299)) ||
(($sshid =~ /SunSSH/) && ($sshvernum < 100))) {
logmsg "ssh client found $ssh is $sshverstr\n";
logmsg "SCP, SFTP and SOCKS tests require OpenSSH 2.9.9 or later\n";
$doesntrun{$pidfile} = 1;
return (0,0);
}
logmsg "ssh client found $ssh is $sshverstr\n" if($verbose);
# Config file options for ssh client are previously set from sshserver.pl
if(! -e $sshconfig) {
logmsg "RUN: SOCKS server cannot find $sshconfig\n";
$doesntrun{$pidfile} = 1;
return (0,0);
}
# start our socks server
my $cmd="$ssh -N -F $sshconfig $ip > $sshlog 2>&1";
my ($sshpid, $pid2) = startnew($cmd, $pidfile, 30, 1);
logmsg "TRACESSH:runsocksserver: startnew returns sshpid: $sshpid pid2: $pid2\n";
if($sshpid <= 0 || !kill(0, $sshpid)) {
# it is NOT alive
logmsg "RUN: failed to start the SOCKS server\n";
display_sshlog();
$doesntrun{$pidfile} = 1;
return (0,0);
}
# Ugly hack but ssh doesn't support pid files
if (!verifyserver('socks',$ip,$port)) {
logmsg "RUN: SOCKS server failed verification\n";
display_sshlog();
# failed to talk to it properly. Kill the server and return failure
stopserver("$sshpid $pid2");
$doesntrun{$pidfile} = 1;
return (0,0);
}
if($verbose) {
logmsg "RUN: SOCKS server is now running PID $sshpid\n";
}
return ($pid2, $sshpid);
}
#######################################################################
# Remove all files in the specified directory
#
sub cleardir {
my $dir = $_[0];
my $count;
# Get all files
opendir(DIR, $dir) ||
return 0; # can't open dir
while($file = readdir(DIR)) {
if($file !~ /^\./) {
unlink("$dir/$file");
$count++;
}
}
closedir DIR;
return $count;
}
#######################################################################
# filter out the specified pattern from the given input file and store the
# results in the given output file
#
sub filteroff {
my $infile=$_[0];
my $filter=$_[1];
my $ofile=$_[2];
open(IN, "<$infile")
open(OUT, ">$ofile")
# logmsg "FILTER: off $filter from $infile to $ofile\n";
close(IN);
close(OUT);
#######################################################################
# compare test results with the expected output, we might filter off
# some pattern that is allowed to differ, output test results
#
# filter off patterns _before_ this comparison!
my ($subject, $firstref, $secondref)=@_;
my $result = compareparts($firstref, $secondref);
if($result) {
if(!$short) {
logmsg "\n $subject FAILED:\n";
logmsg showdiff($LOGDIR, $firstref, $secondref);
}
else {
logmsg "FAILED\n";
#######################################################################
# display information about curl and the host the test suite runs on
#
sub checksystem {
unlink($memdump); # remove this if there was one left
my $curl;
my $libcurl;
my $versretval;
my $versnoexec;
my @version=();
my $curlverout="$LOGDIR/curlverout.log";
my $curlvererr="$LOGDIR/curlvererr.log";
my $versioncmd="$CURL --version 1>$curlverout 2>$curlvererr";
unlink($curlverout);
unlink($curlvererr);
$versretval = runclient($versioncmd);
$versnoexec = $!;
open(VERSOUT, "<$curlverout");
@version = <VERSOUT>;
close(VERSOUT);
for(@version) {
chomp;
if($_ =~ /^curl/) {
$curl = $_;
$curl =~ s/^(.*)(libcurl.*)/$1/g;
$libcurl = $2;
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
if($curl =~ /mingw32/) {
# This is a windows minw32 build, we need to translate the
# given path to the "actual" windows path.
my @m = `mount`;
my $matchlen;
my $bestmatch;
my $mount;
# example mount output:
# C:\DOCUME~1\Temp on /tmp type user (binmode,noumount)
# c:\ActiveState\perl on /perl type user (binmode)
# C:\msys\1.0\bin on /usr/bin type user (binmode,cygexec,noumount)
# C:\msys\1.0\bin on /bin type user (binmode,cygexec,noumount)
foreach $mount (@m) {
if( $mount =~ /(.*) on ([^ ]*) type /) {
my ($mingw, $real)=($2, $1);
if($pwd =~ /^$mingw/) {
# the path we got from pwd starts with the path
# we found on this line in the mount output
my $len = length($real);
if($len > $matchlen) {
# we remember the match that is the longest
$matchlen = $len;
$bestmatch = $real;
}
}
}
}
if(!$matchlen) {
logmsg "Serious error, can't find our \"real\" path\n";
}
else {
# now prepend the prefix from the mount command to build
# our "actual path"
$pwd = "$bestmatch$pwd";
}
$pwd =~ s#\\#/#g;
}
elsif ($curl =~ /win32/) {
Daniel Stenberg
committed
# Native Windows builds don't understand the
# output of cygwin's pwd. It will be
# something like /cygdrive/c/<some path>.
#
# Use the cygpath utility to convert the
# working directory to a Windows friendly
# path. The -m option converts to use drive
# letter:, but it uses / instead \. Forward
# slashes (/) are easier for us. We don't
# have to escape them to get them to curl
# through a shell.
chomp($pwd = `cygpath -m $pwd`);
}
elsif ($libcurl =~ /openssl/i) {
Daniel Stenberg
committed
$ssllib="OpenSSL";
elsif ($libcurl =~ /gnutls/i) {
Daniel Stenberg
committed
$ssllib="GnuTLS";
elsif ($libcurl =~ /nss/i) {
$has_nss=1;
Daniel Stenberg
committed
$ssllib="NSS";
}
elsif ($libcurl =~ /yassl/i) {
$has_yassl=1;
$has_openssl=1;
$ssllib="yassl";
}
}
elsif($_ =~ /^Protocols: (.*)/i) {
# these are the protocols compiled in to this libcurl
@protocols = split(' ', $1);
# Generate a "proto-ipv6" version of each protocol to match the
# IPv6 <server> name. This works even if IPv6 support isn't
# compiled in because the <features> test will fail.
push @protocols, map($_ . "-ipv6", @protocols);
# 'none' is used in test cases to mean no server
push @protocols, ('none');
}
elsif($_ =~ /^Features: (.*)/i) {
if($feat =~ /debug/i) {
# debug is a listed "feature", use that knowledge
$curl_debug = 1;
# set the NETRC debug env
$ENV{'CURL_DEBUG_NETRC'} = 'log/netrc';
}
if($feat =~ /SSL/i) {
# ssl enabled
$ssl_version=1;
}
if($feat =~ /Largefile/i) {
# large file support
$large_file=1;
}
Daniel Stenberg
committed
if($feat =~ /IDN/i) {
# IDN support
$has_idn=1;
}
if($feat =~ /libz/i) {
$has_libz = 1;
}
Daniel Stenberg
committed
if($feat =~ /NTLM/i) {
# NTLM enabled
$has_ntlm=1;
}
}
}
if(!$curl) {
logmsg "unable to get curl's version, further details are:\n";
logmsg "issued command: \n";
logmsg "$versioncmd \n";
if ($versretval == -1) {
logmsg "command failed with: \n";
logmsg "$versnoexec \n";
}
elsif ($versretval & 127) {
logmsg sprintf("command died with signal %d, and %s coredump.\n",
($versretval & 127), ($versretval & 128)?"a":"no");
}
else {
logmsg sprintf("command exited with value %d \n", $versretval >> 8);
}
logmsg "contents of $curlverout: \n";
displaylogcontent("$curlverout");
logmsg "contents of $curlvererr: \n";
displaylogcontent("$curlvererr");
die "couldn't get curl's version";
}
if(-r "../lib/config.h") {
open(CONF, "<../lib/config.h");
if($_ =~ /^\#define HAVE_GETRLIMIT/) {
$has_getrlimit = 1;
}
}
}
Daniel Stenberg
committed
# client has ipv6 support
# check if the HTTP server has it!
my @sws = `server/sws --version`;
if($sws[0] =~ /IPv6/) {
# HTTP server has ipv6 support!
$http_ipv6 = 1;
}
Daniel Stenberg
committed
# check if the FTP server has it!
@sws = `server/sockfilt --version`;
Daniel Stenberg
committed
if($sws[0] =~ /IPv6/) {
# FTP server has ipv6 support!
$ftp_ipv6 = 1;
}
if(!$curl_debug && $torture) {
die "can't run torture tests since curl was not build with debug";
}
# curl doesn't list cryptographic support separately, so assume it's
# always available
$has_crypto=1;
my $hostname=join(' ', runclientoutput("hostname"));
my $hosttype=join(' ', runclientoutput("uname -a"));
logmsg ("********* System characteristics ******** \n",
"* $curl\n",
"* $libcurl\n",
"* System: $hosttype");
logmsg sprintf("* Server SSL: %s\n", $stunnel?"ON":"OFF");
logmsg sprintf("* libcurl SSL: %s\n", $ssl_version?"ON":"OFF");
logmsg sprintf("* libcurl debug: %s\n", $curl_debug?"ON":"OFF");
logmsg sprintf("* valgrind: %s\n", $valgrind?"ON":"OFF");
logmsg sprintf("* HTTP IPv6 %s\n", $http_ipv6?"ON":"OFF");
logmsg sprintf("* FTP IPv6 %s\n", $ftp_ipv6?"ON":"OFF");
logmsg sprintf("* HTTP port: %d\n", $HTTPPORT);
logmsg sprintf("* FTP port: %d\n", $FTPPORT);
logmsg sprintf("* FTP port 2: %d\n", $FTP2PORT);
Daniel Stenberg
committed
if($stunnel) {
logmsg sprintf("* FTPS port: %d\n", $FTPSPORT);
logmsg sprintf("* HTTPS port: %d\n", $HTTPSPORT);
logmsg sprintf("* HTTP IPv6 port: %d\n", $HTTP6PORT);
Daniel Stenberg
committed
}
Daniel Stenberg
committed
if($ftp_ipv6) {
logmsg sprintf("* FTP IPv6 port: %d\n", $FTP6PORT);
Daniel Stenberg
committed
}
logmsg sprintf("* TFTP port: %d\n", $TFTPPORT);
if($tftp_ipv6) {
logmsg sprintf("* TFTP IPv6 port: %d\n", $TFTP6PORT);
}
logmsg sprintf("* SCP/SFTP port: %d\n", $SSHPORT);
logmsg sprintf("* SOCKS port: %d\n", $SOCKSPORT);
if($ssl_version) {
logmsg sprintf("* SSL library: %s\n", $ssllib);
$has_textaware = ($^O eq 'MSWin32') || ($^O eq 'msys');
logmsg sprintf("* Libtool lib: %s\n", $libtool?"ON":"OFF");
logmsg "***************************************** \n";
#######################################################################
# substitute the variable stuff into either a joined up file or
# a command, in either case passed by reference
#
sub subVariables {
my ($thing) = @_;
$$thing =~ s/%HOSTIP/$HOSTIP/g;
Daniel Stenberg
committed
$$thing =~ s/%HTTPPORT/$HTTPPORT/g;
$$thing =~ s/%HOST6IP/$HOST6IP/g;
$$thing =~ s/%HTTP6PORT/$HTTP6PORT/g;
$$thing =~ s/%HTTPSPORT/$HTTPSPORT/g;
$$thing =~ s/%FTPPORT/$FTPPORT/g;
Daniel Stenberg
committed
$$thing =~ s/%FTP6PORT/$FTP6PORT/g;
Daniel Stenberg
committed
$$thing =~ s/%FTP2PORT/$FTP2PORT/g;
$$thing =~ s/%FTPSPORT/$FTPSPORT/g;
$$thing =~ s/%SRCDIR/$srcdir/g;
$$thing =~ s/%PWD/$pwd/g;
$$thing =~ s/%TFTPPORT/$TFTPPORT/g;
$$thing =~ s/%TFTP6PORT/$TFTP6PORT/g;
$$thing =~ s/%SSHPORT/$SSHPORT/g;
$$thing =~ s/%SOCKSPORT/$SOCKSPORT/g;
$$thing =~ s/%CURL/$CURL/g;
$$thing =~ s/%USER/$USER/g;
$$thing =~ s/%CLIENTIP/$CLIENTIP/g;
$$thing =~ s/%CLIENT6IP/$CLIENT6IP/g;
Daniel Stenberg
committed
# The purpose of FTPTIME2 and FTPTIME3 is to provide times that can be
# used for time-out tests and that whould work on most hosts as these
# adjust for the startup/check time for this particular host. We needed
# to do this to make the test suite run better on very slow hosts.
my $ftp2 = $ftpchecktime * 2;
my $ftp3 = $ftpchecktime * 3;
$$thing =~ s/%FTPTIME2/$ftp2/g;
$$thing =~ s/%FTPTIME3/$ftp3/g;
Daniel Stenberg
committed
sub fixarray {
my @in = @_;
for(@in) {
subVariables \$_;
}
return @in;
}
#######################################################################
# Run a single specified test case
#
my ($testnum, $count, $total)=@_;
my @what;
my $why;
Daniel Stenberg
committed
my %feature;
Daniel Stenberg
committed
my $cmd;
# load the test case file definition
if(loadtest("${TESTDIR}/test${testnum}")) {
if($verbose) {
# this is not a test
logmsg "RUN: $testnum doesn't look like a test case\n";
Daniel Stenberg
committed
$why = "no test";
}
else {
@what = getpart("client", "features");
for(@what) {
my $f = $_;
$f =~ s/\s//g;
Daniel Stenberg
committed
$feature{$f}=$f; # we require this feature
if($f eq "SSL") {
if($ssl_version) {
next;
}
}
elsif($f eq "OpenSSL") {
if($has_openssl) {
next;
}
}
elsif($f eq "GnuTLS") {
if($has_gnutls) {
next;
}
}
elsif($f eq "NSS") {
if($has_nss) {
next;
}
}
elsif($f eq "netrc_debug") {
if($curl_debug) {
next;
}
}
elsif($f eq "large_file") {
if($large_file) {
next;
}
}
Daniel Stenberg
committed
elsif($f eq "idn") {
if($has_idn) {
next;
}
}
elsif($f eq "ipv6") {
if($has_ipv6) {
next;
}
}
elsif($f eq "libz") {
if($has_libz) {
next;
}
}
Daniel Stenberg
committed
elsif($f eq "NTLM") {
if($has_ntlm) {
next;
}
}
elsif($f eq "getrlimit") {
if($has_getrlimit) {
next;
}
}
elsif($f eq "crypto") {
if($has_crypto) {
next;
}
}
elsif($f eq "socks") {
next;
}
# See if this "feature" is in the list of supported protocols
elsif (grep /^$f$/, @protocols) {
next;
}
Daniel Stenberg
committed
$why = "curl lacks $f support";
last;
}
Daniel Stenberg
committed
if(!$why) {
$why = serverfortest($testnum);
}
if(!$why) {
my @keywords = getpart("info", "keywords");
my $k;
for $k (@keywords) {
chomp $k;
if ($disabled_keywords{$k}) {
$why = "disabled by keyword";
}
}
}
Daniel Stenberg
committed
if(!$why) {
Daniel Stenberg
committed
my @precheck = getpart("client", "precheck");
Daniel Stenberg
committed
$cmd = $precheck[0];
Daniel Stenberg
committed
chomp $cmd;
subVariables \$cmd;
Daniel Stenberg
committed
if($cmd) {
my @o = `$cmd 2>/dev/null`;
Daniel Stenberg
committed
if($o[0]) {
$why = $o[0];
chomp $why;
}
logmsg "prechecked $cmd\n" if($verbose);
Daniel Stenberg
committed
}
}
Daniel Stenberg
committed
# there's a problem, count it as "skipped"
$skipped++;
$skipped{$why}++;
$teststat[$testnum]=$why; # store reason for this test case
if(!$short) {
Daniel Stenberg
committed
printf "test %03d SKIPPED: $why\n", $testnum;
}
return -1;
}
logmsg sprintf("test %03d...", $testnum);
# extract the reply data
my @reply = getpart("reply", "data");
my @replycheck = getpart("reply", "datacheck");
if (@replycheck) {
# we use this file instead to check the final output against
my %hash = getpartattr("reply", "datacheck");
if($hash{'nonewline'}) {
# Yes, we must cut off the final newline from the final line
# of the datacheck
chomp($replycheck[$#replycheck]);
}
Daniel Stenberg
committed
my @curlcmd= fixarray ( getpart("client", "command") );
# this is the valid protocol blurb curl should generate
Daniel Stenberg
committed
my @protocol= fixarray ( getpart("verify", "protocol") );
# redirected stdout/stderr to these files
$STDOUT="$LOGDIR/stdout$testnum";
$STDERR="$LOGDIR/stderr$testnum";
# if this section exists, we verify that the stdout contained this:
Daniel Stenberg
committed
my @validstdout = fixarray ( getpart("verify", "stdout") );
# if this section exists, we verify upload
my @upload = getpart("verify", "upload");
# if this section exists, it might be FTP server instructions:
my @ftpservercmd = getpart("reply", "servercmd");
my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout
my @testname= getpart("client", "name");
if(!$short) {
my $name = $testname[0];
$name =~ s/\n//g;
logmsg "[$name]\n";
}
if($listonly) {
return 0; # look successful
}
my @codepieces = getpart("client", "tool");
my $tool="";
if(@codepieces) {
$tool = $codepieces[0];
chomp $tool;
}
Daniel Stenberg
committed
# remove server output logfiles
Daniel Stenberg
committed
unlink($SERVER2IN);
if(@ftpservercmd) {
# write the instructions to file
writearray($FTPDCMD, \@ftpservercmd);
}
my (@setenv)= getpart("client", "setenv");
my @envs;
my $s;
for $s (@setenv) {
chomp $s; # cut off the newline
subVariables \$s;
if($s =~ /([^=]*)=(.*)/) {
my ($var, $content)=($1, $2);
$ENV{$var}=$content;
# remember which, so that we can clear them afterwards!
push @envs, $var;
}
}
Daniel Stenberg
committed
my @blaha;
($cmd, @blaha)= getpart("client", "command");
# make some nice replace operations
$cmd =~ s/\n//g; # no newlines please
if($curl_debug) {
unlink($memdump);
}
my @inputfile=getpart("client", "file");
if(@inputfile) {
# we need to generate a file before this test is invoked
Daniel Stenberg
committed
my %fileattr = getpartattr("client", "file");
Daniel Stenberg
committed
my $filename=$fileattr{'name'};
logmsg "ERROR: section client=>file has no name attribute\n";
my $fileContent = join('', @inputfile);
subVariables \$fileContent;
# logmsg "DEBUG: writing file " . $filename . "\n";
open(OUTFILE, ">$filename");
binmode OUTFILE; # for crapage systems, use binary
print OUTFILE $fileContent;
close(OUTFILE);
my %cmdhash = getpartattr("client", "command");
if($cmdhash{'option'} !~ /no-output/) {
#We may slap on --output!
$out=" --output $CURLOUT ";
my $cmdargs;
if(!$tool) {
# run curl, add -v for debug information output
$cmdargs ="$out --include -v --trace-time $cmd";
}
else {
$cmdargs = " $cmd"; # $cmd is the command line for the test file
$CURLOUT = $STDOUT; # sends received data to stdout
}
my @stdintest = getpart("client", "stdin");
if(@stdintest) {
my $stdinfile="$LOGDIR/stdin-for-$testnum";
writearray($stdinfile, \@stdintest);
$cmdargs .= " <$stdinfile";
if(!$tool) {
$CMDLINE="$CURL";
else {
$CMDLINE="$LIBDIR/$tool";
if(! -f $CMDLINE) {
print "The tool set in the test case for this: '$tool' does not exist\n";
return -1;
}
my $usevalgrind = $valgrind && ((getpart("verify", "valgrind"))[0] !~ /disable/);
if($usevalgrind) {
Daniel Stenberg
committed
$CMDLINE = "$valgrind ".$valgrind_tool."--leak-check=yes --num-callers=16 ${valgrind_logfile}=log/valgrind$testnum $CMDLINE";
}
logmsg "$CMDLINE\n";
Daniel Stenberg
committed
}
print CMDLOG "$CMDLINE\n";
Daniel Stenberg
committed
unlink("core");
my $dumped_core;
my $cmdres;
# Apr 2007: precommand isn't being used and could be removed
my @precommand= getpart("client", "precommand");
if($precommand[0]) {
# this is pure perl to eval!
my $code = join("", @precommand);
eval $code;
if($@) {
logmsg "perl: $code\n";
logmsg "precommand: $@";
open(GDBCMD, ">log/gdbcmd");
print GDBCMD "set args $cmdargs\n";
print GDBCMD "show args\n";
close(GDBCMD);
}
# run the command line we built
if ($torture) {
$cmdres = torture($CMDLINE,
"$gdb --directory libtest $DBGCURL -x log/gdbcmd");
}
elsif($gdbthis) {
runclient("$gdb --directory libtest $DBGCURL -x log/gdbcmd");
$cmdres=0; # makes it always continue after a debugged run
$cmdres = runclient("$CMDLINE");
my $signal_num = $cmdres & 127;
Daniel Stenberg
committed
$dumped_core = $cmdres & 128;
if(!$anyway && ($signal_num || $dumped_core)) {
$cmdres = 1000;
}
else {
$cmdres /= 256;
}
Daniel Stenberg
committed
if(!$dumped_core) {
if(-r "core") {
# there's core file present now!
$dumped_core = 1;
}
}
if($dumped_core) {
logmsg "core dumped\n";
logmsg "running gdb for post-mortem analysis:\n";
open(GDBCMD, ">log/gdbcmd2");
print GDBCMD "bt\n";
close(GDBCMD);
runclient("$gdb --directory libtest -x log/gdbcmd2 -batch $DBGCURL core ");
Daniel Stenberg
committed
# unlink("log/gdbcmd2");
}
}
# run the postcheck command
my @postcheck= getpart("client", "postcheck");
$cmd = $postcheck[0];
chomp $cmd;
subVariables \$cmd;
if($cmd) {
my $rc = runclient("$cmd");
logmsg " postcheck FAILED\n";
return 1;
}
logmsg "postchecked $cmd\n" if($verbose);
}
# remove the special FTP command file after each test!
unlink($FTPDCMD);
my $e;
for $e (@envs) {
$ENV{$e}=""; # clean up
}
# Skip all the verification on torture tests
if(!$cmdres && !$keepoutfiles) {
cleardir($LOGDIR);
}
return $cmdres;
}
my @err = getpart("verify", "errorcode");
my $errorcode = $err[0] || "0";
my $ok="";
my $res;
if (@validstdout) {
# verify redirected stdout