| #!/usr/bin/env perl |
| #*************************************************************************** |
| # _ _ ____ _ |
| # Project ___| | | | _ \| | |
| # / __| | | | |_) | | |
| # | (__| |_| | _ <| |___ |
| # \___|\___/|_| \_\_____| |
| # |
| # Copyright (C) 1998 - 2020, Daniel Stenberg, <daniel@haxx.se>, et al. |
| # |
| # This software is licensed as described in the file COPYING, which |
| # you should have received as part of this distribution. The terms |
| # are also available at https://curl.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 { |
| push(@INC, $ENV{'srcdir'}) if(defined $ENV{'srcdir'}); |
| push(@INC, "."); |
| # run time statistics needs Time::HiRes |
| eval { |
| no warnings "all"; |
| require Time::HiRes; |
| import Time::HiRes qw( time ); |
| } |
| } |
| |
| use strict; |
| use warnings; |
| use Cwd; |
| use Digest::MD5 qw(md5); |
| |
| # Subs imported from serverhelp module |
| use serverhelp qw( |
| serverfactors |
| servername_id |
| servername_str |
| servername_canon |
| server_pidfilename |
| server_portfilename |
| 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 |
| ); |
| |
| use pathhelp; |
| |
| require "getpart.pm"; # array functions |
| require "valgrind.pm"; # valgrind report parser |
| require "ftp.pm"; |
| require "azure.pm"; |
| require "appveyor.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 $minport; # minimum used port number |
| my $maxport; # maximum used port number |
| |
| my $noport="[not running]"; |
| |
| my $NOLISTENPORT=47; # port number we use for a local non-listening service |
| my $MQTTPORT=$noport; # MQTT server port |
| my $HTTPPORT=$noport; # HTTP server port |
| my $HTTP6PORT=$noport; # HTTP IPv6 server port |
| my $HTTPSPORT=$noport; # HTTPS (stunnel) server port |
| my $FTPPORT=$noport; # FTP server port |
| my $FTP2PORT=$noport; # FTP server 2 port |
| my $FTPSPORT=$noport; # FTPS (stunnel) server port |
| my $FTP6PORT=$noport; # FTP IPv6 server port |
| my $TFTPPORT=$noport; # TFTP |
| my $TFTP6PORT=$noport; # TFTP |
| my $SSHPORT=$noport; # SCP/SFTP |
| my $SOCKSPORT=$noport; # SOCKS4/5 port |
| my $POP3PORT=$noport; # POP3 |
| my $POP36PORT=$noport; # POP3 IPv6 server port |
| my $IMAPPORT=$noport; # IMAP |
| my $IMAP6PORT=$noport; # IMAP IPv6 server port |
| my $SMTPPORT=$noport; # SMTP |
| my $SMTP6PORT=$noport; # SMTP IPv6 server port |
| my $RTSPPORT=$noport; # RTSP |
| my $RTSP6PORT=$noport; # RTSP IPv6 server port |
| my $GOPHERPORT=$noport; # Gopher |
| my $GOPHER6PORT=$noport; # Gopher IPv6 server port |
| my $HTTPTLSPORT=$noport; # HTTP TLS (non-stunnel) server port |
| my $HTTPTLS6PORT=$noport; # HTTP TLS (non-stunnel) IPv6 server port |
| my $HTTPPROXYPORT=$noport; # HTTP proxy port, when using CONNECT |
| my $HTTP2PORT=$noport; # HTTP/2 server port |
| my $DICTPORT=$noport; # DICT server port |
| my $SMBPORT=$noport; # SMB server port |
| my $SMBSPORT=$noport; # SMBS server port |
| my $NEGTELNETPORT=$noport; # TELNET server port with negotiation |
| my $HTTPUNIXPATH; # HTTP server Unix domain socket path |
| |
| my $SSHSRVMD5 = "[uninitialized]"; # MD5 of ssh server public key |
| |
| my $srcdir = $ENV{'srcdir'} || '.'; |
| my $CURL="../src/curl".exe_ext('TOOL'); # 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="commands.log"; # all command lines run |
| my $FTPDCMD="$LOGDIR/ftpserver.cmd"; # copy 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; # built debug enabled (--enable-debug) |
| my $has_memory_tracking=0; # built with memory tracking (--enable-curldebug) |
| my $libtool; |
| my $repeat = 0; |
| |
| # name of the file that the memory debugging creates: |
| my $memdump="$LOGDIR/memdump"; |
| |
| # the path to the script that analyzes the memory debug output file: |
| my $memanalyze="$perl $srcdir/memanalyze.pl"; |
| |
| my $pwd = getcwd(); # current working directory |
| my $posix_pwd = $pwd; |
| |
| my $start; |
| my $ftpchecktime=1; # time it took to verify our test FTP server |
| my $scrambleorder; |
| my $stunnel = checkcmd("stunnel4") || checkcmd("tstunnel") || checkcmd("stunnel"); |
| my $valgrind = checktestcmd("valgrind"); |
| my $valgrind_logfile="--logfile"; |
| my $valgrind_tool; |
| my $gdb = checktestcmd("gdb"); |
| my $httptlssrv = find_httptlssrv(); |
| |
| my $uname_release = `uname -r`; |
| my $is_wsl = $uname_release =~ /Microsoft$/; |
| |
| my $has_ssl; # set if libcurl is built with SSL support |
| my $has_largefile; # 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 $http_unix; # set if HTTP server has Unix sockets 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_unix; # set if libcurl is built with Unix sockets support |
| my $has_libz; # set if libcurl is built with libz support |
| my $has_brotli; # set if libcurl is built with brotli 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_sspi; # set if libcurl is built with Windows SSPI |
| my $has_gssapi; # set if libcurl is built with a GSS-API library |
| my $has_kerberos; # set if libcurl is built with Kerberos support |
| my $has_spnego; # set if libcurl is built with SPNEGO support |
| 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_metalink; # set if curl is built with Metalink support |
| my $has_http2; # set if libcurl is built with HTTP2 support |
| my $has_crypto; # set if libcurl is built with cryptographic support |
| my $has_cares; # set if built with c-ares |
| my $has_threadedres;# set if built with threaded resolver |
| my $has_psl; # set if libcurl is built with PSL support |
| my $has_altsvc; # set if libcurl is built with alt-svc support |
| my $has_ldpreload; # set if curl is built for systems supporting LD_PRELOAD |
| my $has_multissl; # set if curl is build with MultiSSL support |
| my $has_manual; # set if curl is built with built-in manual |
| my $has_win32; # set if curl is built for Windows |
| my $has_mingw; # set if curl is built with MinGW (as opposed to MinGW-w64) |
| |
| # this version is decided by the particular nghttp2 library that is being used |
| my $h2cver = "h2c"; |
| |
| 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_wolfssl; # built with wolfSSL |
| my $has_winssl; # built with WinSSL (Secure Channel aka Schannel) |
| my $has_darwinssl; # built with DarwinSSL (Secure Transport) |
| my $has_boringssl; # built with BoringSSL |
| my $has_libressl; # built with libressl |
| my $has_mbedtls; # built with mbedTLS |
| my $has_mesalink; # built with MesaLink |
| |
| my $has_sslpinning; # built with a TLS backend that supports pinning |
| |
| my $has_shared = "unknown"; # built shared |
| |
| my $resolver; # name of the resolver backend (for human presentation) |
| |
| 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 %ignored_keywords; # key words of tests to ignore results |
| my %enabled_keywords; # key words of tests to run |
| my %disabled; # disabled test cases |
| my %ignored; # ignored results of 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 = 2; # 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; |
| my %feature; # array of enabled features |
| my %keywords; # array of keywords from the test spec |
| |
| ####################################################################### |
| # variables that command line options may set |
| # |
| |
| my $short; |
| my $automakestyle; |
| 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_event_based; # run curl with --test-event to test the event API |
| |
| 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 %serverportfile;# all server port 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; |
| my $shallow; |
| my $randseed = 0; |
| |
| # Azure Pipelines specific variables |
| my $AZURE_RUN_ID = 0; |
| my $AZURE_RESULT_ID = 0; |
| |
| ####################################################################### |
| # logmsg is our general message logging subroutine. |
| # |
| sub logmsg { |
| for(@_) { |
| my $line = $_; |
| if ($is_wsl) { |
| # use \r\n for WSL shell |
| $line =~ s/\r?\n$/\r\n/g; |
| } |
| print "$line"; |
| } |
| } |
| |
| # 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{'CURL_ENTROPY'}="12345678"; |
| $ENV{'CURL_FORCETIME'}=1; # for debug NTLM magic |
| $ENV{'HOME'}=$pwd; |
| $ENV{'COLUMNS'}=79; # screen width! |
| |
| 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 and serverportfile hashes with file names for all |
| # possible servers. |
| # |
| sub init_serverpidfile_hash { |
| for my $proto (('ftp', 'http', 'imap', 'pop3', 'smtp', 'http/2')) { |
| for my $ssl (('', 's')) { |
| for my $ipvnum ((4, 6)) { |
| for my $idnum ((1, 2, 3)) { |
| my $serv = servername_id("$proto$ssl", $ipvnum, $idnum); |
| my $pidf = server_pidfilename("$proto$ssl", $ipvnum, $idnum); |
| $serverpidfile{$serv} = $pidf; |
| my $portf = server_portfilename("$proto$ssl", $ipvnum, $idnum); |
| $serverportfile{$serv} = $portf; |
| } |
| } |
| } |
| } |
| for my $proto (('tftp', 'sftp', 'socks', 'ssh', 'rtsp', 'gopher', 'httptls', |
| 'dict', 'smb', 'smbs', 'telnet', 'mqtt')) { |
| 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; |
| my $portf = server_portfilename($proto, $ipvnum, $idnum); |
| $serverportfile{$serv} = $portf; |
| } |
| } |
| } |
| for my $proto (('http', 'imap', 'pop3', 'smtp', 'http/2')) { |
| for my $ssl (('', 's')) { |
| my $serv = servername_id("$proto$ssl", "unix", 1); |
| my $pidf = server_pidfilename("$proto$ssl", "unix", 1); |
| $serverpidfile{$serv} = $pidf; |
| my $portf = server_portfilename("$proto$ssl", "unix", 1); |
| $serverportfile{$serv} = $portf; |
| } |
| } |
| } |
| |
| ####################################################################### |
| # 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 = pidwait($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 |
| portable_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) && pidexists($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)=@_; |
| my $ret = system($cmd); |
| print "CMD ($ret): $cmd\n" if($verbose && !$torture); |
| return $ret; |
| |
| # 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, $testnum, $gdbline) = @_; |
| |
| # 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(/^Operations: (\d+)/) { |
| $count = $1; |
| last; |
| } |
| } |
| if(!$count) { |
| logmsg " found no functions to make fail\n"; |
| return 0; |
| } |
| |
| my @ttests = (1 .. $count); |
| if($shallow && ($shallow < $count)) { |
| my $discard = scalar(@ttests) - $shallow; |
| my $percent = sprintf("%.2f%%", $shallow * 100 / scalar(@ttests));; |
| logmsg " $count functions found, but only fail $shallow ($percent)\n"; |
| while($discard) { |
| my $rm; |
| do { |
| # find a test to discard |
| $rm = rand(scalar(@ttests)); |
| } while(!$ttests[$rm]); |
| $ttests[$rm] = undef; |
| $discard--; |
| } |
| } |
| else { |
| logmsg " $count functions to make fail\n"; |
| } |
| |
| for (@ttests) { |
| my $limit = $_; |
| my $fail; |
| my $dumped_core; |
| |
| if(!defined($limit)) { |
| # --shallow can undefine them |
| next; |
| } |
| if($tortalloc && ($tortalloc != $limit)) { |
| next; |
| } |
| |
| if($verbose) { |
| my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = |
| localtime(time()); |
| my $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec); |
| logmsg "Fail function no: $limit at $now\r"; |
| } |
| |
| # make the memory allocation function number $limit return failure |
| $ENV{'CURL_MEMLIMIT'} = $limit; |
| |
| # remove memdump first to be sure we get a new nice and clean one |
| unlink($memdump); |
| |
| my $cmd = $testcmd; |
| if($valgrind && !$gdbthis) { |
| my @valgrindoption = getpart("verify", "valgrind"); |
| if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) { |
| my $valgrindcmd = "$valgrind "; |
| $valgrindcmd .= "$valgrind_tool " if($valgrind_tool); |
| $valgrindcmd .= "--quiet --leak-check=yes "; |
| $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp "; |
| # $valgrindcmd .= "--gen-suppressions=all "; |
| $valgrindcmd .= "--num-callers=16 "; |
| $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; |
| $cmd = "$valgrindcmd $testcmd"; |
| } |
| } |
| logmsg "*** Function number $limit is now set to fail ***\n" if($gdbthis); |
| |
| my $ret = 0; |
| if($gdbthis) { |
| runclient($gdbline); |
| } |
| else { |
| $ret = runclient($cmd); |
| } |
| #logmsg "$_ Returned " . ($ret >> 8) . "\n"; |
| |
| # Now clear the variable again |
| delete $ENV{'CURL_MEMLIMIT'} if($ENV{'CURL_MEMLIMIT'}); |
| |
| if(-r "core") { |
| # there's core file present now! |
| logmsg " core dumped\n"; |
| $dumped_core = 1; |
| $fail = 2; |
| } |
| |
| if($valgrind) { |
| my @e = valgrindparse("$LOGDIR/valgrind$testnum"); |
| if(@e && $e[0]) { |
| if($automakestyle) { |
| logmsg "FAIL: torture $testnum - valgrind\n"; |
| } |
| else { |
| logmsg " valgrind ERROR "; |
| logmsg @e; |
| } |
| $fail = 1; |
| } |
| } |
| |
| # verify that it returns a proper error code, doesn't leak memory |
| # and doesn't core dump |
| if(($ret & 255) || ($ret >> 8) >= 128) { |
| logmsg " system() returned $ret\n"; |
| $fail=1; |
| } |
| else { |
| my @memdata=`$memanalyze $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 function 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|-unix|))$/) { |
| # 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|-unix|))$/) { |
| # 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_or_path) = @_; |
| my $server = servername_id($proto, $ipvnum, $idnum); |
| my $pid = 0; |
| my $bonus=""; |
| # $port_or_path contains a path for Unix sockets, sws ignores the port |
| my $port = ($ipvnum eq "unix") ? 80 : $port_or_path; |
| |
| 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 .= "--unix-socket '$port_or_path' " if $ipvnum eq "unix"; |
| $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 "; |
| } |
| |
| 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(!pidexists($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|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(!pidexists($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(!pidexists($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. 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 verifysmb { |
| 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); |
| |
| my $flags = "--max-time $server_response_maxtime "; |
| $flags .= "--silent "; |
| $flags .= "--verbose "; |
| $flags .= "--globoff "; |
| $flags .= "-u 'curltest:curltest' "; |
| $flags .= $extra; |
| $flags .= "\"$proto://$ip:$port/SERVER/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 server as a measure |
| # on how fast/slow this host 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 verifytelnet { |
| 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); |
| |
| my $flags = "--max-time $server_response_maxtime "; |
| $flags .= "--silent "; |
| $flags .= "--verbose "; |
| $flags .= "--globoff "; |
| $flags .= "--upload-file - "; |
| $flags .= $extra; |
| $flags .= "\"$proto://$ip:$port\""; |
| |
| my $cmd = "echo 'verifiedserver' | $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 server as a measure |
| # on how fast/slow this host is. |
| my $took = int(0.5+time()-$time); |
| |
| if($verbose) { |
| logmsg "RUN: Verifying our test $server server took $took seconds\n"; |
| } |
| |
| 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, |
| 'dict' => \&verifyftp, |
| 'smb' => \&verifysmb, |
| 'telnet' => \&verifytelnet); |
| |
| 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 http2 server |
| # |
| sub runhttp2server { |
| my ($verbose, $port) = @_; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| my $proto="http/2"; |
| my $ipvnum = 4; |
| my $idnum = 0; |
| my $exe = "$perl $srcdir/http2-server.pl"; |
| my $verbose_flag = "--verbose "; |
| |
| $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 .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--port $HTTP2PORT "; |
| $flags .= "--connect $HOSTIP:$HTTPPORT "; |
| $flags .= $verbose_flag if($debugprotocol); |
| |
| my $cmd = "$exe $flags"; |
| my ($http2pid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($http2pid <= 0 || !pidexists($http2pid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $http2pid\n"; |
| } |
| |
| return ($http2pid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the http server |
| # |
| sub runhttpserver { |
| my ($proto, $verbose, $alt, $port_or_path) = @_; |
| my $ip = $HOSTIP; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| my $exe = "$perl $srcdir/httpserver.pl"; |
| my $verbose_flag = "--verbose "; |
| |
| 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; |
| } |
| elsif($alt eq "unix") { |
| # IP (protocol) is mutually exclusive with Unix sockets |
| $ipvnum = "unix"; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| my $portfile = $serverportfile{$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 .= "--gopher " if($proto eq "gopher"); |
| $flags .= "--connect $HOSTIP " if($alt eq "proxy"); |
| $flags .= $verbose_flag if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--portfile $portfile "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| if($ipvnum eq "unix") { |
| $flags .= "--unix-socket '$port_or_path' "; |
| } else { |
| $flags .= "--ipv$ipvnum --port 0 "; |
| } |
| $flags .= "--srcdir \"$srcdir\""; |
| |
| my $cmd = "$exe $flags"; |
| my ($httppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($httppid <= 0 || !pidexists($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); |
| } |
| |
| # where is it? |
| my $port; |
| if(!$port_or_path) { |
| $port = $port_or_path = pidfromfile($portfile); |
| } |
| |
| # Server is up. Verify that we can speak to it. |
| my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port_or_path); |
| 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 on PID $httppid port $port\n"; |
| } |
| |
| sleep(1); |
| |
| return ($httppid, $pid2, $port); |
| } |
| |
| ####################################################################### |
| # 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 || !pidexists($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 .= "--priority NORMAL:+SRP "; |
| $flags .= "--srppasswd $srcdir/certs/srp-verifier-db "; |
| $flags .= "--srppasswdconf $srcdir/certs/srp-verifier-conf"; |
| |
| my $cmd = "$httptlssrv $flags > $logfile 2>&1"; |
| my ($httptlspid, $pid2) = startnew($cmd, $pidfile, 10, 1); # fake pidfile |
| |
| if($httptlspid <= 0 || !pidexists($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 = ""; |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| my $portfile = $serverportfile{$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 .= "--portfile \"$portfile\" "; |
| $flags .= "--srcdir \"$srcdir\" --proto $proto "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port 0 --addr \"$ip\""; |
| |
| my $cmd = "$perl $srcdir/ftpserver.pl $flags"; |
| my ($ftppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($ftppid <= 0 || !pidexists($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); |
| } |
| |
| # where is it? |
| $port = pidfromfile($portfile); |
| |
| logmsg "PINGPONG runs on port $port ($portfile)\n" if($verbose); |
| |
| # 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; |
| |
| logmsg "RUN: $srvrname server is PID $ftppid port $port\n" if($verbose); |
| |
| # Assign the correct port variable! |
| if($proto eq "ftp") { |
| if($ipvnum == 6) { |
| # if IPv6, use a different setup |
| $FTP6PORT = $port; |
| } |
| elsif($idnum>1) { |
| $FTP2PORT = $port; |
| } |
| else { |
| $FTPPORT = $port; |
| } |
| } |
| elsif($proto eq "pop3") { |
| if($ipvnum == 6) { |
| $POP36PORT = $port; |
| } |
| else { |
| $POP3PORT = $port; |
| } |
| } |
| elsif($proto eq "imap") { |
| if($ipvnum == 6) { |
| $IMAP6PORT = $port; |
| } |
| else { |
| $IMAPPORT = $port; |
| } |
| } |
| elsif($proto eq "smtp") { |
| if($ipvnum == 6) { |
| $SMTP6PORT = $port; |
| } |
| else { |
| $SMTPPORT = $port; |
| } |
| } |
| else { |
| print STDERR "Unsupported protocol $proto!!\n"; |
| return 0; |
| } |
| |
| 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 || !pidexists($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 $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; |
| $ip = $HOST6IP; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| my $portfile = $serverportfile{$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\" ". |
| "--portfile \"$portfile\" ". |
| "--logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port 0 --srcdir \"$srcdir\""; |
| |
| my $cmd = "$perl $srcdir/tftpserver.pl $flags"; |
| my ($tftppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($tftppid <= 0 || !pidexists($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); |
| } |
| |
| my $port = pidfromfile($portfile); |
| |
| # 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 on PID $tftppid port $port\n"; |
| } |
| |
| sleep(1); |
| |
| return ($pid2, $tftppid, $port); |
| } |
| |
| |
| ####################################################################### |
| # start the rtsp server |
| # |
| sub runrtspserver { |
| my ($verbose, $ipv6) = @_; |
| 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; |
| $ip = $HOST6IP; |
| } |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| |
| $pidfile = $serverpidfile{$server}; |
| my $portfile = $serverportfile{$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\" ". |
| "--portfile \"$portfile\" ". |
| "--logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--ipv$ipvnum --port 0 --srcdir \"$srcdir\""; |
| |
| my $cmd = "$perl $srcdir/rtspserver.pl $flags"; |
| my ($rtsppid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($rtsppid <= 0 || !pidexists($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); |
| } |
| |
| my $port = pidfromfile($portfile); |
| |
| # 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 PID $rtsppid port $port\n"; |
| } |
| |
| sleep(1); |
| |
| return ($rtsppid, $pid2, $port); |
| } |
| |
| |
| ####################################################################### |
| # Start the ssh (scp/sftp) server |
| # |
| sub runsshserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $ip=$HOSTIP; |
| my $port = $SSHPORT; |
| 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 "; |
| $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 || !pidexists($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); |
| } |
| |
| my $hstpubmd5f = "curl_host_rsa_key.pub_md5"; |
| if(!open(PUBMD5FILE, "<", $hstpubmd5f) || |
| (read(PUBMD5FILE, $SSHSRVMD5, 32) != 32) || |
| !close(PUBMD5FILE) || |
| ($SSHSRVMD5 !~ /^[a-f0-9]{32}$/i)) |
| { |
| my $msg = "Fatal: $srvrname pubkey md5 missing : \"$hstpubmd5f\" : $!"; |
| logmsg "$msg\n"; |
| stopservers($verbose); |
| die $msg; |
| } |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $pid2\n"; |
| } |
| |
| return ($pid2, $sshpid); |
| } |
| |
| ####################################################################### |
| # Start the socks server |
| # |
| sub runmqttserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $ip=$HOSTIP; |
| my $port = $MQTTPORT; |
| my $proto = 'mqtt'; |
| my $ipvnum = 4; |
| my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $portfile; |
| my $logfile; |
| my $flags = ""; |
| |
| $server = servername_id($proto, $ipvnum, $idnum); |
| $pidfile = $serverpidfile{$server}; |
| $portfile = $serverportfile{$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); |
| |
| # start our MQTT server - on a random port! |
| my $cmd="server/mqttd".exe_ext('SRV'). |
| " --port 0 ". |
| " --pidfile $pidfile". |
| " --portfile $portfile". |
| " --config $FTPDCMD"; |
| my ($sockspid, $pid2) = startnew($cmd, $pidfile, 30, 0); |
| |
| if($sockspid <= 0 || !pidexists($sockspid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| $MQTTPORT = pidfromfile($portfile); |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $pid2 on PORT $MQTTPORT\n"; |
| } |
| |
| return ($pid2, $sockspid); |
| } |
| |
| ####################################################################### |
| # Start the socks server |
| # |
| sub runsocksserver { |
| my ($id, $verbose, $ipv6) = @_; |
| my $ip=$HOSTIP; |
| 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}; |
| my $portfile = $serverportfile{$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); |
| |
| # start our socks server, get commands from the FTP cmd file |
| my $cmd="server/socksd".exe_ext('SRV'). |
| " --port 0 ". |
| " --pidfile $pidfile". |
| " --portfile $portfile". |
| " --backend $HOSTIP". |
| " --config $FTPDCMD"; |
| my ($sockspid, $pid2) = startnew($cmd, $pidfile, 30, 0); |
| |
| if($sockspid <= 0 || !pidexists($sockspid)) { |
| # it is NOT alive |
| logmsg "RUN: failed to start the $srvrname server\n"; |
| stopserver($server, "$pid2"); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| |
| my $port = pidfromfile($portfile); |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $pid2\n"; |
| } |
| |
| return ($pid2, $sockspid, $port); |
| } |
| |
| ####################################################################### |
| # start the dict server |
| # |
| sub rundictserver { |
| my ($verbose, $alt, $port) = @_; |
| my $proto = "dict"; |
| my $ip = $HOSTIP; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($alt eq "ipv6") { |
| # No IPv6 |
| } |
| |
| $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 1 " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--port $port --srcdir \"$srcdir\" "; |
| $flags .= "--host $HOSTIP"; |
| |
| my $cmd = "$srcdir/dictserver.py $flags"; |
| my ($dictpid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($dictpid <= 0 || !pidexists($dictpid)) { |
| # 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, "$dictpid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $dictpid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($dictpid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the SMB server |
| # |
| sub runsmbserver { |
| my ($verbose, $alt, $port) = @_; |
| my $proto = "smb"; |
| my $ip = $HOSTIP; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($alt eq "ipv6") { |
| # No IPv6 |
| } |
| |
| $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 1 " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--port $port --srcdir \"$srcdir\" "; |
| $flags .= "--host $HOSTIP"; |
| |
| my $cmd = "$srcdir/smbserver.py $flags"; |
| my ($smbpid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($smbpid <= 0 || !pidexists($smbpid)) { |
| # 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, "$smbpid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $smbpid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($smbpid, $pid2); |
| } |
| |
| ####################################################################### |
| # start the telnet server |
| # |
| sub runnegtelnetserver { |
| my ($verbose, $alt, $port) = @_; |
| my $proto = "telnet"; |
| my $ip = $HOSTIP; |
| my $ipvnum = 4; |
| my $idnum = 1; |
| my $server; |
| my $srvrname; |
| my $pidfile; |
| my $logfile; |
| my $flags = ""; |
| |
| if($alt eq "ipv6") { |
| # No IPv6 |
| } |
| |
| $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 1 " if($debugprotocol); |
| $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; |
| $flags .= "--id $idnum " if($idnum > 1); |
| $flags .= "--port $port --srcdir \"$srcdir\""; |
| |
| my $cmd = "$srcdir/negtelnetserver.py $flags"; |
| my ($ntelpid, $pid2) = startnew($cmd, $pidfile, 15, 0); |
| |
| if($ntelpid <= 0 || !pidexists($ntelpid)) { |
| # 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, "$ntelpid $pid2"); |
| displaylogs($testnumcheck); |
| $doesntrun{$pidfile} = 1; |
| return (0,0); |
| } |
| $pid2 = $pid3; |
| |
| if($verbose) { |
| logmsg "RUN: $srvrname server is now running PID $ntelpid\n"; |
| } |
| |
| sleep(1); |
| |
| return ($ntelpid, $pid2); |
| } |
| |
| |
| ####################################################################### |
| # 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_or_path) = @_; |
| 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; |
| } |
| elsif($alt eq "unix") { |
| # IP (protocol) is mutually exclusive with Unix sockets |
| $ipvnum = "unix"; |
| } |
| |
| return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port_or_path); |
| } |
| |
| ####################################################################### |
| # 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; |
| } |
| |
| ####################################################################### |
| # compare test results with the expected output, we might filter off |
| # some pattern that is allowed to differ, output test results |
| # |
| sub compare { |
| my ($testnum, $testname, $subject, $firstref, $secondref)=@_; |
| |
| my $result = compareparts($firstref, $secondref); |
| |
| if($result) { |
| # timestamp test result verification end |
| $timevrfyend{$testnum} = Time::HiRes::time(); |
| |
| if(!$short) { |
| logmsg "\n $testnum: $subject FAILED:\n"; |
| logmsg showdiff($LOGDIR, $firstref, $secondref); |
| } |
| elsif(!$automakestyle) { |
| logmsg "FAILED\n"; |
| } |
| else { |
| # automakestyle |
| logmsg "FAIL: $testnum - $testname - $subject\n"; |
| } |
| } |
| return $result; |
| } |
| |
| sub setupfeatures { |
| $feature{"SSL"} = $has_ssl; |
| $feature{"MultiSSL"} = $has_multissl; |
| $feature{"SSLpinning"} = $has_sslpinning; |
| $feature{"OpenSSL"} = $has_openssl; |
| $feature{"GnuTLS"} = $has_gnutls; |
| $feature{"NSS"} = $has_nss; |
| $feature{"WinSSL"} = $has_winssl; |
| $feature{"Schannel"} = $has_winssl; # alias |
| $feature{"sectransp"} = $has_darwinssl; |
| $feature{"DarwinSSL"} = $has_darwinssl; # alias |
| $feature{"ld_preload"} = ($has_ldpreload && !$debug_build); |
| $feature{"unittest"} = $debug_build; |
| $feature{"debug"} = $debug_build; |
| $feature{"TrackMemory"} = $has_memory_tracking; |
| $feature{"large_file"} = $has_largefile; |
| $feature{"idn"} = $has_idn; |
| $feature{"ipv6"} = $has_ipv6; |
| $feature{"libz"} = $has_libz; |
| $feature{"brotli"} = $has_brotli; |
| $feature{"NTLM"} = $has_ntlm; |
| $feature{"NTLM_WB"} = $has_ntlm_wb; |
| $feature{"SSPI"} = $has_sspi; |
| $feature{"GSS-API"} = $has_gssapi; |
| $feature{"Kerberos"} = $has_kerberos; |
| $feature{"SPNEGO"} = $has_spnego; |
| $feature{"getrlimit"} = $has_getrlimit; |
| $feature{"crypto"} = $has_crypto; |
| $feature{"TLS-SRP"} = $has_tls_srp; |
| $feature{"Metalink"} = $has_metalink; |
| $feature{"http/2"} = $has_http2; |
| $feature{"threaded-resolver"} = $has_threadedres; |
| $feature{"PSL"} = $has_psl; |
| $feature{"alt-svc"} = $has_altsvc; |
| $feature{"manual"} = $has_manual; |
| $feature{"unix-sockets"} = $has_unix; |
| $feature{"win32"} = $has_win32; |
| $feature{"MinGW"} = $has_mingw; |
| |
| # make each protocol an enabled "feature" |
| for my $p (@protocols) { |
| $feature{$p} = 1; |
| } |
| # 'socks' was once here but is now removed |
| |
| # |
| # strings that must match the names used in server/disabled.c |
| # |
| $feature{"cookies"} = 1; |
| $feature{"DoH"} = 1; |
| $feature{"HTTP-auth"} = 1; |
| $feature{"Mime"} = 1; |
| $feature{"netrc"} = 1; |
| $feature{"parsedate"} = 1; |
| $feature{"proxy"} = 1; |
| $feature{"shuffle-dns"} = 1; |
| $feature{"typecheck"} = 1; |
| $feature{"verbose-strings"} = 1; |
| |
| } |
| |
| ####################################################################### |
| # 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 @disabled; |
| my $dis = ""; |
| |
| 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); |
| |
| open(DISABLED, "server/disabled".exe_ext('TOOL')."|"); |
| @disabled = <DISABLED>; |
| close(DISABLED); |
| |
| if($disabled[0]) { |
| map s/[\r\n]//g, @disabled; |
| $dis = join(", ", @disabled); |
| } |
| |
| $resolver="stock"; |
| for(@version) { |
| chomp; |
| |
| if($_ =~ /^curl/) { |
| $curl = $_; |
| $curl =~ s/^(.*)(libcurl.*)/$1/g; |
| |
| $libcurl = $2; |
| if($curl =~ /linux|bsd|solaris/) { |
| $has_ldpreload = 1; |
| } |
| if($curl =~ /win32|Windows|mingw(32|64)/) { |
| # This is a Windows MinGW build or native build, we need to use |
| # Win32-style path. |
| $pwd = pathhelp::sys_native_current_path(); |
| $has_textaware = 1; |
| $has_win32 = 1; |
| $has_mingw = 1 if ($curl =~ /-pc-mingw32/); |
| } |
| if ($libcurl =~ /(winssl|schannel)/i) { |
| $has_winssl=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /openssl/i) { |
| $has_openssl=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /gnutls/i) { |
| $has_gnutls=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /nss/i) { |
| $has_nss=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /wolfssl/i) { |
| $has_wolfssl=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /securetransport/i) { |
| $has_darwinssl=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /BoringSSL/i) { |
| $has_boringssl=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /libressl/i) { |
| $has_libressl=1; |
| $has_sslpinning=1; |
| } |
| elsif ($libcurl =~ /mbedTLS/i) { |
| $has_mbedtls=1; |
| $has_sslpinning=1; |
| } |
| if ($libcurl =~ /ares/i) { |
| $has_cares=1; |
| $resolver="c-ares"; |
| } |
| if ($libcurl =~ /mesalink/i) { |
| $has_mesalink=1; |
| } |
| } |
| 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 and a "proto-unix" to match the variant which |
| # uses Unix domain sockets. This works even if support isn't |
| # compiled in because the <features> test will fail. |
| push @protocols, map(("$_-ipv6", "$_-unix"), @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) { |
| # built with memory tracking support (--enable-curldebug) |
| $has_memory_tracking = 1; |
| } |
| if($feat =~ /debug/i) { |
| # curl was built with --enable-debug |
| $debug_build = 1; |
| } |
| if($feat =~ /SSL/i) { |
| # ssl enabled |
| $has_ssl=1; |
| } |
| if($feat =~ /MultiSSL/i) { |
| # multiple ssl backends available. |
| $has_multissl=1; |
| } |
| if($feat =~ /Largefile/i) { |
| # large file support |
| $has_largefile=1; |
| } |
| if($feat =~ /IDN/i) { |
| # IDN support |
| $has_idn=1; |
| } |
| if($feat =~ /IPv6/i) { |
| $has_ipv6 = 1; |
| } |
| if($feat =~ /UnixSockets/i) { |
| $has_unix = 1; |
| } |
| if($feat =~ /libz/i) { |
| $has_libz = 1; |
| } |
| if($feat =~ /brotli/i) { |
| $has_brotli = 1; |
| } |
| if($feat =~ /NTLM/i) { |
| # NTLM enabled |
| $has_ntlm=1; |
| |
| # Use this as a proxy for any cryptographic authentication |
| $has_crypto=1; |
| } |
| if($feat =~ /NTLM_WB/i) { |
| # NTLM delegation to winbind daemon ntlm_auth helper enabled |
| $has_ntlm_wb=1; |
| } |
| if($feat =~ /SSPI/i) { |
| # SSPI enabled |
| $has_sspi=1; |
| } |
| if($feat =~ /GSS-API/i) { |
| # GSS-API enabled |
| $has_gssapi=1; |
| } |
| if($feat =~ /Kerberos/i) { |
| # Kerberos enabled |
| $has_kerberos=1; |
| |
| # Use this as a proxy for any cryptographic authentication |
| $has_crypto=1; |
| } |
| if($feat =~ /SPNEGO/i) { |
| # SPNEGO enabled |
| $has_spnego=1; |
| |
| # Use this as a proxy for any cryptographic authentication |
| $has_crypto=1; |
| } |
| if($feat =~ /CharConv/i) { |
| # CharConv enabled |
| $has_charconv=1; |
| } |
| if($feat =~ /TLS-SRP/i) { |
| # TLS-SRP enabled |
| $has_tls_srp=1; |
| } |
| if($feat =~ /Metalink/i) { |
| # Metalink enabled |
| $has_metalink=1; |
| } |
| if($feat =~ /PSL/i) { |
| # PSL enabled |
| $has_psl=1; |
| } |
| if($feat =~ /alt-svc/i) { |
| # alt-svc enabled |
| $has_altsvc=1; |
| } |
| if($feat =~ /AsynchDNS/i) { |
| if(!$has_cares) { |
| # this means threaded resolver |
| $has_threadedres=1; |
| $resolver="threaded"; |
| } |
| } |
| if($feat =~ /HTTP2/) { |
| # http2 enabled |
| $has_http2=1; |
| |
| push @protocols, 'http/2'; |
| } |
| } |
| # |
| # 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 $cmd = "server/sws".exe_ext('SRV')." --version"; |
| my @sws = `$cmd`; |
| if($sws[0] =~ /IPv6/) { |
| # HTTP server has IPv6 support! |
| $http_ipv6 = 1; |
| $gopher_ipv6 = 1; |
| } |
| |
| # check if the FTP server has it! |
| $cmd = "server/sockfilt".exe_ext('SRV')." --version"; |
| @sws = `$cmd`; |
| if($sws[0] =~ /IPv6/) { |
| # FTP server has IPv6 support! |
| $ftp_ipv6 = 1; |
| } |
| } |
| |
| if($has_unix) { |
| # client has Unix sockets support, check whether the HTTP server has it |
| my $cmd = "server/sws".exe_ext('SRV')." --version"; |
| my @sws = `$cmd`; |
| $http_unix = 1 if($sws[0] =~ /unix/); |
| } |
| |
| if(!$has_memory_tracking && $torture) { |
| die "can't run torture tests since curl was built without ". |
| "TrackMemory feature (--enable-curldebug)"; |
| } |
| |
| open(M, "$CURL -M 2>&1|"); |
| while(my $s = <M>) { |
| if($s =~ /built-in manual was disabled at build-time/) { |
| $has_manual = 0; |
| last; |
| } |
| $has_manual = 1; |
| last; |
| } |
| close(M); |
| |
| $has_shared = `sh $CURLCONFIG --built-shared`; |
| chomp $has_shared; |
| |
| my $hostname=join(' ', runclientoutput("hostname")); |
| my $hosttype=join(' ', runclientoutput("uname -a")); |
| my $hostos=$^O; |
| |
| logmsg ("********* System characteristics ******** \n", |
| "* $curl\n", |
| "* $libcurl\n", |
| "* Features: $feat\n", |
| "* Disabled: $dis\n", |
| "* Host: $hostname", |
| "* System: $hosttype", |
| "* OS: $hostos\n"); |
| |
| if($has_memory_tracking && $has_threadedres) { |
| $has_memory_tracking = 0; |
| logmsg("*\n", |
| "*** DISABLES memory tracking when using threaded resolver\n", |
| "*\n"); |
| } |
| |
| logmsg sprintf("* Servers: %s", $stunnel?"SSL ":""); |
| logmsg sprintf("%s", $http_ipv6?"HTTP-IPv6 ":""); |
| logmsg sprintf("%s", $http_unix?"HTTP-unix ":""); |
| logmsg sprintf("%s\n", $ftp_ipv6?"FTP-IPv6 ":""); |
| |
| logmsg sprintf("* Env: %s%s", $valgrind?"Valgrind ":"", |
| $run_event_based?"event-based ":""); |
| logmsg sprintf("%s\n", $libtool?"Libtool ":""); |
| logmsg ("* Seed: $randseed\n"); |
| logmsg ("* Port range: $minport-$maxport\n"); |
| |
| if($verbose) { |
| logmsg "* Ports: "; |
| if($stunnel) { |
| logmsg sprintf("FTPS/%d ", $FTPSPORT); |
| logmsg sprintf("HTTPS/%d ", $HTTPSPORT); |
| } |
| logmsg sprintf("\n* SSH/%d ", $SSHPORT); |
| if($httptlssrv) { |
| logmsg sprintf("HTTPTLS/%d ", $HTTPTLSPORT); |
| if($has_ipv6) { |
| logmsg sprintf("HTTPTLS-IPv6/%d ", $HTTPTLS6PORT); |
| } |
| logmsg "\n"; |
| } |
| |
| if($has_unix) { |
| logmsg "* Unix socket paths:\n"; |
| if($http_unix) { |
| logmsg sprintf("* HTTP-Unix:%s\n", $HTTPUNIXPATH); |
| } |
| } |
| } |
| |
| logmsg "***************************************** \n"; |
| |
| setupfeatures(); |
| # toggle off the features that were disabled in the build |
| for my $d(@disabled) { |
| $feature{$d} = 0; |
| } |
| } |
| |
| ####################################################################### |
| # substitute the variable stuff into either a joined up file or |
| # a command, in either case passed by reference |
| # |
| sub subVariables { |
| my ($thing, $prefix) = @_; |
| |
| if(!$prefix) { |
| $prefix = "%"; |
| } |
| |
| # test server ports |
| $$thing =~ s/${prefix}FTP6PORT/$FTP6PORT/g; |
| $$thing =~ s/${prefix}FTP2PORT/$FTP2PORT/g; |
| $$thing =~ s/${prefix}FTPSPORT/$FTPSPORT/g; |
| $$thing =~ s/${prefix}FTPPORT/$FTPPORT/g; |
| $$thing =~ s/${prefix}GOPHER6PORT/$GOPHER6PORT/g; |
| $$thing =~ s/${prefix}GOPHERPORT/$GOPHERPORT/g; |
| $$thing =~ s/${prefix}HTTPTLS6PORT/$HTTPTLS6PORT/g; |
| $$thing =~ s/${prefix}HTTPTLSPORT/$HTTPTLSPORT/g; |
| $$thing =~ s/${prefix}HTTP6PORT/$HTTP6PORT/g; |
| $$thing =~ s/${prefix}HTTPSPORT/$HTTPSPORT/g; |
| $$thing =~ s/${prefix}HTTP2PORT/$HTTP2PORT/g; |
| $$thing =~ s/${prefix}HTTPPORT/$HTTPPORT/g; |
| $$thing =~ s/${prefix}PROXYPORT/$HTTPPROXYPORT/g; |
| $$thing =~ s/${prefix}MQTTPORT/$MQTTPORT/g; |
| $$thing =~ s/${prefix}IMAP6PORT/$IMAP6PORT/g; |
| $$thing =~ s/${prefix}IMAPPORT/$IMAPPORT/g; |
| $$thing =~ s/${prefix}POP36PORT/$POP36PORT/g; |
| $$thing =~ s/${prefix}POP3PORT/$POP3PORT/g; |
| $$thing =~ s/${prefix}RTSP6PORT/$RTSP6PORT/g; |
| $$thing =~ s/${prefix}RTSPPORT/$RTSPPORT/g; |
| $$thing =~ s/${prefix}SMTP6PORT/$SMTP6PORT/g; |
| $$thing =~ s/${prefix}SMTPPORT/$SMTPPORT/g; |
| $$thing =~ s/${prefix}SOCKSPORT/$SOCKSPORT/g; |
| $$thing =~ s/${prefix}SSHPORT/$SSHPORT/g; |
| $$thing =~ s/${prefix}TFTP6PORT/$TFTP6PORT/g; |
| $$thing =~ s/${prefix}TFTPPORT/$TFTPPORT/g; |
| $$thing =~ s/${prefix}DICTPORT/$DICTPORT/g; |
| $$thing =~ s/${prefix}SMBPORT/$SMBPORT/g; |
| $$thing =~ s/${prefix}SMBSPORT/$SMBSPORT/g; |
| $$thing =~ s/${prefix}NEGTELNETPORT/$NEGTELNETPORT/g; |
| $$thing =~ s/${prefix}NOLISTENPORT/$NOLISTENPORT/g; |
| |
| # server Unix domain socket paths |
| $$thing =~ s/${prefix}HTTPUNIXPATH/$HTTPUNIXPATH/g; |
| |
| # client IP addresses |
| $$thing =~ s/${prefix}CLIENT6IP/$CLIENT6IP/g; |
| $$thing =~ s/${prefix}CLIENTIP/$CLIENTIP/g; |
| |
| # server IP addresses |
| $$thing =~ s/${prefix}HOST6IP/$HOST6IP/g; |
| $$thing =~ s/${prefix}HOSTIP/$HOSTIP/g; |
| |
| # misc |
| $$thing =~ s/${prefix}CURL/$CURL/g; |
| $$thing =~ s/${prefix}PWD/$pwd/g; |
| $$thing =~ s/${prefix}POSIX_PWD/$posix_pwd/g; |
| |
| my $file_pwd = $pwd; |
| if($file_pwd !~ /^\//) { |
| $file_pwd = "/$file_pwd"; |
| } |
| |
| $$thing =~ s/${prefix}FILE_PWD/$file_pwd/g; |
| $$thing =~ s/${prefix}SRCDIR/$srcdir/g; |
| $$thing =~ s/${prefix}USER/$USER/g; |
| |
| $$thing =~ s/${prefix}SSHSRVMD5/$SSHSRVMD5/g; |
| |
| # The purpose of FTPTIME2 and FTPTIME3 is to provide times that can be |
| # used for time-out tests and that would 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/${prefix}FTPTIME2/$ftp2/g; |
| $$thing =~ s/${prefix}FTPTIME3/$ftp3/g; |
| |
| # HTTP2 |
| $$thing =~ s/${prefix}H2CVER/$h2cver/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 ($evbased, # 1 means switch on if possible (and "curl" is tested) |
| # returns "not a test" if it can't be used for this test |
| $testnum, |
| $count, |
| $total)=@_; |
| |
| my @what; |
| my $why; |
| my $cmd; |
| my $disablevalgrind; |
| my $errorreturncode = 1; # 1 means normal error, 2 means ignored error |
| |
| # fist, remove all lingering log files |
| cleardir($LOGDIR); |
| |
| # 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($disttests !~ /test$testnum\W/ ) { |
| logmsg "Warning: test$testnum not present in tests/data/Makefile.inc\n"; |
| } |
| if($disabled{$testnum}) { |
| logmsg "Warning: test$testnum is explicitly disabled\n"; |
| } |
| if($ignored{$testnum}) { |
| logmsg "Warning: test$testnum result is ignored\n"; |
| $errorreturncode = 2; |
| } |
| |
| # 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"); |
| } |
| |
| # We require a feature to be present |
| for(@what) { |
| my $f = $_; |
| $f =~ s/\s//g; |
| |
| if($f =~ /^([^!].*)$/) { |
| if($feature{$1}) { |
| next; |
| } |
| |
| $why = "curl lacks $1 support"; |
| last; |
| } |
| } |
| |
| # We require a feature to not be present |
| if(!$why) { |
| for(@what) { |
| my $f = $_; |
| $f =~ s/\s//g; |
| |
| if($f =~ /^!(.*)$/) { |
| if(!$feature{$1}) { |
| next; |
| } |
| } |
| else { |
| next; |
| } |
| |
| $why = "curl has $1 support"; |
| last; |
| } |
| } |
| |
| if(!$why) { |
| my @info_keywords = getpart("info", "keywords"); |
| my $match; |
| my $k; |
| |
| # Clear the list of keywords from the last test |
| %keywords = (); |
| |
| if(!$info_keywords[0]) { |
| $why = "missing the <keywords> section!"; |
| } |
| |
| for $k (@info_keywords) { |
| chomp $k; |
| if ($disabled_keywords{lc($k)}) { |
| $why = "disabled by keyword"; |
| } elsif ($enabled_keywords{lc($k)}) { |
| $match = 1; |
| } |
| if ($ignored_keywords{lc($k)}) { |
| logmsg "Warning: test$testnum result is ignored due to $k\n"; |
| $errorreturncode = 2; |
| } |
| |
| $keywords{$k} = 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}; |
| } |
| |
| # get the name of the test early |
| my @testname= getpart("client", "name"); |
| my $testname = $testname[0]; |
| $testname =~ s/\n//g; |
| |
| # create test result in CI services |
| if(azure_check_environment() && $AZURE_RUN_ID) { |
| $AZURE_RESULT_ID = azure_create_test_result($AZURE_RUN_ID, $testnum, $testname); |
| } |
| elsif(appveyor_check_environment()) { |
| appveyor_create_test_result($testnum, $testname); |
| } |
| |
| # 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(!$why) { |
| $why = serverfortest($testnum); |
| } |
| |
| # Save a preprocessed version of the entire test file. This allows more |
| # "basic" test case readers to enjoy variable replacements. |
| my @entiretest = fulltest(); |
| my $otest = "log/test$testnum"; |
| open(D, ">$otest"); |
| my $diff; |
| for my $s (@entiretest) { |
| my $f = $s; |
| subVariables(\$s, "%"); |
| if($f ne $s) { |
| $diff++; |
| } |
| print D $s; |
| } |
| close(D); |
| # remove the separate test file again if nothing was updated to keep |
| # things simpler |
| unlink($otest) if(!$diff); |
| |
| # timestamp required servers verification end |
| $timesrvrend{$testnum} = Time::HiRes::time(); |
| |
| 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('TOOL') && (exe_ext('TOOL') 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"; |
| print "setenv $var = $content\n" if($verbose); |
| } |
| } |
| } |
| } |
| |
| if(!$why) { |
| 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) { |
| if($skipped{$why} <= 3) { |
| # show only the first three skips for each reason |
| logmsg sprintf("test %04d SKIPPED: $why\n", $testnum); |
| } |
| } |
| |
| timestampskippedevents($testnum); |
| return -1; |
| } |
| logmsg sprintf("test %04d...", $testnum) if(!$automakestyle); |
| |
| my %replyattr = getpartattr("reply", "data"); |
| my @reply; |
| if (partexists("reply", "datacheck")) { |
| for my $partsuffix (('', '1', '2', '3', '4')) { |
| my @replycheckpart = getpart("reply", "datacheck".$partsuffix); |
| if(@replycheckpart) { |
| my %replycheckpartattr = getpartattr("reply", "datacheck".$partsuffix); |
| # get the mode attribute |
| my $filemode=$replycheckpartattr{'mode'}; |
| if($filemode && ($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows: fix line endings |
| map s/\r\n/\n/g, @replycheckpart; |
| map s/\n/\r\n/g, @replycheckpart; |
| } |
| if($replycheckpartattr{'nonewline'}) { |
| # Yes, we must cut off the final newline from the final line |
| # of the datacheck |
| chomp($replycheckpart[$#replycheckpart]); |
| } |
| push(@reply, @replycheckpart); |
| } |
| } |
| } |
| else { |
| # check against the data section |
| @reply = getpart("reply", "data"); |
| # get the mode attribute |
| my $filemode=$replyattr{'mode'}; |
| if($filemode && ($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows: fix line endings |
| map s/\r\n/\n/g, @reply; |
| map s/\n/\r\n/g, @reply; |
| } |
| } |
| for my $r (@reply) { |
| subVariables(\$r); |
| } |
| |
| # 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") ); |
| my @validstderr = fixarray ( getpart("verify", "stderr") ); |
| |
| # if this section exists, we verify upload |
| my @upload = getpart("verify", "upload"); |
| if(@upload) { |
| my %hash = getpartattr("verify", "upload"); |
| if($hash{'nonewline'}) { |
| # cut off the final newline from the final line of the upload data |
| chomp($upload[$#upload]); |
| } |
| } |
| |
| # if this section exists, it might be FTP server instructions: |
| my @ftpservercmd = fixarray ( getpart("reply", "servercmd") ); |
| |
| my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout |
| |
| # name of the test |
| logmsg "[$testname]\n" if(!$short); |
| |
| if($listonly) { |
| timestampskippedevents($testnum); |
| return 0; # look successful |
| } |
| |
| my @codepieces = getpart("client", "tool"); |
| |
| my $tool=""; |
| if(@codepieces) { |
| $tool = $codepieces[0]; |
| chomp $tool; |
| $tool .= exe_ext('TOOL'); |
| } |
| |
| # remove server output logfile |
| unlink($SERVERIN); |
| unlink($SERVER2IN); |
| unlink($PROXYIN); |
| |
| push @ftpservercmd, "Testnum $testnum\n"; |
| # 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($has_memory_tracking) { |
| unlink($memdump); |
| } |
| |
| # create (possibly-empty) files before starting the test |
| for my $partsuffix (('', '1', '2', '3', '4')) { |
| my @inputfile=getpart("client", "file".$partsuffix); |
| my %fileattr = getpartattr("client", "file".$partsuffix); |
| my $filename=$fileattr{'name'}; |
| if(@inputfile || $filename) { |
| if(!$filename) { |
| logmsg "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 || |
| ($cmdhash{'option'} && $cmdhash{'option'} =~ /force-output/)) { |
| $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"; |
| my $fail_due_event_based = $evbased; |
| if($cmdtype eq "perl") { |
| # run the command line prepended with "perl" |
| $cmdargs ="$cmd"; |
| $CMDLINE = "$perl "; |
| $tool=$CMDLINE; |
| $disablevalgrind=1; |
| } |
| elsif($cmdtype eq "shell") { |
| # run the command line prepended with "/bin/sh" |
| $cmdargs ="$cmd"; |
| $CMDLINE = "/bin/sh "; |
| $tool=$CMDLINE; |
| $disablevalgrind=1; |
| } |
| elsif(!$tool && !$keywords{"unittest"}) { |
| # run curl, add suitable command line options |
| my $inc=""; |
| if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-include/)) { |
| $inc = " --include"; |
| } |
| $cmdargs = "$out$inc "; |
| |
| if($cmdhash{'option'} && ($cmdhash{'option'} =~ /binary-trace/)) { |
| $cmdargs .= "--trace log/trace$testnum "; |
| } |
| else { |
| $cmdargs .= "--trace-ascii log/trace$testnum "; |
| } |
| $cmdargs .= "--trace-time "; |
| if($evbased) { |
| $cmdargs .= "--test-event "; |
| $fail_due_event_based--; |
| } |
| $cmdargs .= $cmd; |
| } |
| else { |
| $cmdargs = " $cmd"; # $cmd is the command line for the test file |
| $CURLOUT = $STDOUT; # sends received data to stdout |
| |
| # Default the tool to a unit test with the same name as the test spec |
| if($keywords{"unittest"} && !$tool) { |
| $tool="unit$testnum"; |
| } |
| |
| if($tool =~ /^lib/) { |
| $CMDLINE="$LIBDIR/$tool"; |
| } |
| elsif($tool =~ /^unit/) { |
| $CMDLINE="$UNITDIR/$tool"; |
| } |
| |
| if(! -f $CMDLINE) { |
| logmsg "The tool set in the test case for this: '$tool' does not exist\n"; |
| timestampskippedevents($testnum); |
| return -1; |
| } |
| $DBGCURL=$CMDLINE; |
| } |
| |
| if($gdbthis) { |
| # gdb is incompatible with valgrind, so disable it when debugging |
| # Perhaps a better approach would be to run it under valgrind anyway |
| # with --db-attach=yes or --vgdb=yes. |
| $disablevalgrind=1; |
| } |
| |
| if($fail_due_event_based) { |
| logmsg "This test cannot run event based\n"; |
| return -1; |
| } |
| |
| my @stdintest = getpart("client", "stdin"); |
| |
| if(@stdintest) { |
| my $stdinfile="$LOGDIR/stdin-for-$testnum"; |
| |
| my %hash = getpartattr("client", "stdin"); |
| if($hash{'nonewline'}) { |
| # cut off the final newline from the final line of the stdin data |
| chomp($stdintest[$#stdintest]); |
| } |
| |
| 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 .= "--quiet --leak-check=yes "; |
| $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp "; |
| # $valgrindcmd .= "--gen-suppressions=all "; |
| $valgrindcmd .= "--num-callers=16 "; |
| $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; |
| $CMDLINE = "$valgrindcmd $CMDLINE"; |
| } |
| } |
| |
| $CMDLINE .= "$cmdargs >$STDOUT 2>$STDERR"; |
| |
| if($verbose) { |
| logmsg "$CMDLINE\n"; |
| } |
| |
| open(CMDLOG, ">", "$LOGDIR/$CURLLOG"); |
| print CMDLOG "$CMDLINE\n"; |
| close(CMDLOG); |
| |
| unlink("core"); |
| |
| my $dumped_core; |
| my $cmdres; |
| |
| 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(); |
| |
| # run the command line we built |
| if ($torture) { |
| $cmdres = torture($CMDLINE, |
| $testnum, |
| "$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 = 1000; |
| } |
| else { |
| $cmdres >>= 8; |
| $cmdres = (2000 + $signal_num) if($signal_num && !$cmdres); |
| } |
| } |
| |
| # timestamp finishing of test command |
| $timetoolend{$testnum} = Time::HiRes::time(); |
| |
| if(!$dumped_core) { |
| if(-r "core") { |
| # there's core file present now! |
| $dumped_core = 1; |
| } |
| } |
| |
| if($dumped_core) { |
| logmsg "core dumped\n"; |
| if(0 && $gdb) { |
| logmsg "running gdb for post-mortem analysis:\n"; |
| open(GDBCMD, ">$LOGDIR/gdbcmd2"); |
| print GDBCMD "bt\n"; |
| close(GDBCMD); |
| runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch $DBGCURL core "); |
| # unlink("$LOGDIR/gdbcmd2"); |
| } |
| } |
| |
| # If a server logs advisor read lock file exists, it is an indication |
| # that the server has not yet finished writing out all its log files, |
| # including server request log files used for protocol verification. |
| # So, if the lock file exists the script waits here a certain amount |
| # of time until the server removes it, or the given time expires. |
| |
| if($serverlogslocktimeout) { |
| my $lockretry = $serverlogslocktimeout * 20; |
| while((-f $SERVERLOGS_LOCK) && $lockretry--) { |
| portable_sleep(0.05); |
| } |
| if(($lockretry < 0) && |
| ($serverlogslocktimeout >= $defserverlogslocktimeout)) { |
| logmsg "Warning: server logs lock timeout ", |
| "($serverlogslocktimeout seconds) expired\n"; |
| } |
| } |
| |
| # Test harness ssh server does not have this synchronization mechanism, |
| # this implies that some ssh server based tests might need a small delay |
| # once that the client command has run to avoid false test failures. |
| # |
| # gnutls-serv also lacks this synchronization mechanism, so gnutls-serv |
| # based tests might need a small delay once that the client command has |
| # run to avoid false test failures. |
| |
| portable_sleep($postcommanddelay) if($postcommanddelay); |
| |
| # timestamp removal of server logs advisor read lock |
| $timesrvrlog{$testnum} = Time::HiRes::time(); |
| |
| # test definition might instruct to stop some servers |
| # stop also all servers relative to the given one |
| |
| my @killtestservers = getpart("client", "killserver"); |
| if(@killtestservers) { |
| # |
| # All servers relative to the given one must be stopped also |
| # |
| my @killservers; |
| foreach my $server (@killtestservers) { |
| chomp $server; |
| if($server =~ /^(ftp|http|imap|pop3|smtp)s((\d*)(-ipv6|-unix|))$/) { |
| # given a stunnel ssl server, also kill non-ssl underlying one |
| push @killservers, "${1}${2}"; |
| } |
| elsif($server =~ /^(ftp|http|imap|pop3|smtp)((\d*)(-ipv6|-unix|))$/) { |
| # given a non-ssl server, also kill stunnel 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 sockfilter processes for pingpong relative servers |
| # |
| foreach my $server (@killservers) { |
| 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); |
| } |
| } |
| # |
| # kill server relative pids clearing them in %run hash |
| # |
| my $pidlist; |
| foreach my $server (@killservers) { |
| if($run{$server}) { |
| $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); |
| } |
| } |
| |
| # run the postcheck command |
| my @postcheck= getpart("client", "postcheck"); |
| if(@postcheck) { |
| $cmd = join("", @postcheck); |
| chomp $cmd; |
| subVariables \$cmd; |
| if($cmd) { |
| logmsg "postcheck $cmd\n" if($verbose); |
| my $rc = runclient("$cmd"); |
| # Must run the postcheck command in torture mode in order |
| # to clean up, but the result can't be relied upon. |
| if($rc != 0 && !$torture) { |
| logmsg " postcheck FAILED\n"; |
| # timestamp test result verification end |
| $timevrfyend{$testnum} = Time::HiRes::time(); |
| return $errorreturncode; |
| } |
| } |
| } |
| |
| # restore environment variables that were modified |
| if(%oldenv) { |
| foreach my $var (keys %oldenv) { |
| if($oldenv{$var} eq 'notset') { |
| delete $ENV{$var} if($ENV{$var}); |
| } |
| else { |
| $ENV{$var} = "$oldenv{$var}"; |
| } |
| } |
| } |
| |
| # Skip all the verification on torture tests |
| if ($torture) { |
| # timestamp test result verification end |
| $timevrfyend{$testnum} = Time::HiRes::time(); |
| return $cmdres; |
| } |
| |
| my @err = getpart("verify", "errorcode"); |
| my $errorcode = $err[0] || "0"; |
| my $ok=""; |
| my $res; |
| chomp $errorcode; |
| if (@validstdout) { |
| # verify redirected stdout |
| my @actual = loadarray($STDOUT); |
| |
| # what parts to cut off from stdout |
| my @stripfile = getpart("verify", "stripfile"); |
| |
| foreach my $strip (@stripfile) { |
| chomp $strip; |
| my @newgen; |
| for(@actual) { |
| eval $strip; |
| if($_) { |
| push @newgen, $_; |
| } |
| } |
| # this is to get rid of array entries that vanished (zero |
| # length) because of replacements |
| @actual = @newgen; |
| } |
| |
| # variable-replace in the stdout we have from the test case file |
| @validstdout = fixarray(@validstdout); |
| |
| # get all attributes |
| my %hash = getpartattr("verify", "stdout"); |
| |
| # get the mode attribute |
| my $filemode=$hash{'mode'}; |
| if($filemode && ($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows: fix line endings |
| map s/\r\n/\n/g, @validstdout; |
| map s/\n/\r\n/g, @validstdout; |
| } |
| |
| if($hash{'nonewline'}) { |
| # Yes, we must cut off the final newline from the final line |
| # of the protocol data |
| chomp($validstdout[$#validstdout]); |
| } |
| |
| $res = compare($testnum, $testname, "stdout", \@actual, \@validstdout); |
| if($res) { |
| return $errorreturncode; |
| } |
| $ok .= "s"; |
| } |
| else { |
| $ok .= "-"; # stdout not checked |
| } |
| |
| if (@validstderr) { |
| # verify redirected stderr |
| my @actual = loadarray($STDERR); |
| |
| # what parts to cut off from stderr |
| my @stripfile = getpart("verify", "stripfile"); |
| |
| foreach my $strip (@stripfile) { |
| chomp $strip; |
| my @newgen; |
| for(@actual) { |
| eval $strip; |
| if($_) { |
| push @newgen, $_; |
| } |
| } |
| # this is to get rid of array entries that vanished (zero |
| # length) because of replacements |
| @actual = @newgen; |
| } |
| |
| # variable-replace in the stderr we have from the test case file |
| @validstderr = fixarray(@validstderr); |
| |
| # get all attributes |
| my %hash = getpartattr("verify", "stderr"); |
| |
| # get the mode attribute |
| my $filemode=$hash{'mode'}; |
| if($filemode && ($filemode eq "text") && $has_textaware) { |
| # text mode when running on windows: fix line endings |
| map s/\r\n/\n/g, @validstderr; |
| map s/\n/\r\n/g, @validstderr; |
| } |
| |
| if($hash{'nonewline'}) { |
| # Yes, we must cut off the final newline from the final line |
| # of the protocol data |
| chomp($validstderr[$#validstderr]); |
| } |
| |
| $res = compare($testnum, $testname, "stderr", \@actual, \@validstderr); |
| if($res) { |
| return $errorreturncode; |
| } |
| $ok .= "r"; |
| } |
| else { |
| $ok .= "-"; # stderr not checked |
| } |
| |
| if(@protocol) { |
| # Verify the sent request |
| my @out = loadarray($SERVERIN); |
| |
| # what to cut off from the live protocol sent by curl |
| my @strip = getpart("verify", "strip"); |
| |
| my @protstrip=@protocol; |
| |
| # check if there's any attributes on the verify/protocol section |
| my %hash = getpartattr("verify", "protocol"); |
| |
| if($hash{'nonewline'}) { |
| # Yes, we must cut off the final newline from the final line |
| # of the protocol data |
| chomp($protstrip[$#protstrip]); |
| } |
| |
| for(@strip) { |
| # strip off all lines that match the patterns from both arrays |
| chomp $_; |
| @out = striparray( $_, \@out); |
| @protstrip= striparray( $_, \@protstrip); |
| } |
| |
| # what parts to cut off from the protocol |
| my @strippart = getpart("verify", "strippart"); |
| my $strip; |
| @strippart = fixarray(@strippart); |
| for $strip (@strippart) { |
| chomp $strip; |
| for(@out) { |
| eval $strip; |
| } |
| } |
| |
| if((!$out[0] || ($out[0] eq "")) && $protstrip[0]) { |
| logmsg "\n $testnum: protocol FAILED!\n". |
| " There was no content at all in the file $SERVERIN.\n". |
| " Server glitch? Total curl failure? Returned: $cmdres\n"; |
| return $errorreturncode; |
| } |
| |
| $res = compare($testnum, $testname, "protocol", \@out, \@protstrip); |
| if($res) { |
| return $errorreturncode; |
| } |
| |
| $ok .= "p"; |
| |
| } |
| else { |
| $ok .= "-"; # protocol not checked |
| } |
| |
| if(!$replyattr{'nocheck'} && (@reply || $replyattr{'sendzero'})) { |
| # verify the received data |
| my @out = loadarray($CURLOUT); |
| $res = compare($testnum, $testname, "data", \@out, \@reply); |
| if ($res) { |
| return $errorreturncode; |
| } |
| $ok .= "d"; |
| } |
| else { |
| $ok .= "-"; # data not checked |
| } |
| |
| if(@upload) { |
| # verify uploaded data |
| my @out = loadarray("$LOGDIR/upload.$testnum"); |
| |
| # what parts to cut off from the upload |
| my @strippart = getpart("verify", "strippart"); |
| my $strip; |
| for $strip (@strippart) { |
| chomp $strip; |
| for(@out) { |
| eval $strip; |
| } |
| } |
| |
| $res = compare($testnum, $testname, "upload", \@out, \@upload); |
| if ($res) { |
| return $errorreturncode; |
| } |
| $ok .= "u"; |
| } |
| else { |
| $ok .= "-"; # upload not checked |
| } |
| |
| if(@proxyprot) { |
| # Verify the sent proxy request |
| my @out = loadarray($PROXYIN); |
| |
| # what to cut off from the live protocol sent by curl, we use the |
| # same rules as for <protocol> |
| my @strip = getpart("verify", "strip"); |
| |
| my @protstrip=@proxyprot; |
| |
| # check if there's any attributes on the verify/protocol section |
| my %hash = getpartattr("verify", "proxy"); |
| |
| if($hash{'nonewline'}) { |
| # Yes, we must cut off the final newline from the final line |
| # of the protocol data |
| chomp($protstrip[$#protstrip]); |
| } |
| |
| for(@strip) { |
| # strip off all lines that match the patterns from both arrays |
| chomp $_; |
| @out = striparray( $_, \@out); |
| @protstrip= striparray( $_, \@protstrip); |
| } |
| |
| # what parts to cut off from the protocol |
| my @strippart = getpart("verify", "strippart"); |
| my $strip; |
| for $strip (@strippart) { |
| chomp $strip; |
| for(@out) { |
| |