| #!/usr/bin/env perl |
| #*************************************************************************** |
| # _ _ ____ _ |
| # Project ___| | | | _ \| | |
| # / __| | | | |_) | | |
| # | (__| |_| | _ <| |___ |
| # \___|\___/|_| \_\_____| |
| # |
| # Copyright (C) 1998 - 2005, 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 http://curl.haxx.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. |
| # |
| # $Id$ |
| ########################################################################### |
| # These should be the only variables that might be needed to get edited: |
| |
| use strict; |
| #use Time::HiRes qw( gettimeofday ); |
| #use warnings; |
| |
| @INC=(@INC, $ENV{'srcdir'}, "."); |
| |
| require "getpart.pm"; # array functions |
| require "valgrind.pm"; # valgrind report parser |
| require "ftp.pm"; |
| |
| my $srcdir = $ENV{'srcdir'} || '.'; |
| my $HOSTIP="127.0.0.1"; |
| my $HOST6IP="[::1]"; |
| |
| my $base = 8990; # base port number |
| |
| my $HTTPPORT; # HTTP server port |
| my $HTTP6PORT; # HTTP IPv6 server port |
| my $HTTPSPORT; # HTTPS server port |
| my $FTPPORT; # FTP server port |
| my $FTP2PORT; # FTP server 2 port |
| my $FTPSPORT; # FTPS server port |
| my $FTP6PORT; # FTP IPv6 server port |
| |
| my $CURL="../src/curl"; # what curl executable to run on the tests |
| my $DBGCURL=$CURL; #"../src/.libs/curl"; # alternative for debugging |
| my $LOGDIR="log"; |
| my $TESTDIR="$srcdir/data"; |
| my $LIBDIR="./libtest"; |
| my $SERVERIN="$LOGDIR/server.input"; # what curl sent the server |
| my $SERVER2IN="$LOGDIR/server2.input"; # what curl sent the second server |
| my $CURLLOG="$LOGDIR/curl.log"; # all command lines run |
| my $FTPDCMD="$LOGDIR/ftpserver.cmd"; # copy ftp server instructions here |
| |
| # Normally, all test cases should be run, but at times it is handy to |
| # simply run a particular one: |
| my $TESTCASES="all"; |
| |
| # To run specific test cases, set them like: |
| # $TESTCASES="1 2 3 7 8"; |
| |
| ####################################################################### |
| # No variables below this point should need to be modified |
| # |
| |
| my $HTTPPIDFILE=".http.pid"; |
| my $HTTP6PIDFILE=".http6.pid"; |
| my $HTTPSPIDFILE=".https.pid"; |
| my $FTPPIDFILE=".ftp.pid"; |
| my $FTP6PIDFILE=".ftp6.pid"; |
| my $FTP2PIDFILE=".ftp2.pid"; |
| my $FTPSPIDFILE=".ftps.pid"; |
| |
| # invoke perl like this: |
| my $perl="perl -I$srcdir"; |
| |
| # this gets set if curl is compiled with debugging: |
| my $curl_debug=0; |
| |
| # name of the file that the memory debugging creates: |
| my $memdump="$LOGDIR/memdump"; |
| |
| # the path to the script that analyzes the memory debug output file: |
| my $memanalyze="./memanalyze.pl"; |
| |
| my $stunnel = checkcmd("stunnel"); |
| my $valgrind = checkcmd("valgrind"); |
| my $valgrind_logfile="--logfile"; |
| my $start; |
| |
| my $valgrind_tool; |
| if($valgrind) { |
| # since valgrind 2.1.x, '--tool' option is mandatory |
| # use it, if it is supported by the version installed on the system |
| system("valgrind --help 2>&1 | grep -- --tool > /dev/null 2>&1"); |
| if (($? >> 8)==0) { |
| $valgrind_tool="--tool=memcheck "; |
| } |
| open(C, "<$CURL"); |
| my $l = <C>; |
| if($l =~ /^\#\!/) { |
| # The first line starts with "#!" which implies a shell-script. |
| # This means libcurl is built shared and curl is a wrapper-script |
| # Disable valgrind in this setup |
| $valgrind=0; |
| } |
| close(C); |
| |
| # valgrind 3 renamed the --logfile option to --log-file!!! |
| my $ver=`valgrind --version`; |
| # cut off all but digits and dots |
| $ver =~ s/[^0-9.]//g; |
| |
| if($ver >= 3) { |
| $valgrind_logfile="--log-file"; |
| } |
| } |
| |
| my $gdb = checkcmd("gdb"); |
| |
| my $ssl_version; # set if libcurl is built with SSL support |
| my $large_file; # set if libcurl is built with large file support |
| my $has_idn; # set if libcurl is built with IDN support |
| my $http_ipv6; # set if HTTP server has IPv6 support |
| my $ftp_ipv6; # set if FTP server has IPv6 support |
| my $has_ipv6; # set if libcurl is built with IPv6 support |
| my $has_libz; # set if libcurl is built with libz support |
| my $has_getrlimit; # set if system has getrlimit() |
| my $has_ntlm; # set if libcurl is built with NTLM support |
| my $has_openssl; # set if libcurl is built with OpenSSL |
| my $has_gnutls; # set if libcurl is built with GnuTLS |
| my $has_textaware; # set if running on a system that has a text mode concept |
| # on files. Windows for example |
| |
| my $skipped=0; # number of tests skipped; reported in main loop |
| my %skipped; # skipped{reason}=counter, reasons for skip |
| my @teststat; # teststat[testnum]=reason, reasons for skip |
| |
| ####################################################################### |
| # variables the command line options may set |
| # |
| |
| my $short; |
| my $verbose; |
| my $debugprotocol; |
| my $anyway; |
| my $gdbthis; # run test case with gdb debugger |
| my $keepoutfiles; # keep stdout and stderr files after tests |
| my $listonly; # only list the tests |
| my $postmortem; # display detailed info about failed tests |
| |
| my $pwd; # current working directory |
| |
| my %run; # running server |
| |
| # torture test variables |
| my $torture; |
| my $tortnum; |
| my $tortalloc; |
| |
| # open and close each time to allow removal at any time |
| sub logmsg { |
| # uncomment the Time::HiRes usage for this |
| # my ($seconds, $microseconds) = gettimeofday; |
| # my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = |
| # localtime($seconds); |
| my $t; |
| if(1) { |
| # $t = sprintf ("%02d:%02d:%02d.%06d ", $hour, $min, $sec, |
| # $microseconds); |
| } |
| for(@_) { |
| print "${t}$_"; |
| } |
| } |
| |
| chomp($pwd = `pwd`); |
| |
| # enable memory debugging if curl is compiled with it |
| $ENV{'CURL_MEMDEBUG'} = $memdump; |
| $ENV{'HOME'}=$pwd; |
| |
| sub catch_zap { |
| my $signame = shift; |
| logmsg "runtests.pl received SIG$signame, exiting\n"; |
| stopservers(1); |
| die "Somebody sent me a SIG$signame"; |
| } |
| $SIG{INT} = \&catch_zap; |
| $SIG{KILL} = \&catch_zap; |
| |
| ########################################################################## |
| # Clear all possible '*_proxy' environment variables for various protocols |
| # to prevent them to interfere with our testing! |
| |
| my $protocol; |
| foreach $protocol (('ftp', 'http', 'ftps', 'https', 'gopher', 'no')) { |
| my $proxy = "${protocol}_proxy"; |
| # clear lowercase version |
| $ENV{$proxy}=undef; |
| # clear uppercase version |
| $ENV{uc($proxy)}=undef; |
| } |
| |
| # make sure we don't get affected by other variables that control our |
| # behaviour |
| |
| $ENV{'SSL_CERT_DIR'}=undef; |
| $ENV{'SSL_CERT_PATH'}=undef; |
| $ENV{'CURL_CA_BUNDLE'}=undef; |
| |
| ####################################################################### |
| # Start a new thread/process and run the given command line in there. |
| # Return the pids (yes plural) of the new child process to the parent. |
| # |
| sub startnew { |
| my ($cmd, $pidfile)=@_; |
| |
| logmsg "startnew: $cmd\n" if ($verbose); |
| |
| my $child = fork(); |
| my $pid2; |
| |
| if(0 == $child) { |
| # a child, run the given command instead! |
| |
| # Calling exec() within a pseudo-process actually spawns the requested |
| # executable in a separate process and waits for it to complete before |
| # exiting with the same exit status as that process. This means that |
| # the process ID reported within the running executable will be |
| # different from what the earlier Perl fork() might have returned. |
| |
| exec($cmd); |
| } |
| |
| my $count=5; |
| while($count--) { |
| if(-f $pidfile) { |
| open(PID, "<$pidfile"); |
| $pid2 = 0 + <PID>; |
| close(PID); |
| if(kill(0, $pid2)) { |
| # make sure this pid is alive, as otherwise it is just likely |
| # to be the _previous_ pidfile or similar! |
| last; |
| } |
| } |
| sleep(1); |
| } |
| |
| return ($child, $pid2); |
| } |
| |
| |
| ####################################################################### |
| # Check for a command in the PATH. |
| # |
| sub checkcmd { |
| my ($cmd)=@_; |
| my @paths=("/usr/sbin", "/usr/local/sbin", "/sbin", "/usr/bin", |
| "/usr/local/bin", split(":", $ENV{'PATH'})); |
| for(@paths) { |
| if( -x "$_/$cmd") { |
| return "$_/$cmd"; |
| } |
| } |
| } |
| |
| ####################################################################### |
| # Memory allocation test and failure torture testing. |
| # |
| sub torture { |
| my $testcmd = shift; |
| my $gdbline = shift; |
| |
| # remove memdump first to be sure we get a new nice and clean one |
| unlink($memdump); |
| |
| # First get URL from test server, ignore the output/result |
| system($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 $memdump`; |
| for(@out) { |
| if(/^Allocations: (\d+)/) { |
| $count = $1; |
| last; |
| } |
| } |
| if(!$count) { |
| logmsg " found no allocs to make fail\n"; |
| return 0; |
| } |
| |
| logmsg " $count allocations to make fail\n"; |
| |
| for ( 1 .. $count ) { |
| my $limit = $_; |
| my $fail; |
| my $dumped_core; |
| |
| if($tortalloc && ($tortalloc != $limit)) { |
| next; |
| } |
| |
| logmsg "Fail alloc no: $limit\r" if($verbose); |
| |
| # 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($memdump); |
| |
| logmsg "**> Alloc number $limit is now set to fail <**\n" if($gdbthis); |
| |
| my $ret; |
| if($gdbthis) { |
| system($gdbline) |
| } |
| else { |
| $ret = system($testcmd); |
| } |
| |
| # Now clear the variable again |
| $ENV{'CURL_MEMLIMIT'} = undef; |
| |
| if(-r "core") { |
| # there's core file present now! |
| logmsg " core dumped!\n"; |
| $dumped_core = 1; |
| $fail = 2; |
| } |
| |
| # verify that it returns a proper error code, doesn't leak memory |
| # and doesn't core dump |
| if($ret & 255) { |
| logmsg " system() returned $ret\n"; |
| $fail=1; |
| } |
| else { |
| my @memdata=`$memanalyze $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 $memdump`; |
| $fail = 1; |
| } |
| } |
| if($fail) { |
| logmsg " Failed on alloc number $limit in test.\n", |
| " invoke with -t$limit to repeat this single case.\n"; |
| stopservers($verbose); |
| exit 1; |
| } |
| } |
| |
| logmsg "torture OK\n"; |
| return 0; |
| } |
| |
| ####################################################################### |
| # stop the given test server (pid) |
| # |
| sub stopserver { |
| my ($pid) = @_; |
| |
| if($pid <= 0) { |
| return; # this is not a good pid |
| } |
| |
| if($pid =~ / /) { |
| # if it contains space, it might be more than one pid |
| my @pids = split(" ", $pid); |
| for (@pids) { |
| kill (9, $_); # die! |
| } |
| } |
| |
| my $res = kill (9, $pid); # die! |
| |
| if($verbose) { |
| logmsg "RUN: Test server pid $pid signalled to die\n"; |
| } |
| } |
| |
| ####################################################################### |
| # Verify that the server that runs on $ip, $port is our server. This also |
| # implies that we can speak with it, as there might be occasions when the |
| # server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't |
| # assign requested address" # |
| |
| sub verifyhttp { |
| my ($proto, $ip, $port) = @_; |
| my $cmd = "$CURL -m4 -o log/verifiedserver -ksvg \"$proto://$ip:$port/verifiedserver\" 2>log/verifyhttp"; |
| my $pid; |
| |
| # verify if our/any server is running on this port |
| logmsg "CMD; $cmd\n" if ($verbose); |
| my $res = system($cmd); |
| |
| $res >>= 8; # rotate the result |
| my $data; |
| |
| if($res && $verbose) { |
| open(ERR, "<log/verifyhttp"); |
| my @e = <ERR>; |
| close(ERR); |
| logmsg "RUN: curl command returned $res\n"; |
| for(@e) { |
| if($_ !~ /^([ \t]*)$/) { |
| logmsg "RUN: $_"; |
| } |
| } |
| } |
| open(FILE, "<log/verifiedserver"); |
| my @file=<FILE>; |
| close(FILE); |
| $data=$file[0]; # first line |
| |
| if ( $data =~ /WE ROOLZ: (\d+)/ ) { |
| $pid = 0+$1; |
| } |
| elsif($res == 6) { |
| # curl: (6) Couldn't resolve host '::1' |
| logmsg "RUN: failed to resolve host\n"; |
| return 0; |
| } |
| elsif($data || ($res != 7)) { |
| logmsg "RUN: Unknown server is running on port $port\n"; |
| return 0; |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # Verify that the server that runs on $ip, $port is our server. This also |
| # implies that we can speak with it, as there might be occasions when the |
| # server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't |
| # assign requested address" # |
| |
| sub verifyftp { |
| my ($proto, $ip, $port) = @_; |
| my $pid; |
| my $time=time(); |
| my $cmd="$CURL -m4 --silent -vg \"$proto://$ip:$port/verifiedserver\" 2>log/verifyftp"; |
| # check if this is our server running on this port: |
| my @data=`$cmd`; |
| logmsg "RUN: $cmd\n" if($verbose); |
| my $line; |
| |
| # if this took more than 2 secs, we assume it "hung" on a weird server |
| my $took = time()-$time; |
| |
| foreach $line (@data) { |
| if ( $line =~ /WE ROOLZ: (\d+)/ ) { |
| # this is our test server with a known pid! |
| $pid = 0+$1; |
| last; |
| } |
| } |
| if($pid <= 0 && $data[0]) { |
| # this is not a known server |
| logmsg "RUN: Unknown server on our FTP port: $port\n"; |
| return 0; |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # Verify that the server that runs on $ip, $port is our server. |
| # Retry during 5 seconds before giving up. |
| # |
| |
| my %protofunc = ('http' => \&verifyhttp, |
| 'https' => \&verifyhttp, |
| 'ftp' => \&verifyftp); |
| |
| sub verifyserver { |
| my ($proto, $ip, $port) = @_; |
| |
| my $count = 5; # try for this many seconds |
| my $pid; |
| |
| while($count--) { |
| my $fun = $protofunc{$proto}; |
| |
| $pid = &$fun($proto, $ip, $port); |
| |
| if($pid) { |
| last; |
| } |
| sleep(1); |
| } |
| return $pid; |
| } |
| |
| |
| |
| ####################################################################### |
| # start the http server |
| # |
| sub runhttpserver { |
| my ($verbose, $ipv6) = @_; |
| my $RUNNING; |
| my $pid; |
| my $pidfile = $HTTPPIDFILE; |
| my $port = $HTTPPORT; |
| my $ip = $HOSTIP; |
| my $nameext; |
| |
| if($ipv6) { |
| # if IPv6, use a different setup |
| $pidfile = $HTTP6PIDFILE; |
| $port = $HTTP6PORT; |
| $ip = $HOST6IP; |
| $nameext="-ipv6"; |
| } |
| |
| $pid = checkserver($pidfile); |
| |
| if($pid > 0) { |
| stopserver($pid); |
| } |
| |
| my $flag=$debugprotocol?"-v ":""; |
| my $dir=$ENV{'srcdir'}; |
| if($dir) { |
| $flag .= "-d \"$dir\" "; |
| } |
| |
| my $cmd="$perl $srcdir/httpserver.pl -p $pidfile $flag $port $ipv6"; |
| my ($httppid, $pid2) = |
| startnew($cmd, $pidfile); # start the server in a new process |
| |
| if(!kill(0, $httppid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the HTTP server!\n"; |
| stopservers($verbose); |
| return (0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| if(!verifyserver("http", $ip, $port)) { |
| logmsg "RUN: HTTP$nameext server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver("$httppid $pid2"); |
| return (0,0); |
| } |
| |
| if($verbose) { |
| logmsg "RUN: HTTP$nameext server is now running PID $httppid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($httppid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the https server (or rather, tunnel) |
| # |
| sub runhttpsserver { |
| my ($verbose, $ipv6) = @_; |
| my $STATUS; |
| my $RUNNING; |
| my $ip = $HOSTIP; |
| |
| if(!$stunnel) { |
| return 0; |
| } |
| |
| if($ipv6) { |
| # not complete yet |
| $ip = $HOST6IP; |
| } |
| |
| my $pid=checkserver($HTTPSPIDFILE); |
| |
| if($pid > 0) { |
| # kill previous stunnel! |
| stopserver($pid); |
| } |
| |
| my $flag=$debugprotocol?"-v ":""; |
| my $cmd="$perl $srcdir/httpsserver.pl $flag -s \"$stunnel\" -d $srcdir -r $HTTPPORT $HTTPSPORT"; |
| |
| my ($httpspid, $pid2) = startnew($cmd, $HTTPSPIDFILE); |
| |
| if(!kill(0, $httpspid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the HTTPS server!\n"; |
| stopservers($verbose); |
| return(0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| if(!verifyserver("https", $ip, $HTTPSPORT)) { |
| logmsg "RUN: HTTPS server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver("$httpspid $pid2"); |
| return (0,0); |
| } |
| |
| if($verbose) { |
| logmsg "RUN: HTTPS server is now running PID $httpspid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($httpspid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the ftp server |
| # |
| sub runftpserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $STATUS; |
| my $RUNNING; |
| my $port = $id?$FTP2PORT:$FTPPORT; |
| # check for pidfile |
| my $pidfile = $id?$FTP2PIDFILE:$FTPPIDFILE; |
| my $ip=$HOSTIP; |
| my $nameext; |
| my $cmd; |
| |
| if($ipv6) { |
| # if IPv6, use a different setup |
| $pidfile = $FTP6PIDFILE; |
| $port = $FTP6PORT; |
| $ip = $HOST6IP; |
| $nameext="-ipv6"; |
| } |
| |
| 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="$perl $srcdir/ftpserver.pl --pidfile $pidfile $flag --port $port"; |
| |
| unlink($pidfile); |
| |
| my ($ftppid, $pid2) = startnew($cmd, $pidfile); |
| |
| if(!$ftppid || !kill(0, $ftppid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the FTP$id$nameext server!\n"; |
| return -1; |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| if(!verifyserver("ftp", $ip, $port)) { |
| logmsg "RUN: FTP$id$nameext server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver("$ftppid $pid2"); |
| return (0,0); |
| } |
| |
| if($verbose) { |
| logmsg "RUN: FTP$id$nameext server is now running PID $ftppid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($pid2, $ftppid); |
| } |
| |
| ####################################################################### |
| # Remove all files in the specified directory |
| # |
| sub cleardir { |
| my $dir = $_[0]; |
| my $count; |
| my $file; |
| |
| # 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") |
| || return 1; |
| |
| open(OUT, ">$ofile") |
| || return 1; |
| |
| # logmsg "FILTER: off $filter from $infile to $ofile\n"; |
| |
| while(<IN>) { |
| $_ =~ s/$filter//; |
| print OUT $_; |
| } |
| close(IN); |
| close(OUT); |
| return 0; |
| } |
| |
| ####################################################################### |
| # compare test results with the expected output, we might filter off |
| # some pattern that is allowed to differ, output test results |
| # |
| |
| sub compare { |
| # 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"; |
| } |
| } |
| return $result; |
| } |
| |
| ####################################################################### |
| # display information about curl and the host the test suite runs on |
| # |
| sub checksystem { |
| |
| unlink($memdump); # remove this if there was one left |
| |
| my $feat; |
| my $curl; |
| my $libcurl; |
| my @version=`$CURL --version 2>/dev/null`; |
| for(@version) { |
| chomp; |
| |
| if($_ =~ /^curl/) { |
| $curl = $_; |
| $curl =~ s/^(.*)(libcurl.*)/$1/g; |
| |
| $libcurl = $2; |
| 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/) { |
| # 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) { |
| # OpenSSL in use |
| $has_openssl=1; |
| } |
| elsif ($libcurl =~ /gnutls/i) { |
| # GnuTLS in use |
| $has_gnutls=1; |
| } |
| } |
| elsif($_ =~ /^Protocols: (.*)/i) { |
| # these are the supported protocols, we don't use this knowledge |
| # at this point |
| } |
| elsif($_ =~ /^Features: (.*)/i) { |
| $feat = $1; |
| 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; |
| } |
| if($feat =~ /IDN/i) { |
| # IDN support |
| $has_idn=1; |
| } |
| if($feat =~ /IPv6/i) { |
| $has_ipv6 = 1; |
| } |
| if($feat =~ /libz/i) { |
| $has_libz = 1; |
| } |
| if($feat =~ /NTLM/i) { |
| # NTLM enabled |
| $has_ntlm=1; |
| } |
| } |
| } |
| if(!$curl) { |
| die "couldn't run '$CURL'" |
| } |
| |
| if(-r "../lib/config.h") { |
| open(CONF, "<../lib/config.h"); |
| while(<CONF>) { |
| if($_ =~ /^\#define HAVE_GETRLIMIT/) { |
| $has_getrlimit = 1; |
| } |
| } |
| close(CONF); |
| } |
| |
| if($has_ipv6) { |
| # 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; |
| } |
| |
| # check if the FTP server has it! |
| @sws = `server/sockfilt --version`; |
| 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"; |
| } |
| |
| my $hostname=`hostname`; |
| my $hosttype=`uname -a`; |
| |
| logmsg ("********* System characteristics ******** \n", |
| "* $curl\n", |
| "* $libcurl\n", |
| "* Features: $feat\n", |
| "* Host: $hostname", |
| "* 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); |
| if($stunnel) { |
| #logmsg sprintf("* FTPS port: %d\n", $FTPSPORT); |
| logmsg sprintf("* HTTPS port: %d\n", $HTTPSPORT); |
| } |
| if($http_ipv6) { |
| logmsg sprintf("* HTTP IPv6 port: %d\n", $HTTP6PORT); |
| } |
| if($ftp_ipv6) { |
| logmsg sprintf("* FTP IPv6 port: %d\n", $FTP6PORT); |
| } |
| |
| if($ssl_version) { |
| logmsg sprintf("* SSL library: %s\n", |
| $has_gnutls?"GnuTLS":($has_openssl?"OpenSSL":"<unknown>")); |
| } |
| |
| $has_textaware = ($^O eq 'MSWin32') || ($^O eq 'msys'); |
| |
| 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; |
| $$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; |
| $$thing =~ s/%FTP6PORT/$FTP6PORT/g; |
| $$thing =~ s/%FTP2PORT/$FTP2PORT/g; |
| $$thing =~ s/%FTPSPORT/$FTPSPORT/g; |
| $$thing =~ s/%SRCDIR/$srcdir/g; |
| $$thing =~ s/%PWD/$pwd/g; |
| } |
| |
| sub fixarray { |
| my @in = @_; |
| |
| for(@in) { |
| subVariables \$_; |
| } |
| return @in; |
| } |
| |
| ####################################################################### |
| # Run a single specified test case |
| # |
| |
| sub singletest { |
| my ($testnum, $count, $total)=@_; |
| |
| my @what; |
| my $why; |
| my %feature; |
| 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"; |
| } |
| $why = "no test"; |
| } |
| else { |
| @what = getpart("client", "features"); |
| } |
| |
| for(@what) { |
| my $f = $_; |
| $f =~ s/\s//g; |
| |
| $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 "netrc_debug") { |
| if($curl_debug) { |
| next; |
| } |
| } |
| elsif($f eq "large_file") { |
| if($large_file) { |
| next; |
| } |
| } |
| elsif($f eq "idn") { |
| if($has_idn) { |
| next; |
| } |
| } |
| elsif($f eq "ipv6") { |
| if($has_ipv6) { |
| next; |
| } |
| } |
| elsif($f eq "libz") { |
| if($has_libz) { |
| next; |
| } |
| } |
| elsif($f eq "NTLM") { |
| if($has_ntlm) { |
| next; |
| } |
| } |
| elsif($f eq "getrlimit") { |
| if($has_getrlimit) { |
| next; |
| } |
| } |
| |
| $why = "curl lacks $f support"; |
| last; |
| } |
| |
| if(!$why) { |
| $why = serverfortest($testnum); |
| } |
| |
| if(!$why) { |
| my @precheck = getpart("client", "precheck"); |
| $cmd = $precheck[0]; |
| chomp $cmd; |
| if($cmd) { |
| my @o = `$cmd 2>/dev/null`; |
| if($o[0]) { |
| $why = $o[0]; |
| chomp $why; |
| } |
| logmsg "prechecked $cmd\n" if($verbose); |
| } |
| } |
| |
| if($why) { |
| # there's a problem, count it as "skipped" |
| $skipped++; |
| $skipped{$why}++; |
| $teststat[$testnum]=$why; # store reason for this test case |
| |
| if(!$short) { |
| 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]); |
| } |
| |
| @reply=@replycheck; |
| } |
| |
| # curl command to run |
| my @curlcmd= fixarray ( getpart("client", "command") ); |
| |
| # this is the valid protocol blurb curl should generate |
| 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: |
| 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 |
| |
| # name of the test |
| 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; |
| } |
| |
| # remove server output logfiles |
| unlink($SERVERIN); |
| 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; |
| } |
| } |
| |
| # get the command line options to use |
| my @blaha; |
| ($cmd, @blaha)= getpart("client", "command"); |
| |
| # make some nice replace operations |
| $cmd =~ s/\n//g; # no newlines please |
| |
| # substitute variables in the command line |
| subVariables \$cmd; |
| |
| if($curl_debug) { |
| unlink($memdump); |
| } |
| |
| my @inputfile=getpart("client", "file"); |
| if(@inputfile) { |
| # we need to generate a file before this test is invoked |
| my %fileattr = getpartattr("client", "file"); |
| |
| my $filename=$fileattr{'name'}; |
| |
| if(!$filename) { |
| logmsg "ERROR: section client=>file has no name attribute!\n"; |
| return -1; |
| } |
| 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"); |
| |
| my $out=""; |
| |
| if($cmdhash{'option'} !~ /no-output/) { |
| #We may slap on --output! |
| if (!@validstdout) { |
| $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"; |
| } |
| my $CMDLINE; |
| |
| if(!$tool) { |
| $CMDLINE="$CURL"; |
| } |
| else { |
| $CMDLINE="$LIBDIR/$tool"; |
| $DBGCURL=$CMDLINE; |
| } |
| |
| if($valgrind) { |
| $CMDLINE = "valgrind ".$valgrind_tool."--leak-check=yes --num-callers=16 ${valgrind_logfile}=log/valgrind$testnum $CMDLINE"; |
| } |
| |
| $CMDLINE .= "$cmdargs >>$STDOUT 2>>$STDERR"; |
| |
| if($verbose) { |
| logmsg "$CMDLINE\n"; |
| } |
| |
| print CMDLOG "$CMDLINE\n"; |
| |
| unlink("core"); |
| |
| my $dumped_core; |
| my $cmdres; |
| |
| 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: $@"; |
| stopservers($verbose); |
| return -1; |
| } |
| } |
| |
| if($gdbthis) { |
| 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) { |
| return torture($CMDLINE, |
| "gdb --directory libtest $DBGCURL -x log/gdbcmd"); |
| } |
| elsif($gdbthis) { |
| system("gdb --directory libtest $DBGCURL -x log/gdbcmd"); |
| $cmdres=0; # makes it always continue after a debugged run |
| } |
| else { |
| $cmdres = system("$CMDLINE"); |
| my $signal_num = $cmdres & 127; |
| $dumped_core = $cmdres & 128; |
| |
| if(!$anyway && ($signal_num || $dumped_core)) { |
| $cmdres = 1000; |
| } |
| else { |
| $cmdres /= 256; |
| } |
| } |
| 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(GDBCMD, ">log/gdbcmd2"); |
| print GDBCMD "bt\n"; |
| close(GDBCMD); |
| system("gdb --directory libtest -x log/gdbcmd2 -batch $DBGCURL core "); |
| # unlink("log/gdbcmd2"); |
| } |
| } |
| |
| # remove the special FTP command file after each test! |
| unlink($FTPDCMD); |
| |
| my $e; |
| for $e (@envs) { |
| $ENV{$e}=""; # clean up |
| } |
| |
| my @err = getpart("verify", "errorcode"); |
| my $errorcode = $err[0] || "0"; |
| my $ok=""; |
| my $res; |
| if (@validstdout) { |
| # verify redirected stdout |
| my @actual = loadarray($STDOUT); |
| |
| # get all attributes |
| my %hash = getpartattr("verify", "stdout"); |
| |
| # get the mode attribute |
| my $filemode=$hash{'mode'}; |
| if(($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows: fix line endings |
| map s/\r\n/\n/g, @actual; |
| } |
| |
| $res = compare("stdout", \@actual, \@validstdout); |
| if($res) { |
| return 1; |
| } |
| $ok .= "s"; |
| } |
| else { |
| $ok .= "-"; # stdout not checked |
| } |
| |
| my %replyattr = getpartattr("reply", "data"); |
| if(!$replyattr{'nocheck'} && (@reply || $replyattr{'sendzero'})) { |
| # verify the received data |
| my @out = loadarray($CURLOUT); |
| my %hash = getpartattr("reply", "data"); |
| # get the mode attribute |
| my $filemode=$hash{'mode'}; |
| if(($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows: fix line endings |
| map s/\r\n/\n/g, @out; |
| } |
| |
| $res = compare("data", \@out, \@reply); |
| if ($res) { |
| return 1; |
| } |
| $ok .= "d"; |
| } |
| else { |
| $ok .= "-"; # data not checked |
| } |
| |
| if(@upload) { |
| # verify uploaded data |
| my @out = loadarray("$LOGDIR/upload.$testnum"); |
| $res = compare("upload", \@out, \@upload); |
| if ($res) { |
| return 1; |
| } |
| $ok .= "u"; |
| } |
| else { |
| $ok .= "-"; # upload not checked |
| } |
| |
| if(@protocol) { |
| my @out; |
| my $retry = 5; |
| |
| # Verify the sent request. Sometimes, like in test 513 on some hosts, |
| # curl will return back faster than the server writes down the request |
| # to its file, so we might need to wait here for a while to see if the |
| # file gets written a bit later. |
| |
| while($retry--) { |
| @out = loadarray($SERVERIN); |
| |
| if(!$out[0]) { |
| # nothing there yet, wait a while and try again |
| sleep(1); |
| } |
| } |
| |
| # what to cut off from the live protocol sent by curl |
| my @strip = getpart("verify", "strip"); |
| |
| my @protstrip=@protocol; |
| |
| # check if there's any attributes on the verify/protocol section |
| my %hash = getpartattr("verify", "protocol"); |
| |
| if($hash{'nonewline'}) { |
| # Yes, we must cut off the final newline from the final line |
| # of the protocol data |
| chomp($protstrip[$#protstrip]); |
| } |
| |
| for(@strip) { |
| # strip off all lines that match the patterns from both arrays |
| chomp $_; |
| @out = striparray( $_, \@out); |
| @protstrip= striparray( $_, \@protstrip); |
| } |
| |
| # what parts to cut off from the protocol |
| my @strippart = getpart("verify", "strippart"); |
| my $strip; |
| for $strip (@strippart) { |
| chomp $strip; |
| for(@out) { |
| eval $strip; |
| } |
| } |
| |
| $res = compare("protocol", \@out, \@protstrip); |
| if($res) { |
| return 1; |
| } |
| |
| $ok .= "p"; |
| |
| } |
| else { |
| $ok .= "-"; # protocol not checked |
| } |
| |
| my @outfile=getpart("verify", "file"); |
| if(@outfile) { |
| # we're supposed to verify a dynamicly generated file! |
| my %hash = getpartattr("verify", "file"); |
| |
| my $filename=$hash{'name'}; |
| if(!$filename) { |
| logmsg "ERROR: section verify=>file has no name attribute!\n"; |
| stopservers($verbose); |
| return -1; |
| } |
| my @generated=loadarray($filename); |
| |
| # what parts to cut off from the file |
| my @stripfile = getpart("verify", "stripfile"); |
| |
| my $filemode=$hash{'mode'}; |
| if(($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows means adding an extra |
| # strip expression |
| push @stripfile, "s/\r\n/\n/"; |
| } |
| |
| my $strip; |
| for $strip (@stripfile) { |
| chomp $strip; |
| for(@generated) { |
| eval $strip; |
| } |
| } |
| |
| $res = compare("output", \@generated, \@outfile); |
| if($res) { |
| return 1; |
| } |
| |
| $ok .= "o"; |
| } |
| else { |
| $ok .= "-"; # output not checked |
| } |
| |
| # accept multiple comma-separated error codes |
| my @splerr = split(/ *, */, $errorcode); |
| my $errok; |
| foreach $e (@splerr) { |
| if($e == $cmdres) { |
| # a fine error code |
| $errok = 1; |
| last; |
| } |
| } |
| |
| if($errok) { |
| $ok .= "e"; |
| } |
| else { |
| if(!$short) { |
| printf "\ncurl returned $cmdres, %s was expected\n", $errorcode; |
| } |
| logmsg " exit FAILED\n"; |
| return 1; |
| } |
| |
| @what = getpart("client", "killserver"); |
| for(@what) { |
| my $serv = $_; |
| chomp $serv; |
| if($serv =~ /^ftp(\d*)(-ipv6|)/) { |
| my ($id, $ext) = ($1, $2); |
| print STDERR "SERV $serv $id $ext\n"; |
| ftpkillslave($id, $ext, 1); |
| } |
| if($run{$serv}) { |
| stopserver($run{$serv}); # the pid file is in the hash table |
| $run{$serv}=0; # clear pid |
| } |
| else { |
| logmsg "RUN: The $serv server is not running\n"; |
| } |
| } |
| |
| if($curl_debug) { |
| if(! -f $memdump) { |
| logmsg "\n** ALERT! memory debuggin without any output file?\n"; |
| } |
| else { |
| my @memdata=`$memanalyze $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 "\n** MEMORY FAILURE\n"; |
| logmsg @memdata; |
| return 1; |
| } |
| else { |
| $ok .= "m"; |
| } |
| } |
| } |
| else { |
| $ok .= "-"; # memory not checked |
| } |
| |
| if($valgrind) { |
| # this is the valid protocol blurb curl should generate |
| my @disable= getpart("verify", "valgrind"); |
| |
| if($disable[0] !~ /disable/) { |
| |
| opendir(DIR, "log") || |
| return 0; # can't open log dir |
| my @files = readdir(DIR); |
| closedir DIR; |
| my $f; |
| my $l; |
| foreach $f (@files) { |
| if($f =~ /^valgrind$testnum\.pid/) { |
| $l = $f; |
| last; |
| } |
| } |
| my $src=$ENV{'srcdir'}; |
| if(!$src) { |
| $src="."; |
| } |
| my @e = valgrindparse($src, $feature{'SSL'}, "log/$l"); |
| if($e[0]) { |
| logmsg " valgrind ERROR "; |
| logmsg @e; |
| return 1; |
| } |
| $ok .= "v"; |
| } |
| else { |
| if(!$short) { |
| logmsg " valgrind SKIPPED"; |
| } |
| $ok .= "-"; # skipped |
| } |
| } |
| else { |
| $ok .= "-"; # valgrind not checked |
| } |
| |
| logmsg "$ok " if(!$short); |
| |
| my $sofar= time()-$start; |
| my $esttotal = $sofar/$count * $total; |
| my $estleft = $esttotal - $sofar; |
| my $left=sprintf("remaining: %02d:%02d", |
| $estleft/60, |
| $estleft%60); |
| printf "OK (%-3d out of %-3d, %s)\n", $count, $total, $left; |
| |
| # the test succeeded, remove all log files |
| if(!$keepoutfiles) { |
| cleardir($LOGDIR); |
| } |
| |
| unlink($FTPDCMD); # remove the instructions for this test |
| |
| return 0; |
| } |
| |
| ####################################################################### |
| # Stop all running test servers |
| sub stopservers { |
| my ($verbose)=@_; |
| for(keys %run) { |
| my $server = $_; |
| my $pids=$run{$server}; |
| my $pid; |
| my $prev; |
| |
| foreach $pid (split(" ", $pids)) { |
| if($pid != $prev) { |
| # no need to kill same pid twice! |
| logmsg sprintf("* kill pid for %s => %d\n", |
| $server, $pid) if($verbose); |
| stopserver($pid); |
| } |
| $prev = $pid; |
| } |
| } |
| ftpkillslaves($verbose); |
| } |
| |
| ####################################################################### |
| # startservers() starts all the named servers |
| # |
| # Returns: string with error reason or blank for success |
| |
| sub startservers { |
| my @what = @_; |
| my ($pid, $pid2); |
| for(@what) { |
| my $what = lc($_); |
| $what =~ s/[^a-z0-9-]//g; |
| if($what eq "ftp") { |
| if(!$run{'ftp'}) { |
| ($pid, $pid2) = runftpserver("", $verbose); |
| if($pid <= 0) { |
| return "failed starting FTP server"; |
| } |
| printf ("* pid ftp => %d %d\n", $pid, $pid2) if($verbose); |
| $run{'ftp'}="$pid $pid2"; |
| } |
| } |
| elsif($what eq "ftp2") { |
| if(!$run{'ftp2'}) { |
| ($pid, $pid2) = runftpserver("2", $verbose); |
| if($pid <= 0) { |
| return "failed starting FTP2 server"; |
| } |
| printf ("* pid ftp2 => %d %d\n", $pid, $pid2) if($verbose); |
| $run{'ftp2'}="$pid $pid2"; |
| } |
| } |
| elsif($what eq "ftp-ipv6") { |
| if(!$run{'ftp-ipv6'}) { |
| ($pid, $pid2) = runftpserver("", $verbose, "ipv6"); |
| if($pid <= 0) { |
| return "failed starting FTP-ipv6 server"; |
| } |
| logmsg sprintf("* pid ftp-ipv6 => %d %d\n", $pid, |
| $pid2) if($verbose); |
| $run{'ftp-ipv6'}="$pid $pid2"; |
| } |
| } |
| elsif($what eq "http") { |
| if(!$run{'http'}) { |
| ($pid, $pid2) = runhttpserver($verbose); |
| if($pid <= 0) { |
| return "failed starting HTTP server"; |
| } |
| printf ("* pid http => %d %d\n", $pid, $pid2) if($verbose); |
| $run{'http'}="$pid $pid2"; |
| } |
| } |
| elsif($what eq "http-ipv6") { |
| if(!$run{'http-ipv6'}) { |
| ($pid, $pid2) = runhttpserver($verbose, "IPv6"); |
| if($pid <= 0) { |
| return "failed starting IPv6 HTTP server"; |
| } |
| logmsg sprintf("* pid http-ipv6 => %d %d\n", $pid, $pid2) |
| if($verbose); |
| $run{'http-ipv6'}="$pid $pid2"; |
| } |
| } |
| elsif($what eq "ftps") { |
| # we can't run ftps tests at all for the moment |
| return "test suite lacks FTPS support"; |
| } |
| elsif($what eq "file") { |
| # we support it but have no server! |
| } |
| elsif($what eq "https") { |
| if(!$stunnel) { |
| # we can't run ftps tests without stunnel |
| return "no stunnel"; |
| } |
| if(!$ssl_version) { |
| # we can't run ftps tests if libcurl is SSL-less |
| return "curl lacks SSL support"; |
| } |
| |
| if(!$run{'http'}) { |
| ($pid, $pid2) = runhttpserver($verbose); |
| if($pid <= 0) { |
| return "failed starting HTTP server"; |
| } |
| printf ("* pid http => %d %d\n", $pid, $pid2) if($verbose); |
| $run{'http'}="$pid $pid2"; |
| } |
| if(!$run{'https'}) { |
| ($pid, $pid2) = runhttpsserver($verbose); |
| if($pid <= 0) { |
| return "failed starting HTTPS server (stunnel)"; |
| } |
| logmsg sprintf("* pid https => %d %d\n", $pid, $pid2) |
| if($verbose); |
| $run{'https'}="$pid $pid2"; |
| } |
| } |
| elsif($what eq "none") { |
| logmsg "* starts no server\n" if ($verbose); |
| } |
| else { |
| warn "we don't support a server for $what"; |
| } |
| } |
| return 0; |
| } |
| |
| ############################################################################## |
| # This function makes sure the right set of server is running for the |
| # specified test case. This is a useful design when we run single tests as not |
| # all servers need to run then! |
| # |
| # Returns: a string, blank if everything is fine or a reason why it failed |
| # |
| |
| sub serverfortest { |
| my ($testnum)=@_; |
| |
| # load the test case file definition |
| if(loadtest("${TESTDIR}/test${testnum}")) { |
| if($verbose) { |
| # this is not a test |
| logmsg "$testnum doesn't look like a test case!\n"; |
| } |
| return "no test"; |
| } |
| |
| my @what = getpart("client", "server"); |
| |
| if(!$what[0]) { |
| warn "Test case $testnum has no server(s) specified!"; |
| return "no server specified"; |
| } |
| |
| return &startservers(@what); |
| } |
| |
| ####################################################################### |
| # Check options to this test program |
| # |
| |
| my $number=0; |
| my $fromnum=-1; |
| my @testthis; |
| do { |
| if ($ARGV[0] eq "-v") { |
| # verbose output |
| $verbose=1; |
| } |
| elsif ($ARGV[0] eq "-c") { |
| # use this path to curl instead of default |
| $DBGCURL=$CURL=$ARGV[1]; |
| shift @ARGV; |
| } |
| elsif ($ARGV[0] eq "-d") { |
| # have the servers display protocol output |
| $debugprotocol=1; |
| } |
| elsif ($ARGV[0] eq "-g") { |
| # run this test with gdb |
| $gdbthis=1; |
| } |
| elsif($ARGV[0] eq "-s") { |
| # short output |
| $short=1; |
| } |
| elsif($ARGV[0] eq "-n") { |
| # no valgrind |
| undef $valgrind; |
| } |
| elsif($ARGV[0] =~ /^-t(.*)/) { |
| # torture |
| $torture=1; |
| my $xtra = $1; |
| |
| if($xtra =~ s/(\d+)$//) { |
| $tortalloc = $1; |
| } |
| # we undef valgrind to make this fly in comparison |
| undef $valgrind; |
| } |
| elsif($ARGV[0] eq "-a") { |
| # continue anyway, even if a test fail |
| $anyway=1; |
| } |
| elsif($ARGV[0] eq "-p") { |
| $postmortem=1; |
| } |
| elsif($ARGV[0] eq "-l") { |
| # lists the test case names only |
| $listonly=1; |
| } |
| elsif($ARGV[0] eq "-k") { |
| # keep stdout and stderr files after tests |
| $keepoutfiles=1; |
| } |
| elsif($ARGV[0] eq "-h") { |
| # show help text |
| print <<EOHELP |
| Usage: runtests.pl [options] |
| -a continue even if a test fails |
| -d display server debug info |
| -g run the test case with gdb |
| -h this help text |
| -k keep stdout and stderr files present after tests |
| -l list all test case names/descriptions |
| -n No valgrind |
| -p Print log file contents when a test fails |
| -s short output |
| -t torture |
| -v verbose output |
| [num] like "5 6 9" or " 5 to 22 " to run those tests only |
| EOHELP |
| ; |
| exit; |
| } |
| elsif($ARGV[0] =~ /^(\d+)/) { |
| $number = $1; |
| if($fromnum >= 0) { |
| for($fromnum .. $number) { |
| push @testthis, $_; |
| } |
| $fromnum = -1; |
| } |
| else { |
| push @testthis, $1; |
| } |
| } |
| elsif($ARGV[0] =~ /^to$/i) { |
| $fromnum = $number+1; |
| } |
| } while(shift @ARGV); |
| |
| if($testthis[0] ne "") { |
| $TESTCASES=join(" ", @testthis); |
| } |
| |
| if($valgrind) { |
| # we have found valgrind on the host, use it |
| |
| # verify that we can invoke it fine |
| my $code = system("valgrind >/dev/null 2>&1"); |
| |
| if(($code>>8) != 1) { |
| #logmsg "Valgrind failure, disable it\n"; |
| undef $valgrind; |
| } |
| } |
| |
| $HTTPPORT = $base + 0; # HTTP server port |
| $HTTPSPORT = $base + 1; # HTTPS server port |
| $FTPPORT = $base + 2; # FTP server port |
| $FTPSPORT = $base + 3; # FTPS server port |
| $HTTP6PORT = $base + 4; # HTTP IPv6 server port (different IP protocol |
| # but we follow the same port scheme anyway) |
| $FTP2PORT = $base + 5; # FTP server 2 port |
| $FTP6PORT = $base + 6; # FTP IPv6 port |
| |
| ####################################################################### |
| # Output curl version and host info being tested |
| # |
| |
| if(!$listonly) { |
| checksystem(); |
| } |
| |
| ####################################################################### |
| # clear and create logging directory: |
| # |
| cleardir($LOGDIR); |
| mkdir($LOGDIR, 0777); |
| |
| ####################################################################### |
| # If 'all' tests are requested, find out all test numbers |
| # |
| |
| if ( $TESTCASES eq "all") { |
| # Get all commands and find out their test numbers |
| opendir(DIR, $TESTDIR) || die "can't opendir $TESTDIR: $!"; |
| my @cmds = grep { /^test([0-9]+)$/ && -f "$TESTDIR/$_" } readdir(DIR); |
| closedir DIR; |
| |
| $TESTCASES=""; # start with no test cases |
| |
| # cut off everything but the digits |
| for(@cmds) { |
| $_ =~ s/[a-z\/\.]*//g; |
| } |
| # the the numbers from low to high |
| for(sort { $a <=> $b } @cmds) { |
| $TESTCASES .= " $_"; |
| } |
| } |
| |
| ####################################################################### |
| # Start the command line log |
| # |
| open(CMDLOG, ">$CURLLOG") || |
| logmsg "can't log command lines to $CURLLOG\n"; |
| |
| ####################################################################### |
| |
| sub displaylogcontent { |
| my ($file)=@_; |
| open(SINGLE, "<$file"); |
| while(<SINGLE>) { |
| logmsg " $_"; |
| } |
| close(SINGLE); |
| } |
| |
| sub displaylogs { |
| my ($testnum)=@_; |
| opendir(DIR, "$LOGDIR") || |
| die "can't open dir: $!"; |
| my @logs = readdir(DIR); |
| closedir DIR; |
| my $log; |
| |
| logmsg "== Contents of files in the log/ dir after test $testnum\n"; |
| foreach $log (sort @logs) { |
| # the log file is not "." or ".." and contains more than zero bytes |
| if(($log !~ /\.(\.|)$/) && |
| ($log ne "memdump") && # and not "memdump" |
| -s "$LOGDIR/$log") { |
| if($log =~ /^\.nfs/) { |
| next; |
| } |
| logmsg "== Start of file $log\n"; |
| displaylogcontent("$LOGDIR/$log"); |
| logmsg "== End of file $log\n"; |
| } |
| } |
| } |
| |
| ####################################################################### |
| # The main test-loop |
| # |
| |
| my $failed; |
| my $testnum; |
| my $ok=0; |
| my $total=0; |
| my $lasttest; |
| my @at = split(" ", $TESTCASES); |
| my $count=0; |
| |
| $start = time(); |
| |
| foreach $testnum (@at) { |
| |
| $lasttest = $testnum if($testnum > $lasttest); |
| $count++; |
| |
| my $error = singletest($testnum, $count, scalar(@at)); |
| if($error < 0) { |
| # not a test we can run |
| next; |
| } |
| |
| $total++; # number of tests we've run |
| |
| if($error>0) { |
| $failed.= "$testnum "; |
| if($postmortem) { |
| # display all files in log/ in a nice way |
| displaylogs($testnum); |
| } |
| if(!$anyway) { |
| # a test failed, abort |
| logmsg "\n - abort tests\n"; |
| last; |
| } |
| } |
| elsif(!$error) { |
| $ok++; # successful test counter |
| } |
| |
| # loop for next test |
| } |
| |
| ####################################################################### |
| # Close command log |
| # |
| close(CMDLOG); |
| |
| # Tests done, stop the servers |
| stopservers($verbose); |
| |
| my $all = $total + $skipped; |
| |
| if($total) { |
| logmsg sprintf("TESTDONE: $ok tests out of $total reported OK: %d%%\n", |
| $ok/$total*100); |
| |
| if($ok != $total) { |
| logmsg "TESTFAIL: These test cases failed: $failed\n"; |
| } |
| } |
| else { |
| logmsg "TESTFAIL: No tests were performed!\n"; |
| } |
| |
| if($all) { |
| my $sofar = time()-$start; |
| logmsg "TESTDONE: $all tests were considered during $sofar seconds.\n"; |
| } |
| |
| if($skipped) { |
| my $s=0; |
| logmsg "TESTINFO: $skipped tests were skipped due to these restraints:\n"; |
| |
| for(keys %skipped) { |
| my $r = $_; |
| printf "TESTINFO: \"%s\" %d times (", $r, $skipped{$_}; |
| |
| # now show all test case numbers that had this reason for being |
| # skipped |
| my $c=0; |
| for(0 .. $lasttest) { |
| my $t = $_; |
| if($teststat[$_] eq $r) { |
| logmsg ", " if($c); |
| logmsg $_; |
| $c++; |
| } |
| } |
| logmsg ")\n"; |
| } |
| } |
| if($total && ($ok != $total)) { |
| exit 1; |
| } |