| #!/usr/bin/env perl |
| #*************************************************************************** |
| # _ _ ____ _ |
| # Project ___| | | | _ \| | |
| # / __| | | | |_) | | |
| # | (__| |_| | _ <| |___ |
| # \___|\___/|_| \_\_____| |
| # |
| # Copyright (C) 1998 - 2012, 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. |
| # |
| ########################################################################### |
| |
| # Experimental hooks are available to run tests remotely on machines that |
| # are able to run curl but are unable to run the test harness. |
| # The following sections need to be modified: |
| # |
| # $HOSTIP, $HOST6IP - Set to the address of the host running the test suite |
| # $CLIENTIP, $CLIENT6IP - Set to the address of the host running curl |
| # runclient, runclientoutput - Modify to copy all the files in the log/ |
| # directory to the system running curl, run the given command remotely |
| # and save the return code or returned stdout (respectively), then |
| # copy all the files from the remote system's log/ directory back to |
| # the host running the test suite. This can be done a few ways, such |
| # as using scp & ssh, rsync & telnet, or using a NFS shared directory |
| # and ssh. |
| # |
| # 'make && make test' needs to be done on both machines before making the |
| # above changes and running runtests.pl manually. In the shared NFS case, |
| # the contents of the tests/server/ directory must be from the host |
| # running the test suite, while the rest must be from the host running curl. |
| # |
| # Note that even with these changes a number of tests will still fail (mainly |
| # to do with cookies, those that set environment variables, or those that |
| # do more than touch the file system in a <precheck> or <postcheck> |
| # section). These can be added to the $TESTCASES line below, |
| # e.g. $TESTCASES="!8 !31 !63 !cookies..." |
| # |
| # Finally, to properly support -g and -n, checktestcmd needs to change |
| # to check the remote system's PATH, and the places in the code where |
| # the curl binary is read directly to determine its type also need to be |
| # fixed. As long as the -g option is never given, and the -n is always |
| # given, this won't be a problem. |
| |
| |
| # These should be the only variables that might be needed to get edited: |
| |
| BEGIN { |
| @INC=(@INC, $ENV{'srcdir'}, "."); |
| # run time statistics needs Time::HiRes |
| eval { |
| no warnings "all"; |
| require Time::HiRes; |
| import Time::HiRes qw( time ); |
| } |
| } |
| |
| use strict; |
| use warnings; |
| use Cwd; |
| |
| # Subs imported from serverhelp module |
| use serverhelp qw( |
| serverfactors |
| servername_id |
| servername_str |
| servername_canon |
| server_pidfilename |
| server_logfilename |
| ); |
| |
| # Variables and subs imported from sshhelp module |
| use sshhelp qw( |
| $sshdexe |
| $sshexe |
| $sftpexe |
| $sshconfig |
| $sftpconfig |
| $sshdlog |
| $sshlog |
| $sftplog |
| $sftpcmds |
| display_sshdconfig |
| display_sshconfig |
| display_sftpconfig |
| display_sshdlog |
| display_sshlog |
| display_sftplog |
| exe_ext |
| find_sshd |
| find_ssh |
| find_sftp |
| find_httptlssrv |
| sshversioninfo |
| ); |
| |
| require "getpart.pm"; # array functions |
| require "valgrind.pm"; # valgrind report parser |
| require "ftp.pm"; |
| |
| my $HOSTIP="127.0.0.1"; # address on which the test server listens |
| my $HOST6IP="[::1]"; # address on which the test server listens |
| my $CLIENTIP="127.0.0.1"; # address which curl uses for incoming connections |
| my $CLIENT6IP="[::1]"; # address which curl uses for incoming connections |
| |
| my $base = 8990; # base port number |
| |
| my $HTTPPORT; # HTTP server port |
| my $HTTP6PORT; # HTTP IPv6 server port |
| my $HTTPSPORT; # HTTPS (stunnel) server port |
| my $FTPPORT; # FTP server port |
| my $FTP2PORT; # FTP server 2 port |
| my $FTPSPORT; # FTPS (stunnel) server port |
| my $FTP6PORT; # FTP IPv6 server port |
| my $TFTPPORT; # TFTP |
| my $TFTP6PORT; # TFTP |
| my $SSHPORT; # SCP/SFTP |
| my $SOCKSPORT; # SOCKS4/5 port |
| my $POP3PORT; # POP3 |
| my $POP36PORT; # POP3 IPv6 server port |
| my $IMAPPORT; # IMAP |
| my $IMAP6PORT; # IMAP IPv6 server port |
| my $SMTPPORT; # SMTP |
| my $SMTP6PORT; # SMTP IPv6 server port |
| my $RTSPPORT; # RTSP |
| my $RTSP6PORT; # RTSP IPv6 server port |
| my $GOPHERPORT; # Gopher |
| my $GOPHER6PORT; # Gopher IPv6 server port |
| my $HTTPTLSPORT; # HTTP TLS (non-stunnel) server port |
| my $HTTPTLS6PORT; # HTTP TLS (non-stunnel) IPv6 server port |
| my $HTTPPROXYPORT; # HTTP proxy port, when using CONNECT |
| |
| my $srcdir = $ENV{'srcdir'} || '.'; |
| my $CURL="../src/curl".exe_ext(); # what curl executable to run on the tests |
| my $VCURL=$CURL; # what curl binary to use to verify the servers with |
| # VCURL is handy to set to the system one when the one you |
| # just built hangs or crashes and thus prevent verification |
| my $DBGCURL=$CURL; #"../src/.libs/curl"; # alternative for debugging |
| my $LOGDIR="log"; |
| my $TESTDIR="$srcdir/data"; |
| my $LIBDIR="./libtest"; |
| my $UNITDIR="./unit"; |
| # TODO: change this to use server_inputfilename() |
| my $SERVERIN="$LOGDIR/server.input"; # what curl sent the server |
| my $SERVER2IN="$LOGDIR/server2.input"; # what curl sent the second server |
| my $PROXYIN="$LOGDIR/proxy.input"; # what curl sent the proxy |
| my $CURLLOG="$LOGDIR/curl.log"; # all command lines run |
| my $FTPDCMD="$LOGDIR/ftpserver.cmd"; # copy ftp server instructions here |
| my $SERVERLOGS_LOCK="$LOGDIR/serverlogs.lock"; # server logs advisor read lock |
| my $CURLCONFIG="../curl-config"; # curl-config from current build |
| |
| # 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 |
| # |
| |
| # invoke perl like this: |
| my $perl="perl -I$srcdir"; |
| my $server_response_maxtime=13; |
| |
| my $debug_build=0; # curl built with --enable-debug |
| my $curl_debug=0; # curl built with --enable-curldebug (memory tracking) |
| my $libtool; |
| |
| # 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="$perl $srcdir/memanalyze.pl"; |
| |
| my $pwd = getcwd(); # current working directory |
| |
| my $start; |
| my $forkserver=0; |
| my $ftpchecktime=1; # time it took to verify our test FTP server |
| |
| my $stunnel = checkcmd("stunnel4") || checkcmd("stunnel"); |
| my $valgrind = checktestcmd("valgrind"); |
| my $valgrind_logfile="--logfile"; |
| my $valgrind_tool; |
| my $gdb = checktestcmd("gdb"); |
| my $httptlssrv = find_httptlssrv(); |
| |
| 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 $tftp_ipv6; # set if TFTP server has IPv6 support |
| my $gopher_ipv6; # set if Gopher 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_ntlm_wb; # set if libcurl is built with NTLM delegation to winbind |
| my $has_charconv;# set if libcurl is built with CharConv support |
| my $has_tls_srp; # set if libcurl is built with TLS-SRP support |
| |
| my $has_openssl; # built with a lib using an OpenSSL-like API |
| my $has_gnutls; # built with GnuTLS |
| my $has_nss; # built with NSS |
| my $has_yassl; # built with yassl |
| my $has_polarssl;# built with polarssl |
| my $has_axtls; # built with axTLS |
| |
| my $has_shared = "unknown"; # built shared |
| |
| my $ssllib; # name of the lib we use (for human presentation) |
| my $has_crypto; # set if libcurl is built with cryptographic support |
| my $has_textaware; # set if running on a system that has a text mode concept |
| # on files. Windows for example |
| |
| my @protocols; # array of lowercase supported protocol servers |
| |
| 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 |
| my %disabled_keywords; # key words of tests to skip |
| my %enabled_keywords; # key words of tests to run |
| my %disabled; # disabled test cases |
| |
| my $sshdid; # for socks server, ssh daemon version id |
| my $sshdvernum; # for socks server, ssh daemon version number |
| my $sshdverstr; # for socks server, ssh daemon version string |
| my $sshderror; # for socks server, ssh daemon version error |
| |
| my $defserverlogslocktimeout = 20; # timeout to await server logs lock removal |
| my $defpostcommanddelay = 0; # delay between command and postcheck sections |
| |
| my $timestats; # time stamping and stats generation |
| my $fullstats; # show time stats for every single test |
| my %timeprepini; # timestamp for each test preparation start |
| my %timesrvrini; # timestamp for each test required servers verification start |
| my %timesrvrend; # timestamp for each test required servers verification end |
| my %timetoolini; # timestamp for each test command run starting |
| my %timetoolend; # timestamp for each test command run stopping |
| my %timesrvrlog; # timestamp for each test server logs lock removal |
| my %timevrfyend; # timestamp for each test result verification end |
| |
| my $testnumcheck; # test number, set in singletest sub. |
| my %oldenv; |
| |
| ####################################################################### |
| # variables that command line options may set |
| # |
| |
| my $short; |
| my $verbose; |
| my $debugprotocol; |
| my $anyway; |
| my $gdbthis; # run test case with gdb debugger |
| my $gdbxwin; # use windowed gdb when using gdb |
| my $keepoutfiles; # keep stdout and stderr files after tests |
| my $listonly; # only list the tests |
| my $postmortem; # display detailed info about failed tests |
| |
| my %run; # running server |
| my %doesntrun; # servers that don't work, identified by pidfile |
| my %serverpidfile;# all server pid file names, identified by server id |
| my %runcert; # cert file currently in use by an ssl running server |
| |
| # torture test variables |
| my $torture; |
| my $tortnum; |
| my $tortalloc; |
| |
| ####################################################################### |
| # logmsg is our general message logging subroutine. |
| # |
| sub logmsg { |
| for(@_) { |
| print "$_"; |
| } |
| } |
| |
| # get the name of the current user |
| my $USER = $ENV{USER}; # Linux |
| if (!$USER) { |
| $USER = $ENV{USERNAME}; # Windows |
| if (!$USER) { |
| $USER = $ENV{LOGNAME}; # Some UNIX (I think) |
| } |
| } |
| |
| # 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($verbose); |
| die "Somebody sent me a SIG$signame"; |
| } |
| $SIG{INT} = \&catch_zap; |
| $SIG{TERM} = \&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', 'no', 'all')) { |
| my $proxy = "${protocol}_proxy"; |
| # clear lowercase version |
| delete $ENV{$proxy} if($ENV{$proxy}); |
| # clear uppercase version |
| delete $ENV{uc($proxy)} if($ENV{uc($proxy)}); |
| } |
| |
| # make sure we don't get affected by other variables that control our |
| # behaviour |
| |
| delete $ENV{'SSL_CERT_DIR'} if($ENV{'SSL_CERT_DIR'}); |
| delete $ENV{'SSL_CERT_PATH'} if($ENV{'SSL_CERT_PATH'}); |
| delete $ENV{'CURL_CA_BUNDLE'} if($ENV{'CURL_CA_BUNDLE'}); |
| |
| ####################################################################### |
| # Load serverpidfile hash with pidfile names for all possible servers. |
| # |
| sub init_serverpidfile_hash { |
| for my $proto (('ftp', 'http', 'imap', 'pop3', 'smtp')) { |
| for my $ssl (('', 's')) { |
| for my $ipvnum ((4, 6)) { |
| for my $idnum ((1, 2)) { |
| my $serv = servername_id("$proto$ssl", $ipvnum, $idnum); |
| my $pidf = server_pidfilename("$proto$ssl", $ipvnum, $idnum); |
| $serverpidfile{$serv} = $pidf; |
| } |
| } |
| } |
| } |
| for my $proto (('tftp', 'sftp', 'socks', 'ssh', 'rtsp', 'gopher', 'httptls')) { |
| for my $ipvnum ((4, 6)) { |
| for my $idnum ((1, 2)) { |
| my $serv = servername_id($proto, $ipvnum, $idnum); |
| my $pidf = server_pidfilename($proto, $ipvnum, $idnum); |
| $serverpidfile{$serv} = $pidf; |
| } |
| } |
| } |
| } |
| |
| ####################################################################### |
| # Check if a given child process has just died. Reaps it if so. |
| # |
| sub checkdied { |
| use POSIX ":sys_wait_h"; |
| my $pid = $_[0]; |
| if(not defined $pid || $pid <= 0) { |
| return 0; |
| } |
| my $rc = waitpid($pid, &WNOHANG); |
| return ($rc == $pid)?1:0; |
| } |
| |
| ####################################################################### |
| # 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, $timeout, $fake)=@_; |
| |
| logmsg "startnew: $cmd\n" if ($verbose); |
| |
| my $child = fork(); |
| my $pid2 = 0; |
| |
| if(not defined $child) { |
| logmsg "startnew: fork() failure detected\n"; |
| return (-1,-1); |
| } |
| |
| if(0 == $child) { |
| # Here we are the child. Run the given command. |
| |
| # Put an "exec" in front of the command so that the child process |
| # keeps this child's process ID. |
| exec("exec $cmd") || die "Can't exec() $cmd: $!"; |
| |
| # exec() should never return back here to this process. We protect |
| # ourselves by calling die() just in case something goes really bad. |
| die "error: exec() has returned"; |
| } |
| |
| # Ugly hack but ssh client and gnutls-serv don't support pid files |
| if ($fake) { |
| if(open(OUT, ">$pidfile")) { |
| print OUT $child . "\n"; |
| close(OUT); |
| logmsg "startnew: $pidfile faked with pid=$child\n" if($verbose); |
| } |
| else { |
| logmsg "startnew: failed to write fake $pidfile with pid=$child\n"; |
| } |
| # could/should do a while connect fails sleep a bit and loop |
| sleep $timeout; |
| if (checkdied($child)) { |
| logmsg "startnew: child process has failed to start\n" if($verbose); |
| return (-1,-1); |
| } |
| } |
| |
| my $count = $timeout; |
| while($count--) { |
| if(-f $pidfile && -s $pidfile && open(PID, "<$pidfile")) { |
| $pid2 = 0 + <PID>; |
| close(PID); |
| if(($pid2 > 0) && kill(0, $pid2)) { |
| # if $pid2 is valid, then make sure this pid is alive, as |
| # otherwise it is just likely to be the _previous_ pidfile or |
| # similar! |
| last; |
| } |
| # invalidate $pid2 if not actually alive |
| $pid2 = 0; |
| } |
| if (checkdied($child)) { |
| logmsg "startnew: child process has died, server might start up\n" |
| if($verbose); |
| # We can't just abort waiting for the server with a |
| # return (-1,-1); |
| # because the server might have forked and could still start |
| # up normally. Instead, just reduce the amount of time we remain |
| # waiting. |
| $count >>= 2; |
| } |
| sleep(1); |
| } |
| |
| # Return two PIDs, the one for the child process we spawned and the one |
| # reported by the server itself (in case it forked again on its own). |
| # Both (potentially) need to be killed at the end of the test. |
| return ($child, $pid2); |
| } |
| |
| |
| ####################################################################### |
| # Check for a command in the PATH of the test server. |
| # |
| sub checkcmd { |
| my ($cmd)=@_; |
| my @paths=(split(":", $ENV{'PATH'}), "/usr/sbin", "/usr/local/sbin", |
| "/sbin", "/usr/bin", "/usr/local/bin", |
| "./libtest/.libs", "./libtest"); |
| for(@paths) { |
| if( -x "$_/$cmd" && ! -d "$_/$cmd") { |
| # executable bit but not a directory! |
| return "$_/$cmd"; |
| } |
| } |
| } |
| |
| ####################################################################### |
| # Get the list of tests that the tests/data/Makefile.am knows about! |
| # |
| my $disttests; |
| sub get_disttests { |
| my @dist = `cd data && make show`; |
| $disttests = join("", @dist); |
| } |
| |
| ####################################################################### |
| # Check for a command in the PATH of the machine running curl. |
| # |
| sub checktestcmd { |
| my ($cmd)=@_; |
| return checkcmd($cmd); |
| } |
| |
| ####################################################################### |
| # Run the application under test and return its return code |
| # |
| sub runclient { |
| my ($cmd)=@_; |
| return system($cmd); |
| |
| # This is one way to test curl on a remote machine |
| # my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'"); |
| # sleep 2; # time to allow the NFS server to be updated |
| # return $out; |
| } |
| |
| ####################################################################### |
| # Run the application under test and return its stdout |
| # |
| sub runclientoutput { |
| my ($cmd)=@_; |
| return `$cmd`; |
| |
| # This is one way to test curl on a remote machine |
| # my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`; |
| # sleep 2; # time to allow the NFS server to be updated |
| # return @out; |
| } |
| |
| ####################################################################### |
| # 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 |
| 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 $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; |
| } |
| |
| 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 alloc 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($memdump); |
| |
| logmsg "*** Alloc number $limit is now set to fail ***\n" if($gdbthis); |
| |
| my $ret = 0; |
| if($gdbthis) { |
| runclient($gdbline) |
| } |
| else { |
| $ret = runclient($testcmd); |
| } |
| #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; |
| } |
| |
| # 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); |
| return 1; |
| } |
| } |
| |
| logmsg "torture OK\n"; |
| return 0; |
| } |
| |
| ####################################################################### |
| # Stop a test server along with pids which aren't in the %run hash yet. |
| # This also stops all servers which are relative to the given one. |
| # |
| sub stopserver { |
| my ($server, $pidlist) = @_; |
| # |
| # kill sockfilter processes for pingpong relative server |
| # |
| if($server =~ /^(ftp|imap|pop3|smtp)s?(\d*)(-ipv6|)$/) { |
| my $proto = $1; |
| my $idnum = ($2 && ($2 > 1)) ? $2 : 1; |
| my $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4; |
| killsockfilters($proto, $ipvnum, $idnum, $verbose); |
| } |
| # |
| # All servers relative to the given one must be stopped also |
| # |
| my @killservers; |
| if($server =~ /^(ftp|http|imap|pop3|smtp)s((\d*)(-ipv6|))$/) { |
| # given a stunnel based ssl server, also kill non-ssl underlying one |
| push @killservers, "${1}${2}"; |
| } |
| elsif($server =~ /^(ftp|http|imap|pop3|smtp)((\d*)(-ipv6|))$/) { |
| # given a non-ssl server, also kill stunnel based ssl piggybacking one |
| push @killservers, "${1}s${2}"; |
| } |
| elsif($server =~ /^(socks)((\d*)(-ipv6|))$/) { |
| # given a socks server, also kill ssh underlying one |
| push @killservers, "ssh${2}"; |
| } |
| elsif($server =~ /^(ssh)((\d*)(-ipv6|))$/) { |
| # given a ssh server, also kill socks piggybacking one |
| push @killservers, "socks${2}"; |
| } |
| push @killservers, $server; |
| # |
| # kill given pids and server relative ones clearing them in %run hash |
| # |
| foreach my $server (@killservers) { |
| if($run{$server}) { |
| # we must prepend a space since $pidlist may already contain a pid |
| $pidlist .= " $run{$server}"; |
| $run{$server} = 0; |
| } |
| $runcert{$server} = 0 if($runcert{$server}); |
| } |
| killpid($verbose, $pidlist); |
| # |
| # cleanup server pid files |
| # |
| foreach my $server (@killservers) { |
| my $pidfile = $serverpidfile{$server}; |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| logmsg "Warning: $server server unexpectedly alive\n"; |
| killpid($verbose, $pid); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| } |
| } |
| |
| ####################################################################### |
| # 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, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| my $bonus=""; |
| |
| my $verifyout = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.out'; |
| unlink($verifyout) if(-f $verifyout); |
| |
| my $verifylog = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; |
| unlink($verifylog) if(-f $verifylog); |
| |
| if($proto eq "gopher") { |
| # gopher is funny |
| $bonus="1/"; |
| } |
| |
| my $flags = "--max-time $server_response_maxtime "; |
| $flags .= "--output $verifyout "; |
| $flags .= "--silent "; |
| $flags .= "--verbose "; |
| $flags .= "--globoff "; |
| $flags .= "-1 " if($has_axtls); |
| $flags .= "--insecure " if($proto eq 'https'); |
| $flags .= "\"$proto://$ip:$port/${bonus}verifiedserver\""; |
| |
| my $cmd = "$VCURL $flags 2>$verifylog"; |
| |
| # verify if our/any server is running on this port |
| logmsg "RUN: $cmd\n" if($verbose); |
| my $res = runclient($cmd); |
| |
| $res >>= 8; # rotate the result |
| if($res & 128) { |
| logmsg "RUN: curl command died with a coredump\n"; |
| return -1; |
| } |
| |
| if($res && $verbose) { |
| logmsg "RUN: curl command returned $res\n"; |
| if(open(FILE, "<$verifylog")) { |
| while(my $string = <FILE>) { |
| logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); |
| } |
| close(FILE); |
| } |
| } |
| |
| my $data; |
| if(open(FILE, "<$verifyout")) { |
| while(my $string = <FILE>) { |
| $data = $string; |
| last; # only want first line |
| } |
| close(FILE); |
| } |
| |
| if($data && ($data =~ /WE ROOLZ: (\d+)/)) { |
| $pid = 0+$1; |
| } |
| elsif($res == 6) { |
| # curl: (6) Couldn't resolve host '::1' |
| logmsg "RUN: failed to resolve host ($proto://$ip:$port/verifiedserver)\n"; |
| return -1; |
| } |
| elsif($data || ($res && ($res != 7))) { |
| logmsg "RUN: Unknown server on our $server port: $port ($res)\n"; |
| return -1; |
| } |
| 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, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| my $time=time(); |
| my $extra=""; |
| |
| my $verifylog = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; |
| unlink($verifylog) if(-f $verifylog); |
| |
| if($proto eq "ftps") { |
| $extra .= "--insecure --ftp-ssl-control "; |
| } |
| elsif($proto eq "smtp") { |
| # SMTP is a bit different since it requires more options and it |
| # has _no_ output! |
| $extra .= "--mail-rcpt verifiedserver "; |
| $extra .= "--mail-from fake "; |
| $extra .= "--upload /dev/null "; |
| $extra .= "--stderr - "; # move stderr to parse the verbose stuff |
| } |
| |
| my $flags = "--max-time $server_response_maxtime "; |
| $flags .= "--silent "; |
| $flags .= "--verbose "; |
| $flags .= "--globoff "; |
| $flags .= $extra; |
| $flags .= "\"$proto://$ip:$port/verifiedserver\""; |
| |
| my $cmd = "$VCURL $flags 2>$verifylog"; |
| |
| # check if this is our server running on this port: |
| logmsg "RUN: $cmd\n" if($verbose); |
| my @data = runclientoutput($cmd); |
| |
| my $res = $? >> 8; # rotate the result |
| if($res & 128) { |
| logmsg "RUN: curl command died with a coredump\n"; |
| return -1; |
| } |
| |
| foreach my $line (@data) { |
| if($line =~ /WE ROOLZ: (\d+)/) { |
| # this is our test server with a known pid! |
| $pid = 0+$1; |
| last; |
| } |
| } |
| if($pid <= 0 && @data && $data[0]) { |
| # this is not a known server |
| logmsg "RUN: Unknown server on our $server port: $port\n"; |
| return 0; |
| } |
| # we can/should use the time it took to verify the FTP server as a measure |
| # on how fast/slow this host/FTP is. |
| my $took = int(0.5+time()-$time); |
| |
| if($verbose) { |
| logmsg "RUN: Verifying our test $server server took $took seconds\n"; |
| } |
| $ftpchecktime = $took>=1?$took:1; # make sure it never is below 1 |
| |
| 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 verifyrtsp { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| |
| my $verifyout = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.out'; |
| unlink($verifyout) if(-f $verifyout); |
| |
| my $verifylog = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; |
| unlink($verifylog) if(-f $verifylog); |
| |
| my $flags = "--max-time $server_response_maxtime "; |
| $flags .= "--output $verifyout "; |
| $flags .= "--silent "; |
| $flags .= "--verbose "; |
| $flags .= "--globoff "; |
| # currently verification is done using http |
| $flags .= "\"http://$ip:$port/verifiedserver\""; |
| |
| my $cmd = "$VCURL $flags 2>$verifylog"; |
| |
| # verify if our/any server is running on this port |
| logmsg "RUN: $cmd\n" if($verbose); |
| my $res = runclient($cmd); |
| |
| $res >>= 8; # rotate the result |
| if($res & 128) { |
| logmsg "RUN: curl command died with a coredump\n"; |
| return -1; |
| } |
| |
| if($res && $verbose) { |
| logmsg "RUN: curl command returned $res\n"; |
| if(open(FILE, "<$verifylog")) { |
| while(my $string = <FILE>) { |
| logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); |
| } |
| close(FILE); |
| } |
| } |
| |
| my $data; |
| if(open(FILE, "<$verifyout")) { |
| while(my $string = <FILE>) { |
| $data = $string; |
| last; # only want first line |
| } |
| close(FILE); |
| } |
| |
| if($data && ($data =~ /RTSP_SERVER WE ROOLZ: (\d+)/)) { |
| $pid = 0+$1; |
| } |
| elsif($res == 6) { |
| # curl: (6) Couldn't resolve host '::1' |
| logmsg "RUN: failed to resolve host ($proto://$ip:$port/verifiedserver)\n"; |
| return -1; |
| } |
| elsif($data || ($res != 7)) { |
| logmsg "RUN: Unknown server on our $server port: $port\n"; |
| return -1; |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # Verify that the ssh server has written out its pidfile, recovering |
| # the pid from the file and returning it if a process with that pid is |
| # actually alive. |
| # |
| sub verifyssh { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pidfile = server_pidfilename($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| if(open(FILE, "<$pidfile")) { |
| $pid=0+<FILE>; |
| close(FILE); |
| } |
| if($pid > 0) { |
| # if we have a pid it is actually our ssh server, |
| # since runsshserver() unlinks previous pidfile |
| if(!kill(0, $pid)) { |
| logmsg "RUN: SSH server has died after starting up\n"; |
| checkdied($pid); |
| unlink($pidfile); |
| $pid = -1; |
| } |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # Verify that we can connect to the sftp server, properly authenticate |
| # with generated config and key files and run a simple remote pwd. |
| # |
| sub verifysftp { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $verified = 0; |
| # Find out sftp client canonical file name |
| my $sftp = find_sftp(); |
| if(!$sftp) { |
| logmsg "RUN: SFTP server cannot find $sftpexe\n"; |
| return -1; |
| } |
| # Find out ssh client canonical file name |
| my $ssh = find_ssh(); |
| if(!$ssh) { |
| logmsg "RUN: SFTP server cannot find $sshexe\n"; |
| return -1; |
| } |
| # Connect to sftp server, authenticate and run a remote pwd |
| # command using our generated configuration and key files |
| my $cmd = "$sftp -b $sftpcmds -F $sftpconfig -S $ssh $ip > $sftplog 2>&1"; |
| my $res = runclient($cmd); |
| # Search for pwd command response in log file |
| if(open(SFTPLOGFILE, "<$sftplog")) { |
| while(<SFTPLOGFILE>) { |
| if(/^Remote working directory: /) { |
| $verified = 1; |
| last; |
| } |
| } |
| close(SFTPLOGFILE); |
| } |
| return $verified; |
| } |
| |
| ####################################################################### |
| # Verify that the non-stunnel HTTP TLS extensions capable 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 verifyhttptls { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pidfile = server_pidfilename($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| |
| my $verifyout = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.out'; |
| unlink($verifyout) if(-f $verifyout); |
| |
| my $verifylog = "$LOGDIR/". |
| servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; |
| unlink($verifylog) if(-f $verifylog); |
| |
| my $flags = "--max-time $server_response_maxtime "; |
| $flags .= "--output $verifyout "; |
| $flags .= "--verbose "; |
| $flags .= "--globoff "; |
| $flags .= "--insecure "; |
| $flags .= "--tlsauthtype SRP "; |
| $flags .= "--tlsuser jsmith "; |
| $flags .= "--tlspassword abc "; |
| $flags .= "\"https://$ip:$port/verifiedserver\""; |
| |
| my $cmd = "$VCURL $flags 2>$verifylog"; |
| |
| # verify if our/any server is running on this port |
| logmsg "RUN: $cmd\n" if($verbose); |
| my $res = runclient($cmd); |
| |
| $res >>= 8; # rotate the result |
| if($res & 128) { |
| logmsg "RUN: curl command died with a coredump\n"; |
| return -1; |
| } |
| |
| if($res && $verbose) { |
| logmsg "RUN: curl command returned $res\n"; |
| if(open(FILE, "<$verifylog")) { |
| while(my $string = <FILE>) { |
| logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); |
| } |
| close(FILE); |
| } |
| } |
| |
| my $data; |
| if(open(FILE, "<$verifyout")) { |
| while(my $string = <FILE>) { |
| $data .= $string; |
| } |
| close(FILE); |
| } |
| |
| if($data && ($data =~ /GNUTLS/) && open(FILE, "<$pidfile")) { |
| $pid=0+<FILE>; |
| close(FILE); |
| if($pid > 0) { |
| # if we have a pid it is actually our httptls server, |
| # since runhttptlsserver() unlinks previous pidfile |
| if(!kill(0, $pid)) { |
| logmsg "RUN: $server server has died after starting up\n"; |
| checkdied($pid); |
| unlink($pidfile); |
| $pid = -1; |
| } |
| } |
| return $pid; |
| } |
| elsif($res == 6) { |
| # curl: (6) Couldn't resolve host '::1' |
| logmsg "RUN: failed to resolve host (https://$ip:$port/verifiedserver)\n"; |
| return -1; |
| } |
| elsif($data || ($res && ($res != 7))) { |
| logmsg "RUN: Unknown server on our $server port: $port ($res)\n"; |
| return -1; |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # STUB for verifying socks |
| # |
| sub verifysocks { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pidfile = server_pidfilename($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| if(open(FILE, "<$pidfile")) { |
| $pid=0+<FILE>; |
| close(FILE); |
| } |
| if($pid > 0) { |
| # if we have a pid it is actually our socks server, |
| # since runsocksserver() unlinks previous pidfile |
| if(!kill(0, $pid)) { |
| logmsg "RUN: SOCKS server has died after starting up\n"; |
| checkdied($pid); |
| unlink($pidfile); |
| $pid = -1; |
| } |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # Verify that the server that runs on $ip, $port is our server. |
| # Retry over several seconds before giving up. The ssh server in |
| # particular can take a long time to start if it needs to generate |
| # keys on a slow or loaded host. |
| # |
| # Just for convenience, test harness uses 'https' and 'httptls' literals |
| # as values for 'proto' variable in order to differentiate different |
| # servers. 'https' literal is used for stunnel based https test servers, |
| # and 'httptls' is used for non-stunnel https test servers. |
| # |
| |
| my %protofunc = ('http' => \&verifyhttp, |
| 'https' => \&verifyhttp, |
| 'rtsp' => \&verifyrtsp, |
| 'ftp' => \&verifyftp, |
| 'pop3' => \&verifyftp, |
| 'imap' => \&verifyftp, |
| 'smtp' => \&verifyftp, |
| 'ftps' => \&verifyftp, |
| 'tftp' => \&verifyftp, |
| 'ssh' => \&verifyssh, |
| 'socks' => \&verifysocks, |
| 'gopher' => \&verifyhttp, |
| 'httptls' => \&verifyhttptls); |
| |
| sub verifyserver { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| |
| my $count = 30; # try for this many seconds |
| my $pid; |
| |
| while($count--) { |
| my $fun = $protofunc{$proto}; |
| |
| $pid = &$fun($proto, $ipvnum, $idnum, $ip, $port); |
| |
| if($pid > 0) { |
| last; |
| } |
| elsif($pid < 0) { |
| # a real failure, stop trying and bail out |
| return 0; |
| } |
| sleep(1); |
| } |
| return $pid; |
| } |
| |
| ####################################################################### |
| # Single shot server responsiveness test. This should only be used |
| # to verify that a server present in %run hash is still functional |
| # |
| sub responsiveserver { |
| my ($proto, $ipvnum, $idnum, $ip, $port) = @_; |
| my $prev_verbose = $verbose; |
| |
| $verbose = 0; |
| my $fun = $protofunc{$proto}; |
| my $pid = &$fun($proto, $ipvnum, $idnum, $ip, $port); |
| $verbose = $prev_verbose; |
| |
| if($pid > 0) { |
| return 1; # responsive |
| } |
| |
| my $srvrname = servername_str($proto, $ipvnum, $idnum); |
| logmsg " server precheck FAILED (unresponsive $srvrname server)\n"; |
| return 0; |
| } |
| |
| ####################################################################### |
| # start the http server |
| # |
| sub runhttpserver { |
| my ($proto, $verbose, $alt, $port) = @_; |
| my $ip = $HOSTIP; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($alt eq "ipv6") { |
| # if IPv6, use a different setup |
| $ipvnum = 6; |
| $ip = $HOST6IP; |
| } |
| elsif($alt eq "proxy") { |
| # basically the same, but another ID |
| $idnum = 2; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--fork " if($forkserver); |
| $flags .= "--gopher " if($proto eq "gopher"); |
| $flags .= "--connect $HOSTIP " if($alt eq "proxy"); |
| $flags .= "--verbose " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port $port --srcdir \"$srcdir\""; |
| |
| my $cmd = "$perl $srcdir/httpserver.pl $flags"; |
| my ($httppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($httppid <= 0 || !kill(0, $httppid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$httppid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $httppid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($httppid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the https stunnel based server |
| # |
| sub runhttpsserver { |
| my ($verbose, $ipv6, $certfile) = @_; |
| my $proto = 'https'; |
| my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; |
| my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if(!$stunnel) { |
| return (0,0); |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $certfile = 'stunnel.pem' unless($certfile); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--verbose " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --proto $proto "; |
| $flags .= "--certfile \"$certfile\" " if($certfile ne 'stunnel.pem'); |
| $flags .= "--stunnel \"$stunnel\" --srcdir \"$srcdir\" "; |
| $flags .= "--connect $HTTPPORT --accept $HTTPSPORT"; |
| |
| my $cmd = "$perl $srcdir/secureserver.pl $flags"; |
| my ($httpspid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($httpspid <= 0 || !kill(0, $httpspid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return(0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $HTTPSPORT); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$httpspid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| # Here pid3 is actually the pid returned by the unsecure-http server. |
| |
| $runcert{$server} = $certfile; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $httpspid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($httpspid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the non-stunnel HTTP TLS extensions capable server |
| # |
| sub runhttptlsserver { |
| my ($verbose, $ipv6) = @_; |
| my $proto = "httptls"; |
| my $port = ($ipv6 && ($ipv6 =~ /6$/)) ? $HTTPTLS6PORT : $HTTPTLSPORT; |
| my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; |
| my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if(!$httptlssrv) { |
| return (0,0); |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--http "; |
| $flags .= "--debug 1 " if($debugprotocol); |
| $flags .= "--port $port "; |
| $flags .= "--srppasswd certs/srp-verifier-db "; |
| $flags .= "--srppasswdconf certs/srp-verifier-conf"; |
| |
| my $cmd = "$httptlssrv $flags > $logfile 2>&1"; |
| my ($httptlspid, $pid2) = startnew($cmd, $pidfile, 10, 1); # fake pidfile |
| |
| if($httptlspid <= 0 || !kill(0, $httptlspid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. PID is from fake pidfile |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$httptlspid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $httptlspid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($httptlspid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the pingpong server (FTP, POP3, IMAP, SMTP) |
| # |
| sub runpingpongserver { |
| my ($proto, $id, $verbose, $ipv6) = @_; |
| my $port; |
| my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; |
| my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($proto eq "ftp") { |
| $port = ($idnum>1)?$FTP2PORT:$FTPPORT; |
| |
| if($ipvnum==6) { |
| # if IPv6, use a different setup |
| $port = $FTP6PORT; |
| } |
| } |
| elsif($proto eq "pop3") { |
| $port = ($ipvnum==6) ? $POP36PORT : $POP3PORT; |
| } |
| elsif($proto eq "imap") { |
| $port = ($ipvnum==6) ? $IMAP6PORT : $IMAPPORT; |
| } |
| elsif($proto eq "smtp") { |
| $port = ($ipvnum==6) ? $SMTP6PORT : $SMTPPORT; |
| } |
| else { |
| print STDERR "Unsupported protocol $proto!!\n"; |
| return 0; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--verbose " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--srcdir \"$srcdir\" --proto $proto "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port $port --addr \"$ip\""; |
| |
| my $cmd = "$perl $srcdir/ftpserver.pl $flags"; |
| my ($ftppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($ftppid <= 0 || !kill(0, $ftppid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$ftppid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $ftppid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($pid2, $ftppid); |
| } |
| |
| ####################################################################### |
| # start the ftps server (or rather, tunnel) |
| # |
| sub runftpsserver { |
| my ($verbose, $ipv6, $certfile) = @_; |
| my $proto = 'ftps'; |
| my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; |
| my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if(!$stunnel) { |
| return (0,0); |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $certfile = 'stunnel.pem' unless($certfile); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--verbose " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --proto $proto "; |
| $flags .= "--certfile \"$certfile\" " if($certfile ne 'stunnel.pem'); |
| $flags .= "--stunnel \"$stunnel\" --srcdir \"$srcdir\" "; |
| $flags .= "--connect $FTPPORT --accept $FTPSPORT"; |
| |
| my $cmd = "$perl $srcdir/secureserver.pl $flags"; |
| my ($ftpspid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($ftpspid <= 0 || !kill(0, $ftpspid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return(0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $FTPSPORT); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$ftpspid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| # Here pid3 is actually the pid returned by the unsecure-ftp server. |
| |
| $runcert{$server} = $certfile; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $ftpspid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($ftpspid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the tftp server |
| # |
| sub runtftpserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $port = $TFTPPORT; |
| my $ip = $HOSTIP; |
| my $proto = 'tftp'; |
| my $ipvnum = 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($ipv6) { |
| # if IPv6, use a different setup |
| $ipvnum = 6; |
| $port = $TFTP6PORT; |
| $ip = $HOST6IP; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--verbose " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port $port --srcdir \"$srcdir\""; |
| |
| my $cmd = "$perl $srcdir/tftpserver.pl $flags"; |
| my ($tftppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($tftppid <= 0 || !kill(0, $tftppid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$tftppid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $tftppid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($pid2, $tftppid); |
| } |
| |
| |
| ####################################################################### |
| # start the rtsp server |
| # |
| sub runrtspserver { |
| my ($verbose, $ipv6) = @_; |
| my $port = $RTSPPORT; |
| my $ip = $HOSTIP; |
| my $proto = 'rtsp'; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($ipv6) { |
| # if IPv6, use a different setup |
| $ipvnum = 6; |
| $port = $RTSP6PORT; |
| $ip = $HOST6IP; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--verbose " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port $port --srcdir \"$srcdir\""; |
| |
| my $cmd = "$perl $srcdir/rtspserver.pl $flags"; |
| my ($rtsppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($rtsppid <= 0 || !kill(0, $rtsppid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$rtsppid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $rtsppid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($rtsppid, $pid2); |
| } |
| |
| |
| ####################################################################### |
| # Start the ssh (scp/sftp) server |
| # |
| sub runsshserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $ip=$HOSTIP; |
| my $port = $SSHPORT; |
| my $socksport = $SOCKSPORT; |
| my $proto = 'ssh'; |
| my $ipvnum = 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| $flags .= "--verbose " if($verbose); |
| $flags .= "--debugprotocol " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --addr \"$ip\" "; |
| $flags .= "--sshport $port --socksport $socksport "; |
| $flags .= "--user \"$USER\""; |
| |
| my $cmd = "$perl $srcdir/sshserver.pl $flags"; |
| my ($sshpid, $pid2) = startnew($cmd, $pidfile, 60, 0); |
| |
| # on loaded systems sshserver start up can take longer than the timeout |
| # passed to startnew, when this happens startnew completes without being |
| # able to read the pidfile and consequently returns a zero pid2 above. |
| |
| if($sshpid <= 0 || !kill(0, $sshpid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # ssh server verification allows some extra time for the server to start up |
| # and gives us the opportunity of recovering the pid from the pidfile, when |
| # this verification succeeds the recovered pid is assigned to pid2. |
| |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to fetch server pid. Kill the server and return failure |
| stopserver($server, "$sshpid $pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| # once it is known that the ssh server is alive, sftp server verification |
| # is performed actually connecting to it, authenticating and performing a |
| # very simple remote command. This verification is tried only one time. |
| |
| $sshdlog = server_logfilename($LOGDIR, 'ssh', $ipvnum, $idnum); |
| $sftplog = server_logfilename($LOGDIR, 'sftp', $ipvnum, $idnum); |
| |
| if(verifysftp('sftp', $ipvnum, $idnum, $ip, $port) < 1) { |
| logmsg "RUN: SFTP server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| display_sftplog(); |
| display_sftpconfig(); |
| display_sshdlog(); |
| display_sshdconfig(); |
| stopserver($server, "$sshpid $pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $pid2\n"; |
| } |
| |
| return ($pid2, $sshpid); |
| } |
| |
| ####################################################################### |
| # Start the socks server |
| # |
| sub runsocksserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $ip=$HOSTIP; |
| my $port = $SOCKSPORT; |
| my $proto = 'socks'; |
| my $ipvnum = 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| |
| # don't retry if the server doesn't work |
| if ($doesntrun{$pidfile}) { |
| return (0,0); |
| } |
| |
| my $pid = processexists($pidfile); |
| if($pid > 0) { |
| stopserver($server, "$pid"); |
| } |
| unlink($pidfile) if(-f $pidfile); |
| |
| $srvrname = servername_str($proto, $ipvnum, $idnum); |
| |
| $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); |
| |
| # 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 daemon canonical file name |
| my $sshd = find_sshd(); |
| if(!$sshd) { |
| logmsg "RUN: SOCKS server cannot find $sshdexe\n"; |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Find out ssh daemon version info |
| ($sshdid, $sshdvernum, $sshdverstr, $sshderror) = sshversioninfo($sshd); |
| if(!$sshdid) { |
| # Not an OpenSSH or SunSSH ssh daemon |
| logmsg "$sshderror\n" if($verbose); |
| logmsg "SCP, SFTP and SOCKS tests require OpenSSH 2.9.9 or later\n"; |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| logmsg "ssh server found $sshd is $sshdverstr\n" if($verbose); |
| |
| # 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 |
| my ($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); |
| |
| # Verify if ssh client and ssh daemon versions match |
| if(($sshdid ne $sshid) || ($sshdvernum != $sshvernum)) { |
| # Our test harness might work with slightly mismatched versions |
| logmsg "Warning: version mismatch: sshd $sshdverstr - ssh $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); |
| } |
| |
| $sshlog = server_logfilename($LOGDIR, 'socks', $ipvnum, $idnum); |
| |
| # start our socks server |
| my $cmd="$ssh -N -F $sshconfig $ip > $sshlog 2>&1"; |
| my ($sshpid, $pid2) = startnew($cmd, $pidfile, 30, 1); # fake pidfile |
| |
| if($sshpid <= 0 || !kill(0, $sshpid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| display_sshlog(); |
| display_sshconfig(); |
| display_sshdlog(); |
| display_sshdconfig(); |
| stopserver($server, "$pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| # Ugly hack but ssh doesn't support pid files. PID is from fake pidfile. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); |
| if(!$pid3) { |
| logmsg "RUN: $srvrname server failed verification\n"; |
| # failed to talk to it properly. Kill the server and return failure |
| stopserver($server, "$sshpid $pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $pid2\n"; |
| } |
| |
| return ($pid2, $sshpid); |
| } |
| |
| ####################################################################### |
| # Single shot http and gopher server responsiveness test. This should only |
| # be used to verify that a server present in %run hash is still functional |
| # |
| sub responsive_http_server { |
| my ($proto, $verbose, $alt, $port) = @_; |
| my $ip = $HOSTIP; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| |
| if($alt eq "ipv6") { |
| # if IPv6, use a different setup |
| $ipvnum = 6; |
| $ip = $HOST6IP; |
| } |
| elsif($alt eq "proxy") { |
| $idnum = 2; |
| } |
| |
| return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); |
| } |
| |
| ####################################################################### |
| # Single shot pingpong server responsiveness test. This should only be |
| # used to verify that a server present in %run hash is still functional |
| # |
| sub responsive_pingpong_server { |
| my ($proto, $id, $verbose, $ipv6) = @_; |
| my $port; |
| my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; |
| my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| |
| if($proto eq "ftp") { |
| $port = ($idnum>1)?$FTP2PORT:$FTPPORT; |
| |
| if($ipvnum==6) { |
| # if IPv6, use a different setup |
| $port = $FTP6PORT; |
| } |
| } |
| elsif($proto eq "pop3") { |
| $port = ($ipvnum==6) ? $POP36PORT : $POP3PORT; |
| } |
| elsif($proto eq "imap") { |
| $port = ($ipvnum==6) ? $IMAP6PORT : $IMAPPORT; |
| } |
| elsif($proto eq "smtp") { |
| $port = ($ipvnum==6) ? $SMTP6PORT : $SMTPPORT; |
| } |
| else { |
| print STDERR "Unsupported protocol $proto!!\n"; |
| return 0; |
| } |
| |
| return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); |
| } |
| |
| ####################################################################### |
| # Single shot rtsp server responsiveness test. This should only be |
| # used to verify that a server present in %run hash is still functional |
| # |
| sub responsive_rtsp_server { |
| my ($verbose, $ipv6) = @_; |
| my $port = $RTSPPORT; |
| my $ip = $HOSTIP; |
| my $proto = 'rtsp'; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| |
| if($ipv6) { |
| # if IPv6, use a different setup |
| $ipvnum = 6; |
| $port = $RTSP6PORT; |
| $ip = $HOST6IP; |
| } |
| |
| return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); |
| } |
| |
| ####################################################################### |
| # Single shot tftp server responsiveness test. This should only be |
| # used to verify that a server present in %run hash is still functional |
| # |
| sub responsive_tftp_server { |
| my ($id, $verbose, $ipv6) = @_; |
| my $port = $TFTPPORT; |
| my $ip = $HOSTIP; |
| my $proto = 'tftp'; |
| my $ipvnum = 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| |
| if($ipv6) { |
| # if IPv6, use a different setup |
| $ipvnum = 6; |
| $port = $TFTP6PORT; |
| $ip = $HOST6IP; |
| } |
| |
| return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); |
| } |
| |
| ####################################################################### |
| # Single shot non-stunnel HTTP TLS extensions capable server |
| # responsiveness test. This should only be used to verify that a |
| # server present in %run hash is still functional |
| # |
| sub responsive_httptls_server { |
| my ($verbose, $ipv6) = @_; |
| my $proto = "httptls"; |
| my $port = ($ipv6 && ($ipv6 =~ /6$/)) ? $HTTPTLS6PORT : $HTTPTLSPORT; |
| my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; |
| my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; |
| my $idnum = 1; |
| |
| return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); |
| } |
| |
| ####################################################################### |
| # 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 $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; |
| 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) { |
| $has_openssl=1; |
| $ssllib="OpenSSL"; |
| } |
| elsif ($libcurl =~ /gnutls/i) { |
| $has_gnutls=1; |
| $ssllib="GnuTLS"; |
| } |
| elsif ($libcurl =~ /nss/i) { |
| $has_nss=1; |
| $ssllib="NSS"; |
| } |
| elsif ($libcurl =~ /yassl/i) { |
| $has_yassl=1; |
| $has_openssl=1; |
| $ssllib="yassl"; |
| } |
| elsif ($libcurl =~ /polarssl/i) { |
| $has_polarssl=1; |
| $has_openssl=1; |
| $ssllib="polarssl"; |
| } |
| elsif ($libcurl =~ /axtls/i) { |
| $has_axtls=1; |
| $ssllib="axTLS"; |
| } |
| } |
| elsif($_ =~ /^Protocols: (.*)/i) { |
| # these are the protocols compiled in to this libcurl |
| @protocols = split(' ', lc($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); |
| |
| # 'http-proxy' is used in test cases to do CONNECT through |
| push @protocols, 'http-proxy'; |
| |
| # 'none' is used in test cases to mean no server |
| push @protocols, 'none'; |
| } |
| elsif($_ =~ /^Features: (.*)/i) { |
| $feat = $1; |
| if($feat =~ /TrackMemory/i) { |
| # curl was built with --enable-curldebug (memory tracking) |
| $curl_debug = 1; |
| } |
| if($feat =~ /debug/i) { |
| # curl was built with --enable-debug |
| $debug_build = 1; |
| } |
| 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($feat =~ /NTLM_WB/i) { |
| # NTLM delegation to winbind daemon ntlm_auth helper enabled |
| $has_ntlm_wb=1; |
| } |
| if($feat =~ /CharConv/i) { |
| # CharConv enabled |
| $has_charconv=1; |
| } |
| if($feat =~ /TLS-SRP/i) { |
| # TLS-SRP enabled |
| $has_tls_srp=1; |
| } |
| } |
| # |
| # Test harness currently uses a non-stunnel server in order to |
| # run HTTP TLS-SRP tests required when curl is built with https |
| # protocol support and TLS-SRP feature enabled. For convenience |
| # 'httptls' may be included in the test harness protocols array |
| # to differentiate this from classic stunnel based 'https' test |
| # harness server. |
| # |
| if($has_tls_srp) { |
| my $add_httptls; |
| for(@protocols) { |
| if($_ =~ /^https(-ipv6|)$/) { |
| $add_httptls=1; |
| last; |
| } |
| } |
| if($add_httptls && (! grep /^httptls$/, @protocols)) { |
| push @protocols, 'httptls'; |
| push @protocols, 'httptls-ipv6'; |
| } |
| } |
| } |
| 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/curl_config.h") { |
| open(CONF, "<../lib/curl_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; |
| $gopher_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 built with curldebug"; |
| } |
| |
| $has_shared = `sh $CURLCONFIG --built-shared`; |
| chomp $has_shared; |
| |
| # 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", |
| "* Features: $feat\n", |
| "* Host: $hostname", |
| "* System: $hosttype"); |
| |
| logmsg sprintf("* Server SSL: %8s", $stunnel?"ON ":"OFF"); |
| logmsg sprintf(" libcurl SSL: %s\n", $ssl_version?"ON ":"OFF"); |
| logmsg sprintf("* debug build: %8s", $debug_build?"ON ":"OFF"); |
| logmsg sprintf(" track memory: %s\n", $curl_debug?"ON ":"OFF"); |
| logmsg sprintf("* valgrind: %8s", $valgrind?"ON ":"OFF"); |
| logmsg sprintf(" HTTP IPv6 %s\n", $http_ipv6?"ON ":"OFF"); |
| logmsg sprintf("* FTP IPv6 %8s", $ftp_ipv6?"ON ":"OFF"); |
| logmsg sprintf(" Libtool lib: %s\n", $libtool?"ON ":"OFF"); |
| logmsg sprintf("* Shared build: %s\n", $has_shared); |
| if($ssl_version) { |
| logmsg sprintf("* SSL library: %13s\n", $ssllib); |
| } |
| |
| logmsg "* Ports:\n"; |
| |
| logmsg sprintf("* HTTP/%d ", $HTTPPORT); |
| logmsg sprintf("FTP/%d ", $FTPPORT); |
| logmsg sprintf("FTP2/%d ", $FTP2PORT); |
| logmsg sprintf("RTSP/%d ", $RTSPPORT); |
| if($stunnel) { |
| logmsg sprintf("FTPS/%d ", $FTPSPORT); |
| logmsg sprintf("HTTPS/%d ", $HTTPSPORT); |
| } |
| logmsg sprintf("\n* TFTP/%d ", $TFTPPORT); |
| if($http_ipv6) { |
| logmsg sprintf("HTTP-IPv6/%d ", $HTTP6PORT); |
| logmsg sprintf("RTSP-IPv6/%d ", $RTSP6PORT); |
| } |
| if($ftp_ipv6) { |
| logmsg sprintf("FTP-IPv6/%d ", $FTP6PORT); |
| } |
| if($tftp_ipv6) { |
| logmsg sprintf("TFTP-IPv6/%d ", $TFTP6PORT); |
| } |
| logmsg sprintf("\n* GOPHER/%d ", $GOPHERPORT); |
| if($gopher_ipv6) { |
| logmsg sprintf("GOPHER-IPv6/%d", $GOPHERPORT); |
| } |
| logmsg sprintf("\n* SSH/%d ", $SSHPORT); |
| logmsg sprintf("SOCKS/%d ", $SOCKSPORT); |
| logmsg sprintf("POP3/%d ", $POP3PORT); |
| logmsg sprintf("IMAP/%d ", $IMAPPORT); |
| logmsg sprintf("SMTP/%d\n", $SMTPPORT); |
| if($ftp_ipv6) { |
| logmsg sprintf("* POP3-IPv6/%d ", $POP36PORT); |
| logmsg sprintf("IMAP-IPv6/%d ", $IMAP6PORT); |
| logmsg sprintf("SMTP-IPv6/%d\n", $SMTP6PORT); |
| } |
| if($httptlssrv) { |
| logmsg sprintf("* HTTPTLS/%d ", $HTTPTLSPORT); |
| if($has_ipv6) { |
| logmsg sprintf("HTTPTLS-IPv6/%d ", $HTTPTLS6PORT); |
| } |
| logmsg "\n"; |
| } |
| |
| $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) = @_; |
| |
| # ports |
| |
| $$thing =~ s/%FTP6PORT/$FTP6PORT/g; |
| $$thing =~ s/%FTP2PORT/$FTP2PORT/g; |
| $$thing =~ s/%FTPSPORT/$FTPSPORT/g; |
| $$thing =~ s/%FTPPORT/$FTPPORT/g; |
| |
| $$thing =~ s/%GOPHER6PORT/$GOPHER6PORT/g; |
| $$thing =~ s/%GOPHERPORT/$GOPHERPORT/g; |
| |
| $$thing =~ s/%HTTPTLS6PORT/$HTTPTLS6PORT/g; |
| $$thing =~ s/%HTTPTLSPORT/$HTTPTLSPORT/g; |
| $$thing =~ s/%HTTP6PORT/$HTTP6PORT/g; |
| $$thing =~ s/%HTTPSPORT/$HTTPSPORT/g; |
| $$thing =~ s/%HTTPPORT/$HTTPPORT/g; |
| $$thing =~ s/%PROXYPORT/$HTTPPROXYPORT/g; |
| |
| $$thing =~ s/%IMAP6PORT/$IMAP6PORT/g; |
| $$thing =~ s/%IMAPPORT/$IMAPPORT/g; |
| |
| $$thing =~ s/%POP36PORT/$POP36PORT/g; |
| $$thing =~ s/%POP3PORT/$POP3PORT/g; |
| |
| $$thing =~ s/%RTSP6PORT/$RTSP6PORT/g; |
| $$thing =~ s/%RTSPPORT/$RTSPPORT/g; |
| |
| $$thing =~ s/%SMTP6PORT/$SMTP6PORT/g; |
| $$thing =~ s/%SMTPPORT/$SMTPPORT/g; |
| |
| $$thing =~ s/%SOCKSPORT/$SOCKSPORT/g; |
| $$thing =~ s/%SSHPORT/$SSHPORT/g; |
| |
| $$thing =~ s/%TFTP6PORT/$TFTP6PORT/g; |
| $$thing =~ s/%TFTPPORT/$TFTPPORT/g; |
| |
| # client IP addresses |
| |
| $$thing =~ s/%CLIENT6IP/$CLIENT6IP/g; |
| $$thing =~ s/%CLIENTIP/$CLIENTIP/g; |
| |
| # server IP addresses |
| |
| $$thing =~ s/%HOST6IP/$HOST6IP/g; |
| $$thing =~ s/%HOSTIP/$HOSTIP/g; |
| |
| # misc |
| |
| $$thing =~ s/%CURL/$CURL/g; |
| $$thing =~ s/%PWD/$pwd/g; |
| $$thing =~ s/%SRCDIR/$srcdir/g; |
| $$thing =~ s/%USER/$USER/g; |
| |
| # 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; |
| } |
| |
| sub fixarray { |
| my @in = @_; |
| |
| for(@in) { |
| subVariables \$_; |
| } |
| return @in; |
| } |
| |
| ####################################################################### |
| # Provide time stamps for single test skipped events |
| # |
| sub timestampskippedevents { |
| my $testnum = $_[0]; |
| |
| return if((not defined($testnum)) || ($testnum < 1)); |
| |
| if($timestats) { |
| |
| if($timevrfyend{$testnum}) { |
| return; |
| } |
| elsif($timesrvrlog{$testnum}) { |
| $timevrfyend{$testnum} = $timesrvrlog{$testnum}; |
| return; |
| } |
| elsif($timetoolend{$testnum}) { |
| $timevrfyend{$testnum} = $timetoolend{$testnum}; |
| $timesrvrlog{$testnum} = $timetoolend{$testnum}; |
| } |
| elsif($timetoolini{$testnum}) { |
| $timevrfyend{$testnum} = $timetoolini{$testnum}; |
| $timesrvrlog{$testnum} = $timetoolini{$testnum}; |
| $timetoolend{$testnum} = $timetoolini{$testnum}; |
| } |
| elsif($timesrvrend{$testnum}) { |
| $timevrfyend{$testnum} = $timesrvrend{$testnum}; |
| $timesrvrlog{$testnum} = $timesrvrend{$testnum}; |
| $timetoolend{$testnum} = $timesrvrend{$testnum}; |
| $timetoolini{$testnum} = $timesrvrend{$testnum}; |
| } |
| elsif($timesrvrini{$testnum}) { |
| $timevrfyend{$testnum} = $timesrvrini{$testnum}; |
| $timesrvrlog{$testnum} = $timesrvrini{$testnum}; |
| $timetoolend{$testnum} = $timesrvrini{$testnum}; |
| $timetoolini{$testnum} = $timesrvrini{$testnum}; |
| $timesrvrend{$testnum} = $timesrvrini{$testnum}; |
| } |
| elsif($timeprepini{$testnum}) { |
| $timevrfyend{$testnum} = $timeprepini{$testnum}; |
| $timesrvrlog{$testnum} = $timeprepini{$testnum}; |
| $timetoolend{$testnum} = $timeprepini{$testnum}; |
| $timetoolini{$testnum} = $timeprepini{$testnum}; |
| $timesrvrend{$testnum} = $timeprepini{$testnum}; |
| $timesrvrini{$testnum} = $timeprepini{$testnum}; |
| } |
| } |
| } |
| |
| ####################################################################### |
| # Run a single specified test case |
| # |
| sub singletest { |
| my ($testnum, $count, $total)=@_; |
| |
| my @what; |
| my $why; |
| my %feature; |
| my $cmd; |
| my $disablevalgrind; |
| |
| # copy test number to a global scope var, this allows |
| # testnum checking when starting test harness servers. |
| $testnumcheck = $testnum; |
| |
| # timestamp test preparation start |
| $timeprepini{$testnum} = Time::HiRes::time() if($timestats); |
| |
| if($disttests !~ /test$testnum\W/ ) { |
| logmsg "Warning: test$testnum not present in tests/data/Makefile.am\n"; |
| } |
| if($disabled{$testnum}) { |
| logmsg "Warning: test$testnum is explicitly disabled\n"; |
| } |
| |
| # 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 "NSS") { |
| if($has_nss) { |
| next; |
| } |
| } |
| elsif($f eq "axTLS") { |
| if($has_axtls) { |
| next; |
| } |
| } |
| elsif($f eq "unittest") { |
| if($debug_build) { |
| next; |
| } |
| } |
| elsif($f eq "debug") { |
| if($debug_build) { |
| 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 "NTLM_WB") { |
| if($has_ntlm_wb) { |
| next; |
| } |
| } |
| elsif($f eq "getrlimit") { |
| if($has_getrlimit) { |
| next; |
| } |
| } |
| elsif($f eq "crypto") { |
| if($has_crypto) { |
| next; |
| } |
| } |
| elsif($f eq "TLS-SRP") { |
| if($has_tls_srp) { |
| next; |
| } |
| } |
| elsif($f eq "socks") { |
| next; |
| } |
| # See if this "feature" is in the list of supported protocols |
| elsif (grep /^\Q$f\E$/i, @protocols) { |
| next; |
| } |
| |
| $why = "curl lacks $f support"; |
| last; |
| } |
| |
| if(!$why) { |
| my @keywords = getpart("info", "keywords"); |
| my $match; |
| my $k; |
| for $k (@keywords) { |
| chomp $k; |
| if ($disabled_keywords{$k}) { |
| $why = "disabled by keyword"; |
| } elsif ($enabled_keywords{$k}) { |
| $match = 1; |
| } |
| } |
| |
| if(!$why && !$match && %enabled_keywords) { |
| $why = "disabled by missing keyword"; |
| } |
| } |
| |
| # test definition may instruct to (un)set environment vars |
| # this is done this early, so that the precheck can use environment |
| # variables and still bail out fine on errors |
| |
| # restore environment variables that were modified in a previous run |
| foreach my $var (keys %oldenv) { |
| if($oldenv{$var} eq 'notset') { |
| delete $ENV{$var} if($ENV{$var}); |
| } |
| else { |
| $ENV{$var} = $oldenv{$var}; |
| } |
| delete $oldenv{$var}; |
| } |
| |
| # remove test server commands file before servers are started/verified |
| unlink($FTPDCMD) if(-f $FTPDCMD); |
| |
| # timestamp required servers verification start |
| $timesrvrini{$testnum} = Time::HiRes::time() if($timestats); |
| |
| if(!$why) { |
| $why = serverfortest($testnum); |
| } |
| |
| # timestamp required servers verification end |
| $timesrvrend{$testnum} = Time::HiRes::time() if($timestats); |
| |
| my @setenv = getpart("client", "setenv"); |
| if(@setenv) { |
| foreach my $s (@setenv) { |
| chomp $s; |
| subVariables \$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() && (exe_ext() eq '.exe')) { |
| # print "Skipping LD_PRELOAD due to lack of OS support\n"; |
| next; |
| } |
| if($debug_build || ($has_shared ne "yes")) { |
| # print "Skipping LD_PRELOAD due to no release shared build\n"; |
| next; |
| } |
| } |
| $ENV{$var} = "$content"; |
| } |
| } |
| } |
| } |
| |
| if(!$why) { |
| # TODO: |
| # Add a precheck cache. If a precheck command was already invoked |
| # exactly like this, then use the previous result to speed up |
| # successive test invokes! |
| |
| my @precheck = getpart("client", "precheck"); |
| if(@precheck) { |
| $cmd = $precheck[0]; |
| chomp $cmd; |
| subVariables \$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>/dev/null`; |
| if($o[0]) { |
| $why = $o[0]; |
| chomp $why; |
| } elsif($?) { |
| $why = "precheck command error"; |
| } |
| logmsg "prechecked $cmd\n" if($verbose); |
| } |
| } |
| } |
| |
| if($why && !$listonly) { |
| # there's a problem, count it as "skipped" |
| $skipped++; |
| $skipped{$why}++; |
| $teststat[$testnum]=$why; # store reason for this test case |
| |
| if(!$short) { |
| logmsg sprintf("test %03d SKIPPED: $why\n", $testnum); |
| } |
| |
| timestampskippedevents($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; |
| } |
| |
| # this is the valid protocol blurb curl should generate |
| my @protocol= fixarray ( getpart("verify", "protocol") ); |
| |
| # this is the valid protocol blurb curl should generate to a proxy |
| my @proxyprot = fixarray ( getpart("verify", "proxy") ); |
| |
| # 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) { |
| timestampskippedevents($testnum); |
| return 0; # look successful |
| } |
| |
| my @codepieces = getpart("client", "tool"); |
| |
| my $tool=""; |
| if(@codepieces) { |
| $tool = $codepieces[0]; |
| chomp $tool; |
| } |
| |
| # remove server output logfile |
| unlink($SERVERIN); |
| unlink($SERVER2IN); |
| unlink($PROXYIN); |
| |
| if(@ftpservercmd) { |
| # write the instructions to file |
| writearray($FTPDCMD, \@ftpservercmd); |
| } |
| |
| # get the command line options to use |
| my @blaha; |
| ($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 |
| subVariables \$cmd; |
| } |
| else { |
| # there was no command given, use something silly |
| $cmd="-"; |
| } |
| if($curl_debug) { |
| unlink($memdump); |
| } |
| |
| # create a (possibly-empty) file before starting the test |
| my @inputfile=getpart("client", "file"); |
| my %fileattr = getpartattr("client", "file"); |
| my $filename=$fileattr{'name'}; |
| if(@inputfile || $filename) { |
| if(!$filename) { |
| logmsg "ERROR: section client=>file has no name attribute\n"; |
| timestampskippedevents($testnum); |
| 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'}) || ($cmdhash{'option'} !~ /no-output/)) { |
| #We may slap on --output! |
| if (!@validstdout) { |
| $out=" --output $CURLOUT "; |
| } |
| } |
| |
| my $serverlogslocktimeout = $defserverlogslocktimeout; |
| if($cmdhash{'timeout'}) { |
| # test is allowed to override default server logs lock timeout |
| if($cmdhash{'timeout'} =~ /(\d+)/) { |
| $serverlogslocktimeout = $1 if($1 >= 0); |
| } |
| } |
| |
| 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); |
| } |
| } |
| |
| my $CMDLINE; |
| my $cmdargs; |
| my $cmdtype = $cmdhash{'type'} || "default"; |
| if($cmdtype eq "perl") { |
| # run the command line prepended with "perl" |
| $cmdargs ="$cmd"; |
| $CMDLINE = "perl "; |
| $tool=$CMDLINE; |
| $disablevalgrind=1; |
| } |
| elsif(!$tool) { |
| # run curl, add --verbose for debug information output |
| $cmd = "-1 ".$cmd if(exists $feature{"SSL"} && ($has_axtls)); |
| |
| my $inc=""; |
| if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-include/)) { |
| $inc = "--include "; |
| } |
| |
| $cmdargs ="$out $inc--trace-ascii log/trace$testnum --trace-time $cmd"; |
| } |
| else { |
| $cmdargs = " $cmd"; # $cmd is the command line for the test file |
| $CURLOUT = $STDOUT; # sends received data to stdout |
| |
| if($tool =~ /^lib/) { |
| $CMDLINE="$LIBDIR/$tool"; |
| } |
| elsif($tool =~ /^unit/) { |
| $CMDLINE="$UNITDIR/$tool"; |
| } |
| |
| if(! -f $CMDLINE) { |
| logmsg "The tool set in the test case for this: '$tool' does not exist\n"; |
| timestampskippedevents($testnum); |
| return -1; |
| } |
| $DBGCURL=$CMDLINE; |
| } |
| |
| my @stdintest = getpart("client", "stdin"); |
| |
| if(@stdintest) { |
| my $stdinfile="$LOGDIR/stdin-for-$testnum"; |
| writearray($stdinfile, \@stdintest); |
| |
| $cmdargs .= " <$stdinfile"; |
| } |
| |
| if(!$tool) { |
| $CMDLINE="$CURL"; |
| } |
| |
| my $usevalgrind; |
| if($valgrind && !$disablevalgrind) { |
| my @valgrindoption = getpart("verify", "valgrind"); |
| if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) { |
| $usevalgrind = 1; |
| my $valgrindcmd = "$valgrind "; |
| $valgrindcmd .= "$valgrind_tool " if($valgrind_tool); |
| $valgrindcmd .= "--leak-check=yes "; |
| $valgrindcmd .= "--num-callers=16 "; |
| $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; |
| $CMDLINE = "$valgrindcmd $CMDLINE"; |
| } |
| } |
| |
| $CMDLINE .= "$cmdargs >$STDOUT 2>$STDERR"; |
| |
| if($verbose) { |
| logmsg "$CMDLINE\n"; |
| } |
| |
| print CMDLOG "$CMDLINE\n"; |
| |
| 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: $@"; |
| stopservers($verbose); |
| timestampskippedevents($testnum); |
| return -1; |
| } |
| } |
| |
| if($gdbthis) { |
| my $gdbinit = "$TESTDIR/gdbinit$testnum"; |
| open(GDBCMD, ">$LOGDIR/gdbcmd"); |
| print GDBCMD "set args $cmdargs\n"; |
| print GDBCMD "show args\n"; |
| print GDBCMD "source $gdbinit\n" if -e $gdbinit; |
| close(GDBCMD); |
| } |
| |
| # timestamp starting of test command |
| $timetoolini{$testnum} = Time::HiRes::time() if($timestats); |
| |
| # run the command line we built |
| if ($torture) { |
| $cmdres = torture($CMDLINE, |
| "$gdb --directory libtest $DBGCURL -x $LOGDIR/gdbcmd"); |
| } |
| elsif($gdbthis) { |
| my $GDBW = ($gdbxwin) ? "-w" : ""; |
| runclient("$gdb --directory libtest $DBGCURL $GDBW -x $LOGDIR/gdbcmd"); |
| $cmdres=0; # makes it always continue after a debugged run |
| } |
| else { |
| $cmdres = runclient("$CMDLINE"); |
| my $signal_num = $cmdres & 127; |
| $dumped_core = $cmdres & 128; |
| |
| if(!$anyway && ($signal_num || $dumped_core)) { |
| $cmdres = |