1#!/usr/bin/env perl
2#***************************************************************************
3#                                  _   _ ____  _
4#  Project                     ___| | | |  _ \| |
5#                             / __| | | | |_) | |
6#                            | (__| |_| |  _ <| |___
7#                             \___|\___/|_| \_\_____|
8#
9# Copyright (C) 1998 - 2021, Daniel Stenberg, <daniel@haxx.se>, et al.
10#
11# This software is licensed as described in the file COPYING, which
12# you should have received as part of this distribution. The terms
13# are also available at https://curl.se/docs/copyright.html.
14#
15# You may opt to use, copy, modify, merge, publish, distribute and/or sell
16# copies of the Software, and permit persons to whom the Software is
17# furnished to do so, under the terms of the COPYING file.
18#
19# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
20# KIND, either express or implied.
21#
22###########################################################################
23
24# Experimental hooks are available to run tests remotely on machines that
25# are able to run curl but are unable to run the test harness.
26# The following sections need to be modified:
27#
28#  $HOSTIP, $HOST6IP - Set to the address of the host running the test suite
29#  $CLIENTIP, $CLIENT6IP - Set to the address of the host running curl
30#  runclient, runclientoutput - Modify to copy all the files in the log/
31#    directory to the system running curl, run the given command remotely
32#    and save the return code or returned stdout (respectively), then
33#    copy all the files from the remote system's log/ directory back to
34#    the host running the test suite.  This can be done a few ways, such
35#    as using scp & ssh, rsync & telnet, or using a NFS shared directory
36#    and ssh.
37#
38# 'make && make test' needs to be done on both machines before making the
39# above changes and running runtests.pl manually.  In the shared NFS case,
40# the contents of the tests/server/ directory must be from the host
41# running the test suite, while the rest must be from the host running curl.
42#
43# Note that even with these changes a number of tests will still fail (mainly
44# to do with cookies, those that set environment variables, or those that
45# do more than touch the file system in a <precheck> or <postcheck>
46# section). These can be added to the $TESTCASES line below,
47# e.g. $TESTCASES="!8 !31 !63 !cookies..."
48#
49# Finally, to properly support -g and -n, checktestcmd needs to change
50# to check the remote system's PATH, and the places in the code where
51# the curl binary is read directly to determine its type also need to be
52# fixed. As long as the -g option is never given, and the -n is always
53# given, this won't be a problem.
54
55
56# These should be the only variables that might be needed to get edited:
57
58BEGIN {
59    # Define srcdir to the location of the tests source directory. This is
60    # usually set by the Makefile, but for out-of-tree builds with direct
61    # invocation of runtests.pl, it may not be set.
62    if(!defined $ENV{'srcdir'}) {
63        use File::Basename;
64        $ENV{'srcdir'} = dirname(__FILE__);
65    }
66    push(@INC, $ENV{'srcdir'});
67    # run time statistics needs Time::HiRes
68    eval {
69        no warnings "all";
70        require Time::HiRes;
71        import  Time::HiRes qw( time );
72    }
73}
74
75use strict;
76use warnings;
77use Cwd;
78use Digest::MD5 qw(md5);
79use MIME::Base64;
80
81# Subs imported from serverhelp module
82use serverhelp qw(
83    serverfactors
84    servername_id
85    servername_str
86    servername_canon
87    server_pidfilename
88    server_portfilename
89    server_logfilename
90    );
91
92# Variables and subs imported from sshhelp module
93use sshhelp qw(
94    $sshdexe
95    $sshexe
96    $sftpexe
97    $sshconfig
98    $sftpconfig
99    $sshdlog
100    $sshlog
101    $sftplog
102    $sftpcmds
103    display_sshdconfig
104    display_sshconfig
105    display_sftpconfig
106    display_sshdlog
107    display_sshlog
108    display_sftplog
109    exe_ext
110    find_sshd
111    find_ssh
112    find_sftp
113    find_httptlssrv
114    sshversioninfo
115    );
116
117use pathhelp;
118
119require "getpart.pm"; # array functions
120require "valgrind.pm"; # valgrind report parser
121require "ftp.pm";
122require "azure.pm";
123require "appveyor.pm";
124
125my $HOSTIP="127.0.0.1";   # address on which the test server listens
126my $HOST6IP="[::1]";      # address on which the test server listens
127my $CLIENTIP="127.0.0.1"; # address which curl uses for incoming connections
128my $CLIENT6IP="[::1]";    # address which curl uses for incoming connections
129
130my $noport="[not running]";
131
132my $NOLISTENPORT=47;     # port number we use for a local non-listening service
133my $MQTTPORT=$noport;    # MQTT server port
134my $HTTPPORT=$noport;    # HTTP server port
135my $HTTP6PORT=$noport;   # HTTP IPv6 server port
136my $HTTPSPORT=$noport;   # HTTPS (stunnel) server port
137my $HTTPSPROXYPORT = $noport; # HTTPS-proxy (stunnel) port
138my $FTPPORT=$noport;     # FTP server port
139my $FTPSPORT=$noport;    # FTPS (stunnel) server port
140my $FTP6PORT=$noport;    # FTP IPv6 server port
141my $TFTPPORT=$noport;    # TFTP
142my $TFTP6PORT=$noport;   # TFTP
143my $SSHPORT=$noport;     # SCP/SFTP
144my $SOCKSPORT=$noport;   # SOCKS4/5 port
145my $POP3PORT=$noport;    # POP3
146my $POP36PORT=$noport;   # POP3 IPv6 server port
147my $IMAPPORT=$noport;    # IMAP
148my $IMAP6PORT=$noport;   # IMAP IPv6 server port
149my $SMTPPORT=$noport;    # SMTP
150my $SMTP6PORT=$noport;   # SMTP IPv6 server port
151my $RTSPPORT=$noport;    # RTSP
152my $RTSP6PORT=$noport;   # RTSP IPv6 server port
153my $GOPHERPORT=$noport;  # Gopher
154my $GOPHERSPORT=$noport; # Gophers
155my $GOPHER6PORT=$noport; # Gopher IPv6 server port
156my $HTTPTLSPORT=$noport; # HTTP TLS (non-stunnel) server port
157my $HTTPTLS6PORT=$noport; # HTTP TLS (non-stunnel) IPv6 server port
158my $HTTPPROXYPORT=$noport; # HTTP proxy port, when using CONNECT
159my $HTTP2PORT=$noport;   # HTTP/2 server port
160my $DICTPORT=$noport;    # DICT server port
161my $SMBPORT=$noport;     # SMB server port
162my $SMBSPORT=$noport;    # SMBS server port
163my $TELNETPORT=$noport;  # TELNET server port with negotiation
164my $HTTPUNIXPATH;        # HTTP server Unix domain socket path
165
166my $SSHSRVMD5 = "[uninitialized]"; # MD5 of ssh server public key
167my $VERSION;             # curl's reported version number
168
169my $srcdir = $ENV{'srcdir'} || '.';
170my $CURL="../src/curl".exe_ext('TOOL'); # what curl executable to run on the tests
171my $VCURL=$CURL;   # what curl binary to use to verify the servers with
172                   # VCURL is handy to set to the system one when the one you
173                   # just built hangs or crashes and thus prevent verification
174my $DBGCURL=$CURL; #"../src/.libs/curl";  # alternative for debugging
175my $LOGDIR="log";
176my $TESTDIR="$srcdir/data";
177my $LIBDIR="./libtest";
178my $UNITDIR="./unit";
179# TODO: change this to use server_inputfilename()
180my $SERVERIN="$LOGDIR/server.input"; # what curl sent the server
181my $SERVER2IN="$LOGDIR/server2.input"; # what curl sent the second server
182my $PROXYIN="$LOGDIR/proxy.input"; # what curl sent the proxy
183my $CURLLOG="commands.log"; # all command lines run
184my $FTPDCMD="$LOGDIR/ftpserver.cmd"; # copy server instructions here
185my $SERVERLOGS_LOCK="$LOGDIR/serverlogs.lock"; # server logs advisor read lock
186my $CURLCONFIG="../curl-config"; # curl-config from current build
187
188# Normally, all test cases should be run, but at times it is handy to
189# simply run a particular one:
190my $TESTCASES="all";
191
192# To run specific test cases, set them like:
193# $TESTCASES="1 2 3 7 8";
194
195#######################################################################
196# No variables below this point should need to be modified
197#
198
199# invoke perl like this:
200my $perl="perl -I$srcdir";
201my $server_response_maxtime=13;
202
203my $debug_build=0;          # built debug enabled (--enable-debug)
204my $has_memory_tracking=0;  # built with memory tracking (--enable-curldebug)
205my $libtool;
206my $repeat = 0;
207
208# name of the file that the memory debugging creates:
209my $memdump="$LOGDIR/memdump";
210
211# the path to the script that analyzes the memory debug output file:
212my $memanalyze="$perl $srcdir/memanalyze.pl";
213
214my $pwd = getcwd();          # current working directory
215my $posix_pwd = $pwd;
216
217my $start;
218my $ftpchecktime=1; # time it took to verify our test FTP server
219my $scrambleorder;
220my $stunnel = checkcmd("stunnel4") || checkcmd("tstunnel") || checkcmd("stunnel");
221my $valgrind = checktestcmd("valgrind");
222my $valgrind_logfile="--logfile";
223my $valgrind_tool;
224my $gdb = checktestcmd("gdb");
225my $httptlssrv = find_httptlssrv();
226
227my $uname_release = `uname -r`;
228my $is_wsl = $uname_release =~ /Microsoft$/;
229
230my $has_ssl;        # set if libcurl is built with SSL support
231my $has_largefile;  # set if libcurl is built with large file support
232my $has_idn;        # set if libcurl is built with IDN support
233my $http_ipv6;      # set if HTTP server has IPv6 support
234my $http_unix;      # set if HTTP server has Unix sockets support
235my $ftp_ipv6;       # set if FTP server has IPv6 support
236my $tftp_ipv6;      # set if TFTP server has IPv6 support
237my $gopher_ipv6;    # set if Gopher server has IPv6 support
238my $has_ipv6;       # set if libcurl is built with IPv6 support
239my $has_unix;       # set if libcurl is built with Unix sockets support
240my $has_libz;       # set if libcurl is built with libz support
241my $has_brotli;     # set if libcurl is built with brotli support
242my $has_zstd;       # set if libcurl is built with zstd support
243my $has_getrlimit;  # set if system has getrlimit()
244my $has_ntlm;       # set if libcurl is built with NTLM support
245my $has_ntlm_wb;    # set if libcurl is built with NTLM delegation to winbind
246my $has_sspi;       # set if libcurl is built with Windows SSPI
247my $has_gssapi;     # set if libcurl is built with a GSS-API library
248my $has_kerberos;   # set if libcurl is built with Kerberos support
249my $has_spnego;     # set if libcurl is built with SPNEGO support
250my $has_charconv;   # set if libcurl is built with CharConv support
251my $has_tls_srp;    # set if libcurl is built with TLS-SRP support
252my $has_metalink;   # set if curl is built with Metalink support
253my $has_http2;      # set if libcurl is built with HTTP2 support
254my $has_httpsproxy; # set if libcurl is built with HTTPS-proxy support
255my $has_crypto;     # set if libcurl is built with cryptographic support
256my $has_cares;      # set if built with c-ares
257my $has_threadedres;# set if built with threaded resolver
258my $has_psl;        # set if libcurl is built with PSL support
259my $has_altsvc;     # set if libcurl is built with alt-svc support
260my $has_hsts;       # set if libcurl is built with HSTS support
261my $has_ldpreload;  # set if built for systems supporting LD_PRELOAD
262my $has_multissl;   # set if build with MultiSSL support
263my $has_manual;     # set if built with built-in manual
264my $has_win32;      # set if built for Windows
265my $has_mingw;      # set if built with MinGW (as opposed to MinGW-w64)
266my $has_hyper = 0;  # set if built with Hyper
267
268# this version is decided by the particular nghttp2 library that is being used
269my $h2cver = "h2c";
270
271my $has_openssl;    # built with a lib using an OpenSSL-like API
272my $has_gnutls;     # built with GnuTLS
273my $has_nss;        # built with NSS
274my $has_wolfssl;    # built with wolfSSL
275my $has_schannel;   # built with Schannel
276my $has_sectransp;  # built with Secure Transport
277my $has_boringssl;  # built with BoringSSL
278my $has_libressl;   # built with libressl
279my $has_mbedtls;    # built with mbedTLS
280my $has_mesalink;   # built with MesaLink
281
282my $has_sslpinning; # built with a TLS backend that supports pinning
283
284my $has_shared = "unknown";  # built shared
285
286my $resolver;       # name of the resolver backend (for human presentation)
287
288my $has_textaware;  # set if running on a system that has a text mode concept
289                    # on files. Windows for example
290my @protocols;   # array of lowercase supported protocol servers
291
292my $skipped=0;  # number of tests skipped; reported in main loop
293my %skipped;    # skipped{reason}=counter, reasons for skip
294my @teststat;   # teststat[testnum]=reason, reasons for skip
295my %disabled_keywords;  # key words of tests to skip
296my %ignored_keywords;   # key words of tests to ignore results
297my %enabled_keywords;   # key words of tests to run
298my %disabled;           # disabled test cases
299my %ignored;            # ignored results of test cases
300
301my $sshdid;      # for socks server, ssh daemon version id
302my $sshdvernum;  # for socks server, ssh daemon version number
303my $sshdverstr;  # for socks server, ssh daemon version string
304my $sshderror;   # for socks server, ssh daemon version error
305
306my $defserverlogslocktimeout = 2; # timeout to await server logs lock removal
307my $defpostcommanddelay = 0; # delay between command and postcheck sections
308
309my $timestats;   # time stamping and stats generation
310my $fullstats;   # show time stats for every single test
311my %timeprepini; # timestamp for each test preparation start
312my %timesrvrini; # timestamp for each test required servers verification start
313my %timesrvrend; # timestamp for each test required servers verification end
314my %timetoolini; # timestamp for each test command run starting
315my %timetoolend; # timestamp for each test command run stopping
316my %timesrvrlog; # timestamp for each test server logs lock removal
317my %timevrfyend; # timestamp for each test result verification end
318
319my $testnumcheck; # test number, set in singletest sub.
320my %oldenv;
321my %feature;      # array of enabled features
322my %keywords;     # array of keywords from the test spec
323
324#######################################################################
325# variables that command line options may set
326#
327
328my $short;
329my $automakestyle;
330my $verbose;
331my $debugprotocol;
332my $anyway;
333my $gdbthis;      # run test case with gdb debugger
334my $gdbxwin;      # use windowed gdb when using gdb
335my $keepoutfiles; # keep stdout and stderr files after tests
336my $listonly;     # only list the tests
337my $postmortem;   # display detailed info about failed tests
338my $run_event_based; # run curl with --test-event to test the event API
339
340my %run;          # running server
341my %doesntrun;    # servers that don't work, identified by pidfile
342my %serverpidfile;# all server pid file names, identified by server id
343my %serverportfile;# all server port file names, identified by server id
344my %runcert;      # cert file currently in use by an ssl running server
345
346# torture test variables
347my $torture;
348my $tortnum;
349my $tortalloc;
350my $shallow;
351my $randseed = 0;
352
353# Azure Pipelines specific variables
354my $AZURE_RUN_ID = 0;
355my $AZURE_RESULT_ID = 0;
356
357#######################################################################
358# logmsg is our general message logging subroutine.
359#
360sub logmsg {
361    for(@_) {
362        my $line = $_;
363        if ($is_wsl) {
364            # use \r\n for WSL shell
365            $line =~ s/\r?\n$/\r\n/g;
366        }
367        print "$line";
368    }
369}
370
371# get the name of the current user
372my $USER = $ENV{USER};          # Linux
373if (!$USER) {
374    $USER = $ENV{USERNAME};     # Windows
375    if (!$USER) {
376        $USER = $ENV{LOGNAME};  # Some Unix (I think)
377    }
378}
379
380# enable memory debugging if curl is compiled with it
381$ENV{'CURL_MEMDEBUG'} = $memdump;
382$ENV{'CURL_ENTROPY'}="12345678";
383$ENV{'CURL_FORCETIME'}=1; # for debug NTLM magic
384$ENV{'CURL_GLOBAL_INIT'}=1; # debug curl_global_init/cleanup use
385$ENV{'HOME'}=$pwd;
386$ENV{'COLUMNS'}=79; # screen width!
387
388sub catch_zap {
389    my $signame = shift;
390    logmsg "runtests.pl received SIG$signame, exiting\n";
391    stopservers($verbose);
392    die "Somebody sent me a SIG$signame";
393}
394$SIG{INT} = \&catch_zap;
395$SIG{TERM} = \&catch_zap;
396
397##########################################################################
398# Clear all possible '*_proxy' environment variables for various protocols
399# to prevent them to interfere with our testing!
400
401my $protocol;
402foreach $protocol (('ftp', 'http', 'ftps', 'https', 'no', 'all')) {
403    my $proxy = "${protocol}_proxy";
404    # clear lowercase version
405    delete $ENV{$proxy} if($ENV{$proxy});
406    # clear uppercase version
407    delete $ENV{uc($proxy)} if($ENV{uc($proxy)});
408}
409
410# make sure we don't get affected by other variables that control our
411# behavior
412
413delete $ENV{'SSL_CERT_DIR'} if($ENV{'SSL_CERT_DIR'});
414delete $ENV{'SSL_CERT_PATH'} if($ENV{'SSL_CERT_PATH'});
415delete $ENV{'CURL_CA_BUNDLE'} if($ENV{'CURL_CA_BUNDLE'});
416
417#######################################################################
418# Load serverpidfile and serverportfile hashes with file names for all
419# possible servers.
420#
421sub init_serverpidfile_hash {
422  for my $proto (('ftp', 'gopher', 'http', 'imap', 'pop3', 'smtp', 'http/2')) {
423    for my $ssl (('', 's')) {
424      for my $ipvnum ((4, 6)) {
425        for my $idnum ((1, 2, 3)) {
426          my $serv = servername_id("$proto$ssl", $ipvnum, $idnum);
427          my $pidf = server_pidfilename("$proto$ssl", $ipvnum, $idnum);
428          $serverpidfile{$serv} = $pidf;
429          my $portf = server_portfilename("$proto$ssl", $ipvnum, $idnum);
430          $serverportfile{$serv} = $portf;
431        }
432      }
433    }
434  }
435  for my $proto (('tftp', 'sftp', 'socks', 'ssh', 'rtsp', 'httptls',
436                  'dict', 'smb', 'smbs', 'telnet', 'mqtt')) {
437    for my $ipvnum ((4, 6)) {
438      for my $idnum ((1, 2)) {
439        my $serv = servername_id($proto, $ipvnum, $idnum);
440        my $pidf = server_pidfilename($proto, $ipvnum, $idnum);
441        $serverpidfile{$serv} = $pidf;
442        my $portf = server_portfilename($proto, $ipvnum, $idnum);
443        $serverportfile{$serv} = $portf;
444      }
445    }
446  }
447  for my $proto (('http', 'imap', 'pop3', 'smtp', 'http/2')) {
448    for my $ssl (('', 's')) {
449      my $serv = servername_id("$proto$ssl", "unix", 1);
450      my $pidf = server_pidfilename("$proto$ssl", "unix", 1);
451      $serverpidfile{$serv} = $pidf;
452      my $portf = server_portfilename("$proto$ssl", "unix", 1);
453      $serverportfile{$serv} = $portf;
454    }
455  }
456}
457
458#######################################################################
459# Check if a given child process has just died. Reaps it if so.
460#
461sub checkdied {
462    use POSIX ":sys_wait_h";
463    my $pid = $_[0];
464    if((not defined $pid) || $pid <= 0) {
465        return 0;
466    }
467    my $rc = pidwait($pid, &WNOHANG);
468    return ($rc == $pid)?1:0;
469}
470
471#######################################################################
472# Start a new thread/process and run the given command line in there.
473# Return the pids (yes plural) of the new child process to the parent.
474#
475sub startnew {
476    my ($cmd, $pidfile, $timeout, $fake)=@_;
477
478    logmsg "startnew: $cmd\n" if ($verbose);
479
480    my $child = fork();
481    my $pid2 = 0;
482
483    if(not defined $child) {
484        logmsg "startnew: fork() failure detected\n";
485        return (-1,-1);
486    }
487
488    if(0 == $child) {
489        # Here we are the child. Run the given command.
490
491        # Put an "exec" in front of the command so that the child process
492        # keeps this child's process ID.
493        exec("exec $cmd") || die "Can't exec() $cmd: $!";
494
495        # exec() should never return back here to this process. We protect
496        # ourselves by calling die() just in case something goes really bad.
497        die "error: exec() has returned";
498    }
499
500    # Ugly hack but ssh client and gnutls-serv don't support pid files
501    if ($fake) {
502        if(open(OUT, ">$pidfile")) {
503            print OUT $child . "\n";
504            close(OUT);
505            logmsg "startnew: $pidfile faked with pid=$child\n" if($verbose);
506        }
507        else {
508            logmsg "startnew: failed to write fake $pidfile with pid=$child\n";
509        }
510        # could/should do a while connect fails sleep a bit and loop
511        portable_sleep($timeout);
512        if (checkdied($child)) {
513            logmsg "startnew: child process has failed to start\n" if($verbose);
514            return (-1,-1);
515        }
516    }
517
518    my $count = $timeout;
519    while($count--) {
520        if(-f $pidfile && -s $pidfile && open(PID, "<$pidfile")) {
521            $pid2 = 0 + <PID>;
522            close(PID);
523            if(($pid2 > 0) && pidexists($pid2)) {
524                # if $pid2 is valid, then make sure this pid is alive, as
525                # otherwise it is just likely to be the _previous_ pidfile or
526                # similar!
527                last;
528            }
529            # invalidate $pid2 if not actually alive
530            $pid2 = 0;
531        }
532        if (checkdied($child)) {
533            logmsg "startnew: child process has died, server might start up\n"
534                if($verbose);
535            # We can't just abort waiting for the server with a
536            # return (-1,-1);
537            # because the server might have forked and could still start
538            # up normally. Instead, just reduce the amount of time we remain
539            # waiting.
540            $count >>= 2;
541        }
542        sleep(1);
543    }
544
545    # Return two PIDs, the one for the child process we spawned and the one
546    # reported by the server itself (in case it forked again on its own).
547    # Both (potentially) need to be killed at the end of the test.
548    return ($child, $pid2);
549}
550
551
552#######################################################################
553# Check for a command in the PATH of the test server.
554#
555sub checkcmd {
556    my ($cmd)=@_;
557    my @paths=(split(":", $ENV{'PATH'}), "/usr/sbin", "/usr/local/sbin",
558               "/sbin", "/usr/bin", "/usr/local/bin",
559               "$LIBDIR/.libs", "$LIBDIR");
560    for(@paths) {
561        if( -x "$_/$cmd" && ! -d "$_/$cmd") {
562            # executable bit but not a directory!
563            return "$_/$cmd";
564        }
565    }
566}
567
568#######################################################################
569# Get the list of tests that the tests/data/Makefile.am knows about!
570#
571my $disttests;
572sub get_disttests {
573    my $makeCmd = 'make';
574    if(-f "../CMakeCache.txt") {
575        $makeCmd = 'cmake --build ../.. --target';
576    }
577    my @dist = `cd data && $makeCmd show`;
578    $disttests = join("", @dist);
579}
580
581#######################################################################
582# Check for a command in the PATH of the machine running curl.
583#
584sub checktestcmd {
585    my ($cmd)=@_;
586    return checkcmd($cmd);
587}
588
589#######################################################################
590# Run the application under test and return its return code
591#
592sub runclient {
593    my ($cmd)=@_;
594    my $ret = system($cmd);
595    print "CMD ($ret): $cmd\n" if($verbose && !$torture);
596    return $ret;
597
598# This is one way to test curl on a remote machine
599#    my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'");
600#    sleep 2;    # time to allow the NFS server to be updated
601#    return $out;
602}
603
604#######################################################################
605# Run the application under test and return its stdout
606#
607sub runclientoutput {
608    my ($cmd)=@_;
609    return `$cmd`;
610
611# This is one way to test curl on a remote machine
612#    my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`;
613#    sleep 2;    # time to allow the NFS server to be updated
614#    return @out;
615 }
616
617#######################################################################
618# Memory allocation test and failure torture testing.
619#
620sub torture {
621    my ($testcmd, $testnum, $gdbline) = @_;
622
623    # remove memdump first to be sure we get a new nice and clean one
624    unlink($memdump);
625
626    # First get URL from test server, ignore the output/result
627    runclient($testcmd);
628
629    logmsg " CMD: $testcmd\n" if($verbose);
630
631    # memanalyze -v is our friend, get the number of allocations made
632    my $count=0;
633    my @out = `$memanalyze -v $memdump`;
634    for(@out) {
635        if(/^Operations: (\d+)/) {
636            $count = $1;
637            last;
638        }
639    }
640    if(!$count) {
641        logmsg " found no functions to make fail\n";
642        return 0;
643    }
644
645    my @ttests = (1 .. $count);
646    if($shallow && ($shallow < $count)) {
647        my $discard = scalar(@ttests) - $shallow;
648        my $percent = sprintf("%.2f%%", $shallow * 100 / scalar(@ttests));;
649        logmsg " $count functions found, but only fail $shallow ($percent)\n";
650        while($discard) {
651            my $rm;
652            do {
653                # find a test to discard
654                $rm = rand(scalar(@ttests));
655            } while(!$ttests[$rm]);
656            $ttests[$rm] = undef;
657            $discard--;
658        }
659    }
660    else {
661        logmsg " $count functions to make fail\n";
662    }
663
664    for (@ttests) {
665        my $limit = $_;
666        my $fail;
667        my $dumped_core;
668
669        if(!defined($limit)) {
670            # --shallow can undefine them
671            next;
672        }
673        if($tortalloc && ($tortalloc != $limit)) {
674            next;
675        }
676
677        if($verbose) {
678            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
679                localtime(time());
680            my $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
681            logmsg "Fail function no: $limit at $now\r";
682        }
683
684        # make the memory allocation function number $limit return failure
685        $ENV{'CURL_MEMLIMIT'} = $limit;
686
687        # remove memdump first to be sure we get a new nice and clean one
688        unlink($memdump);
689
690        my $cmd = $testcmd;
691        if($valgrind && !$gdbthis) {
692            my @valgrindoption = getpart("verify", "valgrind");
693            if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) {
694                my $valgrindcmd = "$valgrind ";
695                $valgrindcmd .= "$valgrind_tool " if($valgrind_tool);
696                $valgrindcmd .= "--quiet --leak-check=yes ";
697                $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp ";
698                # $valgrindcmd .= "--gen-suppressions=all ";
699                $valgrindcmd .= "--num-callers=16 ";
700                $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum";
701                $cmd = "$valgrindcmd $testcmd";
702            }
703        }
704        logmsg "*** Function number $limit is now set to fail ***\n" if($gdbthis);
705
706        my $ret = 0;
707        if($gdbthis) {
708            runclient($gdbline);
709        }
710        else {
711            $ret = runclient($cmd);
712        }
713        #logmsg "$_ Returned " . ($ret >> 8) . "\n";
714
715        # Now clear the variable again
716        delete $ENV{'CURL_MEMLIMIT'} if($ENV{'CURL_MEMLIMIT'});
717
718        if(-r "core") {
719            # there's core file present now!
720            logmsg " core dumped\n";
721            $dumped_core = 1;
722            $fail = 2;
723        }
724
725        if($valgrind) {
726            my @e = valgrindparse("$LOGDIR/valgrind$testnum");
727            if(@e && $e[0]) {
728                if($automakestyle) {
729                    logmsg "FAIL: torture $testnum - valgrind\n";
730                }
731                else {
732                    logmsg " valgrind ERROR ";
733                    logmsg @e;
734                }
735                $fail = 1;
736            }
737        }
738
739        # verify that it returns a proper error code, doesn't leak memory
740        # and doesn't core dump
741        if(($ret & 255) || ($ret >> 8) >= 128) {
742            logmsg " system() returned $ret\n";
743            $fail=1;
744        }
745        else {
746            my @memdata=`$memanalyze $memdump`;
747            my $leak=0;
748            for(@memdata) {
749                if($_ ne "") {
750                    # well it could be other memory problems as well, but
751                    # we call it leak for short here
752                    $leak=1;
753                }
754            }
755            if($leak) {
756                logmsg "** MEMORY FAILURE\n";
757                logmsg @memdata;
758                logmsg `$memanalyze -l $memdump`;
759                $fail = 1;
760            }
761        }
762        if($fail) {
763            logmsg " Failed on function number $limit in test.\n",
764            " invoke with \"-t$limit\" to repeat this single case.\n";
765            stopservers($verbose);
766            return 1;
767        }
768    }
769
770    logmsg "torture OK\n";
771    return 0;
772}
773
774#######################################################################
775# Stop a test server along with pids which aren't in the %run hash yet.
776# This also stops all servers which are relative to the given one.
777#
778sub stopserver {
779    my ($server, $pidlist) = @_;
780
781    #
782    # kill sockfilter processes for pingpong relative server
783    #
784    if($server =~ /^(ftp|imap|pop3|smtp)s?(\d*)(-ipv6|)$/) {
785        my $proto  = $1;
786        my $idnum  = ($2 && ($2 > 1)) ? $2 : 1;
787        my $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
788        killsockfilters($proto, $ipvnum, $idnum, $verbose);
789    }
790    #
791    # All servers relative to the given one must be stopped also
792    #
793    my @killservers;
794    if($server =~ /^(ftp|http|imap|pop3|smtp)s((\d*)(-ipv6|-unix|))$/) {
795        # given a stunnel based ssl server, also kill non-ssl underlying one
796        push @killservers, "${1}${2}";
797    }
798    elsif($server =~ /^(ftp|http|imap|pop3|smtp)((\d*)(-ipv6|-unix|))$/) {
799        # given a non-ssl server, also kill stunnel based ssl piggybacking one
800        push @killservers, "${1}s${2}";
801    }
802    elsif($server =~ /^(socks)((\d*)(-ipv6|))$/) {
803        # given a socks server, also kill ssh underlying one
804        push @killservers, "ssh${2}";
805    }
806    elsif($server =~ /^(ssh)((\d*)(-ipv6|))$/) {
807        # given a ssh server, also kill socks piggybacking one
808        push @killservers, "socks${2}";
809    }
810    if($server eq "http") {
811        # since the http2 server is a proxy that needs to know about the
812        # dynamic http port it too needs to get restarted when the http server
813        # is killed
814        push @killservers, "http/2";
815    }
816    push @killservers, $server;
817    #
818    # kill given pids and server relative ones clearing them in %run hash
819    #
820    foreach my $server (@killservers) {
821        if($run{$server}) {
822            # we must prepend a space since $pidlist may already contain a pid
823            $pidlist .= " $run{$server}";
824            $run{$server} = 0;
825        }
826        $runcert{$server} = 0 if($runcert{$server});
827    }
828    killpid($verbose, $pidlist);
829    #
830    # cleanup server pid files
831    #
832    foreach my $server (@killservers) {
833        my $pidfile = $serverpidfile{$server};
834        my $pid = processexists($pidfile);
835        if($pid > 0) {
836            logmsg "Warning: $server server unexpectedly alive\n";
837            killpid($verbose, $pid);
838        }
839        unlink($pidfile) if(-f $pidfile);
840    }
841}
842
843#######################################################################
844# Verify that the server that runs on $ip, $port is our server.  This also
845# implies that we can speak with it, as there might be occasions when the
846# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't
847# assign requested address")
848#
849sub verifyhttp {
850    my ($proto, $ipvnum, $idnum, $ip, $port_or_path) = @_;
851    my $server = servername_id($proto, $ipvnum, $idnum);
852    my $pid = 0;
853    my $bonus="";
854    # $port_or_path contains a path for Unix sockets, sws ignores the port
855    my $port = ($ipvnum eq "unix") ? 80 : $port_or_path;
856
857    my $verifyout = "$LOGDIR/".
858        servername_canon($proto, $ipvnum, $idnum) .'_verify.out';
859    unlink($verifyout) if(-f $verifyout);
860
861    my $verifylog = "$LOGDIR/".
862        servername_canon($proto, $ipvnum, $idnum) .'_verify.log';
863    unlink($verifylog) if(-f $verifylog);
864
865    if($proto eq "gopher") {
866        # gopher is funny
867        $bonus="1/";
868    }
869
870    my $flags = "--max-time $server_response_maxtime ";
871    $flags .= "--output $verifyout ";
872    $flags .= "--silent ";
873    $flags .= "--verbose ";
874    $flags .= "--globoff ";
875    $flags .= "--unix-socket '$port_or_path' " if $ipvnum eq "unix";
876    $flags .= "--insecure " if($proto eq 'https');
877    $flags .= "\"$proto://$ip:$port/${bonus}verifiedserver\"";
878
879    my $cmd = "$VCURL $flags 2>$verifylog";
880
881    # verify if our/any server is running on this port
882    logmsg "RUN: $cmd\n" if($verbose);
883    my $res = runclient($cmd);
884
885    $res >>= 8; # rotate the result
886    if($res & 128) {
887        logmsg "RUN: curl command died with a coredump\n";
888        return -1;
889    }
890
891    if($res && $verbose) {
892        logmsg "RUN: curl command returned $res\n";
893        if(open(FILE, "<$verifylog")) {
894            while(my $string = <FILE>) {
895                logmsg "RUN: $string" if($string !~ /^([ \t]*)$/);
896            }
897            close(FILE);
898        }
899    }
900
901    my $data;
902    if(open(FILE, "<$verifyout")) {
903        while(my $string = <FILE>) {
904            $data = $string;
905            last; # only want first line
906        }
907        close(FILE);
908    }
909
910    if($data && ($data =~ /WE ROOLZ: (\d+)/)) {
911        $pid = 0+$1;
912    }
913    elsif($res == 6) {
914        # curl: (6) Couldn't resolve host '::1'
915        logmsg "RUN: failed to resolve host ($proto://$ip:$port/verifiedserver)\n";
916        return -1;
917    }
918    elsif($data || ($res && ($res != 7))) {
919        logmsg "RUN: Unknown server on our $server port: $port ($res)\n";
920        return -1;
921    }
922    return $pid;
923}
924
925#######################################################################
926# Verify that the server that runs on $ip, $port is our server.  This also
927# implies that we can speak with it, as there might be occasions when the
928# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't
929# assign requested address")
930#
931sub verifyftp {
932    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
933    my $server = servername_id($proto, $ipvnum, $idnum);
934    my $pid = 0;
935    my $time=time();
936    my $extra="";
937
938    my $verifylog = "$LOGDIR/".
939        servername_canon($proto, $ipvnum, $idnum) .'_verify.log';
940    unlink($verifylog) if(-f $verifylog);
941
942    if($proto eq "ftps") {
943        $extra .= "--insecure --ftp-ssl-control ";
944    }
945
946    my $flags = "--max-time $server_response_maxtime ";
947    $flags .= "--silent ";
948    $flags .= "--verbose ";
949    $flags .= "--globoff ";
950    $flags .= $extra;
951    $flags .= "\"$proto://$ip:$port/verifiedserver\"";
952
953    my $cmd = "$VCURL $flags 2>$verifylog";
954
955    # check if this is our server running on this port:
956    logmsg "RUN: $cmd\n" if($verbose);
957    my @data = runclientoutput($cmd);
958
959    my $res = $? >> 8; # rotate the result
960    if($res & 128) {
961        logmsg "RUN: curl command died with a coredump\n";
962        return -1;
963    }
964
965    foreach my $line (@data) {
966        if($line =~ /WE ROOLZ: (\d+)/) {
967            # this is our test server with a known pid!
968            $pid = 0+$1;
969            last;
970        }
971    }
972    if($pid <= 0 && @data && $data[0]) {
973        # this is not a known server
974        logmsg "RUN: Unknown server on our $server port: $port\n";
975        return 0;
976    }
977    # we can/should use the time it took to verify the FTP server as a measure
978    # on how fast/slow this host/FTP is.
979    my $took = int(0.5+time()-$time);
980
981    if($verbose) {
982        logmsg "RUN: Verifying our test $server server took $took seconds\n";
983    }
984    $ftpchecktime = $took>=1?$took:1; # make sure it never is below 1
985
986    return $pid;
987}
988
989#######################################################################
990# Verify that the server that runs on $ip, $port is our server.  This also
991# implies that we can speak with it, as there might be occasions when the
992# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't
993# assign requested address")
994#
995sub verifyrtsp {
996    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
997    my $server = servername_id($proto, $ipvnum, $idnum);
998    my $pid = 0;
999
1000    my $verifyout = "$LOGDIR/".
1001        servername_canon($proto, $ipvnum, $idnum) .'_verify.out';
1002    unlink($verifyout) if(-f $verifyout);
1003
1004    my $verifylog = "$LOGDIR/".
1005        servername_canon($proto, $ipvnum, $idnum) .'_verify.log';
1006    unlink($verifylog) if(-f $verifylog);
1007
1008    my $flags = "--max-time $server_response_maxtime ";
1009    $flags .= "--output $verifyout ";
1010    $flags .= "--silent ";
1011    $flags .= "--verbose ";
1012    $flags .= "--globoff ";
1013    # currently verification is done using http
1014    $flags .= "\"http://$ip:$port/verifiedserver\"";
1015
1016    my $cmd = "$VCURL $flags 2>$verifylog";
1017
1018    # verify if our/any server is running on this port
1019    logmsg "RUN: $cmd\n" if($verbose);
1020    my $res = runclient($cmd);
1021
1022    $res >>= 8; # rotate the result
1023    if($res & 128) {
1024        logmsg "RUN: curl command died with a coredump\n";
1025        return -1;
1026    }
1027
1028    if($res && $verbose) {
1029        logmsg "RUN: curl command returned $res\n";
1030        if(open(FILE, "<$verifylog")) {
1031            while(my $string = <FILE>) {
1032                logmsg "RUN: $string" if($string !~ /^([ \t]*)$/);
1033            }
1034            close(FILE);
1035        }
1036    }
1037
1038    my $data;
1039    if(open(FILE, "<$verifyout")) {
1040        while(my $string = <FILE>) {
1041            $data = $string;
1042            last; # only want first line
1043        }
1044        close(FILE);
1045    }
1046
1047    if($data && ($data =~ /RTSP_SERVER WE ROOLZ: (\d+)/)) {
1048        $pid = 0+$1;
1049    }
1050    elsif($res == 6) {
1051        # curl: (6) Couldn't resolve host '::1'
1052        logmsg "RUN: failed to resolve host ($proto://$ip:$port/verifiedserver)\n";
1053        return -1;
1054    }
1055    elsif($data || ($res != 7)) {
1056        logmsg "RUN: Unknown server on our $server port: $port\n";
1057        return -1;
1058    }
1059    return $pid;
1060}
1061
1062#######################################################################
1063# Verify that the ssh server has written out its pidfile, recovering
1064# the pid from the file and returning it if a process with that pid is
1065# actually alive.
1066#
1067sub verifyssh {
1068    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1069    my $server = servername_id($proto, $ipvnum, $idnum);
1070    my $pidfile = server_pidfilename($proto, $ipvnum, $idnum);
1071    my $pid = 0;
1072    if(open(FILE, "<$pidfile")) {
1073        $pid=0+<FILE>;
1074        close(FILE);
1075    }
1076    if($pid > 0) {
1077        # if we have a pid it is actually our ssh server,
1078        # since runsshserver() unlinks previous pidfile
1079        if(!pidexists($pid)) {
1080            logmsg "RUN: SSH server has died after starting up\n";
1081            checkdied($pid);
1082            unlink($pidfile);
1083            $pid = -1;
1084        }
1085    }
1086    return $pid;
1087}
1088
1089#######################################################################
1090# Verify that we can connect to the sftp server, properly authenticate
1091# with generated config and key files and run a simple remote pwd.
1092#
1093sub verifysftp {
1094    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1095    my $server = servername_id($proto, $ipvnum, $idnum);
1096    my $verified = 0;
1097    # Find out sftp client canonical file name
1098    my $sftp = find_sftp();
1099    if(!$sftp) {
1100        logmsg "RUN: SFTP server cannot find $sftpexe\n";
1101        return -1;
1102    }
1103    # Find out ssh client canonical file name
1104    my $ssh = find_ssh();
1105    if(!$ssh) {
1106        logmsg "RUN: SFTP server cannot find $sshexe\n";
1107        return -1;
1108    }
1109    # Connect to sftp server, authenticate and run a remote pwd
1110    # command using our generated configuration and key files
1111    my $cmd = "\"$sftp\" -b $sftpcmds -F $sftpconfig -S \"$ssh\" $ip > $sftplog 2>&1";
1112    my $res = runclient($cmd);
1113    # Search for pwd command response in log file
1114    if(open(SFTPLOGFILE, "<$sftplog")) {
1115        while(<SFTPLOGFILE>) {
1116            if(/^Remote working directory: /) {
1117                $verified = 1;
1118                last;
1119            }
1120        }
1121        close(SFTPLOGFILE);
1122    }
1123    return $verified;
1124}
1125
1126#######################################################################
1127# Verify that the non-stunnel HTTP TLS extensions capable server that runs
1128# on $ip, $port is our server.  This also implies that we can speak with it,
1129# as there might be occasions when the server runs fine but we cannot talk
1130# to it ("Failed to connect to ::1: Can't assign requested address")
1131#
1132sub verifyhttptls {
1133    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1134    my $server = servername_id($proto, $ipvnum, $idnum);
1135    my $pidfile = server_pidfilename($proto, $ipvnum, $idnum);
1136    my $pid = 0;
1137
1138    my $verifyout = "$LOGDIR/".
1139        servername_canon($proto, $ipvnum, $idnum) .'_verify.out';
1140    unlink($verifyout) if(-f $verifyout);
1141
1142    my $verifylog = "$LOGDIR/".
1143        servername_canon($proto, $ipvnum, $idnum) .'_verify.log';
1144    unlink($verifylog) if(-f $verifylog);
1145
1146    my $flags = "--max-time $server_response_maxtime ";
1147    $flags .= "--output $verifyout ";
1148    $flags .= "--verbose ";
1149    $flags .= "--globoff ";
1150    $flags .= "--insecure ";
1151    $flags .= "--tlsauthtype SRP ";
1152    $flags .= "--tlsuser jsmith ";
1153    $flags .= "--tlspassword abc ";
1154    $flags .= "\"https://$ip:$port/verifiedserver\"";
1155
1156    my $cmd = "$VCURL $flags 2>$verifylog";
1157
1158    # verify if our/any server is running on this port
1159    logmsg "RUN: $cmd\n" if($verbose);
1160    my $res = runclient($cmd);
1161
1162    $res >>= 8; # rotate the result
1163    if($res & 128) {
1164        logmsg "RUN: curl command died with a coredump\n";
1165        return -1;
1166    }
1167
1168    if($res && $verbose) {
1169        logmsg "RUN: curl command returned $res\n";
1170        if(open(FILE, "<$verifylog")) {
1171            while(my $string = <FILE>) {
1172                logmsg "RUN: $string" if($string !~ /^([ \t]*)$/);
1173            }
1174            close(FILE);
1175        }
1176    }
1177
1178    my $data;
1179    if(open(FILE, "<$verifyout")) {
1180        while(my $string = <FILE>) {
1181            $data .= $string;
1182        }
1183        close(FILE);
1184    }
1185
1186    if($data && ($data =~ /(GNUTLS|GnuTLS)/) && open(FILE, "<$pidfile")) {
1187        $pid=0+<FILE>;
1188        close(FILE);
1189        if($pid > 0) {
1190            # if we have a pid it is actually our httptls server,
1191            # since runhttptlsserver() unlinks previous pidfile
1192            if(!pidexists($pid)) {
1193                logmsg "RUN: $server server has died after starting up\n";
1194                checkdied($pid);
1195                unlink($pidfile);
1196                $pid = -1;
1197            }
1198        }
1199        return $pid;
1200    }
1201    elsif($res == 6) {
1202        # curl: (6) Couldn't resolve host '::1'
1203        logmsg "RUN: failed to resolve host (https://$ip:$port/verifiedserver)\n";
1204        return -1;
1205    }
1206    elsif($data || ($res && ($res != 7))) {
1207        logmsg "RUN: Unknown server on our $server port: $port ($res)\n";
1208        return -1;
1209    }
1210    return $pid;
1211}
1212
1213#######################################################################
1214# STUB for verifying socks
1215#
1216sub verifysocks {
1217    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1218    my $server = servername_id($proto, $ipvnum, $idnum);
1219    my $pidfile = server_pidfilename($proto, $ipvnum, $idnum);
1220    my $pid = 0;
1221    if(open(FILE, "<$pidfile")) {
1222        $pid=0+<FILE>;
1223        close(FILE);
1224    }
1225    if($pid > 0) {
1226        # if we have a pid it is actually our socks server,
1227        # since runsocksserver() unlinks previous pidfile
1228        if(!pidexists($pid)) {
1229            logmsg "RUN: SOCKS server has died after starting up\n";
1230            checkdied($pid);
1231            unlink($pidfile);
1232            $pid = -1;
1233        }
1234    }
1235    return $pid;
1236}
1237
1238#######################################################################
1239# Verify that the server that runs on $ip, $port is our server.  This also
1240# implies that we can speak with it, as there might be occasions when the
1241# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't
1242# assign requested address")
1243#
1244sub verifysmb {
1245    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1246    my $server = servername_id($proto, $ipvnum, $idnum);
1247    my $pid = 0;
1248    my $time=time();
1249    my $extra="";
1250
1251    my $verifylog = "$LOGDIR/".
1252        servername_canon($proto, $ipvnum, $idnum) .'_verify.log';
1253    unlink($verifylog) if(-f $verifylog);
1254
1255    my $flags = "--max-time $server_response_maxtime ";
1256    $flags .= "--silent ";
1257    $flags .= "--verbose ";
1258    $flags .= "--globoff ";
1259    $flags .= "-u 'curltest:curltest' ";
1260    $flags .= $extra;
1261    $flags .= "\"$proto://$ip:$port/SERVER/verifiedserver\"";
1262
1263    my $cmd = "$VCURL $flags 2>$verifylog";
1264
1265    # check if this is our server running on this port:
1266    logmsg "RUN: $cmd\n" if($verbose);
1267    my @data = runclientoutput($cmd);
1268
1269    my $res = $? >> 8; # rotate the result
1270    if($res & 128) {
1271        logmsg "RUN: curl command died with a coredump\n";
1272        return -1;
1273    }
1274
1275    foreach my $line (@data) {
1276        if($line =~ /WE ROOLZ: (\d+)/) {
1277            # this is our test server with a known pid!
1278            $pid = 0+$1;
1279            last;
1280        }
1281    }
1282    if($pid <= 0 && @data && $data[0]) {
1283        # this is not a known server
1284        logmsg "RUN: Unknown server on our $server port: $port\n";
1285        return 0;
1286    }
1287    # we can/should use the time it took to verify the server as a measure
1288    # on how fast/slow this host is.
1289    my $took = int(0.5+time()-$time);
1290
1291    if($verbose) {
1292        logmsg "RUN: Verifying our test $server server took $took seconds\n";
1293    }
1294    $ftpchecktime = $took>=1?$took:1; # make sure it never is below 1
1295
1296    return $pid;
1297}
1298
1299#######################################################################
1300# Verify that the server that runs on $ip, $port is our server.  This also
1301# implies that we can speak with it, as there might be occasions when the
1302# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't
1303# assign requested address")
1304#
1305sub verifytelnet {
1306    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1307    my $server = servername_id($proto, $ipvnum, $idnum);
1308    my $pid = 0;
1309    my $time=time();
1310    my $extra="";
1311
1312    my $verifylog = "$LOGDIR/".
1313        servername_canon($proto, $ipvnum, $idnum) .'_verify.log';
1314    unlink($verifylog) if(-f $verifylog);
1315
1316    my $flags = "--max-time $server_response_maxtime ";
1317    $flags .= "--silent ";
1318    $flags .= "--verbose ";
1319    $flags .= "--globoff ";
1320    $flags .= "--upload-file - ";
1321    $flags .= $extra;
1322    $flags .= "\"$proto://$ip:$port\"";
1323
1324    my $cmd = "echo 'verifiedserver' | $VCURL $flags 2>$verifylog";
1325
1326    # check if this is our server running on this port:
1327    logmsg "RUN: $cmd\n" if($verbose);
1328    my @data = runclientoutput($cmd);
1329
1330    my $res = $? >> 8; # rotate the result
1331    if($res & 128) {
1332        logmsg "RUN: curl command died with a coredump\n";
1333        return -1;
1334    }
1335
1336    foreach my $line (@data) {
1337        if($line =~ /WE ROOLZ: (\d+)/) {
1338            # this is our test server with a known pid!
1339            $pid = 0+$1;
1340            last;
1341        }
1342    }
1343    if($pid <= 0 && @data && $data[0]) {
1344        # this is not a known server
1345        logmsg "RUN: Unknown server on our $server port: $port\n";
1346        return 0;
1347    }
1348    # we can/should use the time it took to verify the server as a measure
1349    # on how fast/slow this host is.
1350    my $took = int(0.5+time()-$time);
1351
1352    if($verbose) {
1353        logmsg "RUN: Verifying our test $server server took $took seconds\n";
1354    }
1355
1356    return $pid;
1357}
1358
1359
1360#######################################################################
1361# Verify that the server that runs on $ip, $port is our server.
1362# Retry over several seconds before giving up.  The ssh server in
1363# particular can take a long time to start if it needs to generate
1364# keys on a slow or loaded host.
1365#
1366# Just for convenience, test harness uses 'https' and 'httptls' literals
1367# as values for 'proto' variable in order to differentiate different
1368# servers. 'https' literal is used for stunnel based https test servers,
1369# and 'httptls' is used for non-stunnel https test servers.
1370#
1371
1372my %protofunc = ('http' => \&verifyhttp,
1373                 'https' => \&verifyhttp,
1374                 'rtsp' => \&verifyrtsp,
1375                 'ftp' => \&verifyftp,
1376                 'pop3' => \&verifyftp,
1377                 'imap' => \&verifyftp,
1378                 'smtp' => \&verifyftp,
1379                 'ftps' => \&verifyftp,
1380                 'tftp' => \&verifyftp,
1381                 'ssh' => \&verifyssh,
1382                 'socks' => \&verifysocks,
1383                 'gopher' => \&verifyhttp,
1384                 'httptls' => \&verifyhttptls,
1385                 'dict' => \&verifyftp,
1386                 'smb' => \&verifysmb,
1387                 'telnet' => \&verifytelnet);
1388
1389sub verifyserver {
1390    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1391
1392    my $count = 30; # try for this many seconds
1393    my $pid;
1394
1395    while($count--) {
1396        my $fun = $protofunc{$proto};
1397
1398        $pid = &$fun($proto, $ipvnum, $idnum, $ip, $port);
1399
1400        if($pid > 0) {
1401            last;
1402        }
1403        elsif($pid < 0) {
1404            # a real failure, stop trying and bail out
1405            return 0;
1406        }
1407        sleep(1);
1408    }
1409    return $pid;
1410}
1411
1412#######################################################################
1413# Single shot server responsiveness test. This should only be used
1414# to verify that a server present in %run hash is still functional
1415#
1416sub responsiveserver {
1417    my ($proto, $ipvnum, $idnum, $ip, $port) = @_;
1418    my $prev_verbose = $verbose;
1419
1420    $verbose = 0;
1421    my $fun = $protofunc{$proto};
1422    my $pid = &$fun($proto, $ipvnum, $idnum, $ip, $port);
1423    $verbose = $prev_verbose;
1424
1425    if($pid > 0) {
1426        return 1; # responsive
1427    }
1428
1429    my $srvrname = servername_str($proto, $ipvnum, $idnum);
1430    logmsg " server precheck FAILED (unresponsive $srvrname server)\n";
1431    return 0;
1432}
1433
1434#######################################################################
1435# start the http2 server
1436#
1437sub runhttp2server {
1438    my ($verbose) = @_;
1439    my $server;
1440    my $srvrname;
1441    my $pidfile;
1442    my $logfile;
1443    my $flags = "";
1444    my $proto="http/2";
1445    my $ipvnum = 4;
1446    my $idnum = 0;
1447    my $exe = "$perl $srcdir/http2-server.pl";
1448    my $verbose_flag = "--verbose ";
1449
1450    $server = servername_id($proto, $ipvnum, $idnum);
1451
1452    $pidfile = $serverpidfile{$server};
1453
1454    # don't retry if the server doesn't work
1455    if ($doesntrun{$pidfile}) {
1456        return (0, 0, 0);
1457    }
1458
1459    my $pid = processexists($pidfile);
1460    if($pid > 0) {
1461        stopserver($server, "$pid");
1462    }
1463    unlink($pidfile) if(-f $pidfile);
1464
1465    $srvrname = servername_str($proto, $ipvnum, $idnum);
1466
1467    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
1468
1469    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
1470    $flags .= "--connect $HOSTIP:$HTTPPORT ";
1471    $flags .= $verbose_flag if($debugprotocol);
1472
1473    my ($http2pid, $pid2);
1474    my $port = 23113;
1475    for(1 .. 10) {
1476        $port += int(rand(900));
1477        my $aflags = "--port $port $flags";
1478
1479        my $cmd = "$exe $aflags";
1480        ($http2pid, $pid2) = startnew($cmd, $pidfile, 15, 0);
1481
1482        if($http2pid <= 0 || !pidexists($http2pid)) {
1483            # it is NOT alive
1484            stopserver($server, "$pid2");
1485            $doesntrun{$pidfile} = 1;
1486            $http2pid = $pid2 = 0;
1487            next;
1488        }
1489        $doesntrun{$pidfile} = 0;
1490
1491        if($verbose) {
1492            logmsg "RUN: $srvrname server PID $http2pid port $port\n";
1493        }
1494        last;
1495    }
1496
1497    logmsg "RUN: failed to start the $srvrname server\n" if(!$http2pid);
1498
1499    return ($http2pid, $pid2, $port);
1500}
1501
1502#######################################################################
1503# start the http server
1504#
1505sub runhttpserver {
1506    my ($proto, $verbose, $alt, $port_or_path) = @_;
1507    my $ip = $HOSTIP;
1508    my $ipvnum = 4;
1509    my $idnum = 1;
1510    my $server;
1511    my $srvrname;
1512    my $pidfile;
1513    my $logfile;
1514    my $flags = "";
1515    my $exe = "$perl $srcdir/httpserver.pl";
1516    my $verbose_flag = "--verbose ";
1517
1518    if($alt eq "ipv6") {
1519        # if IPv6, use a different setup
1520        $ipvnum = 6;
1521        $ip = $HOST6IP;
1522    }
1523    elsif($alt eq "proxy") {
1524        # basically the same, but another ID
1525        $idnum = 2;
1526    }
1527    elsif($alt eq "unix") {
1528        # IP (protocol) is mutually exclusive with Unix sockets
1529        $ipvnum = "unix";
1530    }
1531
1532    $server = servername_id($proto, $ipvnum, $idnum);
1533
1534    $pidfile = $serverpidfile{$server};
1535    my $portfile = $serverportfile{$server};
1536
1537    # don't retry if the server doesn't work
1538    if ($doesntrun{$pidfile}) {
1539        return (0, 0, 0);
1540    }
1541
1542    my $pid = processexists($pidfile);
1543    if($pid > 0) {
1544        stopserver($server, "$pid");
1545    }
1546    unlink($pidfile) if(-f $pidfile);
1547
1548    $srvrname = servername_str($proto, $ipvnum, $idnum);
1549
1550    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
1551
1552    $flags .= "--gopher " if($proto eq "gopher");
1553    $flags .= "--connect $HOSTIP " if($alt eq "proxy");
1554    $flags .= $verbose_flag if($debugprotocol);
1555    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
1556    $flags .= "--portfile $portfile ";
1557    $flags .= "--id $idnum " if($idnum > 1);
1558    if($ipvnum eq "unix") {
1559        $flags .= "--unix-socket '$port_or_path' ";
1560    } else {
1561        $flags .= "--ipv$ipvnum --port 0 ";
1562    }
1563    $flags .= "--srcdir \"$srcdir\"";
1564
1565    my $cmd = "$exe $flags";
1566    my ($httppid, $pid2) = startnew($cmd, $pidfile, 15, 0);
1567
1568    if($httppid <= 0 || !pidexists($httppid)) {
1569        # it is NOT alive
1570        logmsg "RUN: failed to start the $srvrname server\n";
1571        stopserver($server, "$pid2");
1572        displaylogs($testnumcheck);
1573        $doesntrun{$pidfile} = 1;
1574        return (0, 0, 0);
1575    }
1576
1577    # where is it?
1578    my $port;
1579    if(!$port_or_path) {
1580        $port = $port_or_path = pidfromfile($portfile);
1581    }
1582
1583    # Server is up. Verify that we can speak to it.
1584    my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port_or_path);
1585    if(!$pid3) {
1586        logmsg "RUN: $srvrname server failed verification\n";
1587        # failed to talk to it properly. Kill the server and return failure
1588        stopserver($server, "$httppid $pid2");
1589        displaylogs($testnumcheck);
1590        $doesntrun{$pidfile} = 1;
1591        return (0, 0, 0);
1592    }
1593    $pid2 = $pid3;
1594
1595    if($verbose) {
1596        logmsg "RUN: $srvrname server is on PID $httppid port $port\n";
1597    }
1598
1599    return ($httppid, $pid2, $port);
1600}
1601
1602#######################################################################
1603# start the https stunnel based server
1604#
1605sub runhttpsserver {
1606    my ($verbose, $proto, $proxy, $certfile) = @_;
1607    my $ip = $HOSTIP;
1608    my $ipvnum = 4;
1609    my $idnum = 1;
1610    my $server;
1611    my $srvrname;
1612    my $pidfile;
1613    my $logfile;
1614    my $flags = "";
1615
1616    if($proxy eq "proxy") {
1617        # the https-proxy runs as https2
1618        $idnum = 2;
1619    }
1620
1621    if(!$stunnel) {
1622        return (0, 0, 0);
1623    }
1624
1625    $server = servername_id($proto, $ipvnum, $idnum);
1626
1627    $pidfile = $serverpidfile{$server};
1628
1629    # don't retry if the server doesn't work
1630    if ($doesntrun{$pidfile}) {
1631        return (0, 0, 0);
1632    }
1633
1634    my $pid = processexists($pidfile);
1635    if($pid > 0) {
1636        stopserver($server, "$pid");
1637    }
1638    unlink($pidfile) if(-f $pidfile);
1639
1640    $srvrname = servername_str($proto, $ipvnum, $idnum);
1641
1642    $certfile = 'stunnel.pem' unless($certfile);
1643
1644    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
1645
1646    $flags .= "--verbose " if($debugprotocol);
1647    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
1648    $flags .= "--id $idnum " if($idnum > 1);
1649    $flags .= "--ipv$ipvnum --proto $proto ";
1650    $flags .= "--certfile \"$certfile\" " if($certfile ne 'stunnel.pem');
1651    $flags .= "--stunnel \"$stunnel\" --srcdir \"$srcdir\" ";
1652    if($proto eq "gophers") {
1653        $flags .= "--connect $GOPHERPORT";
1654    }
1655    elsif(!$proxy) {
1656        $flags .= "--connect $HTTPPORT";
1657    }
1658    else {
1659        # for HTTPS-proxy we connect to the HTTP proxy
1660        $flags .= "--connect $HTTPPROXYPORT";
1661    }
1662
1663    my $pid2;
1664    my $pid3;
1665    my $httpspid;
1666    my $port = 24512; # start attempt
1667    for (1 .. 10) {
1668        $port += int(rand(600));
1669        my $options = "$flags --accept $port";
1670
1671        my $cmd = "$perl $srcdir/secureserver.pl $options";
1672        ($httpspid, $pid2) = startnew($cmd, $pidfile, 15, 0);
1673
1674        if($httpspid <= 0 || !pidexists($httpspid)) {
1675            # it is NOT alive
1676            stopserver($server, "$pid2");
1677            displaylogs($testnumcheck);
1678            $doesntrun{$pidfile} = 1;
1679            $httpspid = $pid2 = 0;
1680            next;
1681        }
1682        # we have a server!
1683        if($verbose) {
1684            logmsg "RUN: $srvrname server is PID $httpspid port $port\n";
1685        }
1686        last;
1687    }
1688    $runcert{$server} = $certfile;
1689    logmsg "RUN: failed to start the $srvrname server\n" if(!$httpspid);
1690
1691    return ($httpspid, $pid2, $port);
1692}
1693
1694#######################################################################
1695# start the non-stunnel HTTP TLS extensions capable server
1696#
1697sub runhttptlsserver {
1698    my ($verbose, $ipv6) = @_;
1699    my $proto = "httptls";
1700    my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
1701    my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
1702    my $idnum = 1;
1703    my $server;
1704    my $srvrname;
1705    my $pidfile;
1706    my $logfile;
1707    my $flags = "";
1708
1709    if(!$httptlssrv) {
1710        return (0,0);
1711    }
1712
1713    $server = servername_id($proto, $ipvnum, $idnum);
1714
1715    $pidfile = $serverpidfile{$server};
1716
1717    # don't retry if the server doesn't work
1718    if ($doesntrun{$pidfile}) {
1719        return (0, 0, 0);
1720    }
1721
1722    my $pid = processexists($pidfile);
1723    if($pid > 0) {
1724        stopserver($server, "$pid");
1725    }
1726    unlink($pidfile) if(-f $pidfile);
1727
1728    $srvrname = servername_str($proto, $ipvnum, $idnum);
1729
1730    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
1731
1732    $flags .= "--http ";
1733    $flags .= "--debug 1 " if($debugprotocol);
1734    $flags .= "--priority NORMAL:+SRP ";
1735    $flags .= "--srppasswd $srcdir/certs/srp-verifier-db ";
1736    $flags .= "--srppasswdconf $srcdir/certs/srp-verifier-conf";
1737
1738    my $port = 24367;
1739    my ($httptlspid, $pid2);
1740    for (1 .. 10) {
1741        $port += int(rand(800));
1742        my $allflags = "--port $port $flags";
1743
1744        my $cmd = "$httptlssrv $allflags > $logfile 2>&1";
1745        ($httptlspid, $pid2) = startnew($cmd, $pidfile, 10, 1);
1746
1747        if($httptlspid <= 0 || !pidexists($httptlspid)) {
1748            # it is NOT alive
1749            stopserver($server, "$pid2");
1750            displaylogs($testnumcheck);
1751            $doesntrun{$pidfile} = 1;
1752            $httptlspid = $pid2 = 0;
1753            next;
1754        }
1755        $doesntrun{$pidfile} = 0;
1756
1757        if($verbose) {
1758            logmsg "RUN: $srvrname server PID $httptlspid port $port\n";
1759        }
1760        last;
1761    }
1762    logmsg "RUN: failed to start the $srvrname server\n" if(!$httptlspid);
1763    return ($httptlspid, $pid2, $port);
1764}
1765
1766#######################################################################
1767# start the pingpong server (FTP, POP3, IMAP, SMTP)
1768#
1769sub runpingpongserver {
1770    my ($proto, $id, $verbose, $ipv6) = @_;
1771    my $port;
1772    my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
1773    my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
1774    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
1775    my $server;
1776    my $srvrname;
1777    my $pidfile;
1778    my $logfile;
1779    my $flags = "";
1780
1781    $server = servername_id($proto, $ipvnum, $idnum);
1782
1783    $pidfile = $serverpidfile{$server};
1784    my $portfile = $serverportfile{$server};
1785
1786    # don't retry if the server doesn't work
1787    if ($doesntrun{$pidfile}) {
1788        return (0,0);
1789    }
1790
1791    my $pid = processexists($pidfile);
1792    if($pid > 0) {
1793        stopserver($server, "$pid");
1794    }
1795    unlink($pidfile) if(-f $pidfile);
1796
1797    $srvrname = servername_str($proto, $ipvnum, $idnum);
1798
1799    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
1800
1801    $flags .= "--verbose " if($debugprotocol);
1802    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
1803    $flags .= "--portfile \"$portfile\" ";
1804    $flags .= "--srcdir \"$srcdir\" --proto $proto ";
1805    $flags .= "--id $idnum " if($idnum > 1);
1806    $flags .= "--ipv$ipvnum --port 0 --addr \"$ip\"";
1807
1808    my $cmd = "$perl $srcdir/ftpserver.pl $flags";
1809    my ($ftppid, $pid2) = startnew($cmd, $pidfile, 15, 0);
1810
1811    if($ftppid <= 0 || !pidexists($ftppid)) {
1812        # it is NOT alive
1813        logmsg "RUN: failed to start the $srvrname server\n";
1814        stopserver($server, "$pid2");
1815        displaylogs($testnumcheck);
1816        $doesntrun{$pidfile} = 1;
1817        return (0,0);
1818    }
1819
1820    # where is it?
1821    $port = pidfromfile($portfile);
1822
1823    logmsg "PINGPONG runs on port $port ($portfile)\n" if($verbose);
1824
1825    # Server is up. Verify that we can speak to it.
1826    my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port);
1827    if(!$pid3) {
1828        logmsg "RUN: $srvrname server failed verification\n";
1829        # failed to talk to it properly. Kill the server and return failure
1830        stopserver($server, "$ftppid $pid2");
1831        displaylogs($testnumcheck);
1832        $doesntrun{$pidfile} = 1;
1833        return (0,0);
1834    }
1835
1836    $pid2 = $pid3;
1837
1838    logmsg "RUN: $srvrname server is PID $ftppid port $port\n" if($verbose);
1839
1840    # Assign the correct port variable!
1841    if($proto eq "ftp") {
1842        if($ipvnum == 6) {
1843            # if IPv6, use a different setup
1844            $FTP6PORT = $port;
1845        }
1846        else {
1847            $FTPPORT = $port;
1848        }
1849    }
1850    elsif($proto eq "pop3") {
1851        if($ipvnum == 6) {
1852            $POP36PORT = $port;
1853        }
1854        else {
1855            $POP3PORT = $port;
1856        }
1857    }
1858    elsif($proto eq "imap") {
1859        if($ipvnum == 6) {
1860            $IMAP6PORT  = $port;
1861        }
1862        else {
1863            $IMAPPORT = $port;
1864        }
1865    }
1866    elsif($proto eq "smtp") {
1867        if($ipvnum == 6) {
1868            $SMTP6PORT = $port;
1869        }
1870        else {
1871            $SMTPPORT = $port;
1872        }
1873    }
1874    else {
1875        print STDERR "Unsupported protocol $proto!!\n";
1876        return (0,0);
1877    }
1878
1879    return ($pid2, $ftppid);
1880}
1881
1882#######################################################################
1883# start the ftps server (or rather, tunnel)
1884#
1885sub runftpsserver {
1886    my ($verbose, $ipv6, $certfile) = @_;
1887    my $proto = 'ftps';
1888    my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
1889    my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
1890    my $idnum = 1;
1891    my $server;
1892    my $srvrname;
1893    my $pidfile;
1894    my $logfile;
1895    my $flags = "";
1896
1897    if(!$stunnel) {
1898        return (0,0);
1899    }
1900
1901    $server = servername_id($proto, $ipvnum, $idnum);
1902
1903    $pidfile = $serverpidfile{$server};
1904
1905    # don't retry if the server doesn't work
1906    if ($doesntrun{$pidfile}) {
1907        return (0, 0, 0);
1908    }
1909
1910    my $pid = processexists($pidfile);
1911    if($pid > 0) {
1912        stopserver($server, "$pid");
1913    }
1914    unlink($pidfile) if(-f $pidfile);
1915
1916    $srvrname = servername_str($proto, $ipvnum, $idnum);
1917
1918    $certfile = 'stunnel.pem' unless($certfile);
1919
1920    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
1921
1922    $flags .= "--verbose " if($debugprotocol);
1923    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
1924    $flags .= "--id $idnum " if($idnum > 1);
1925    $flags .= "--ipv$ipvnum --proto $proto ";
1926    $flags .= "--certfile \"$certfile\" " if($certfile ne 'stunnel.pem');
1927    $flags .= "--stunnel \"$stunnel\" --srcdir \"$srcdir\" ";
1928    $flags .= "--connect $FTPPORT";
1929
1930    my $port = 26713;
1931    my $pid2;
1932    my $pid3;
1933    my $ftpspid;
1934    for (1 .. 10) {
1935        $port += int(rand(700));
1936        my $options = "$flags --accept $port";
1937        my $cmd = "$perl $srcdir/secureserver.pl $options";
1938        ($ftpspid, $pid2) = startnew($cmd, $pidfile, 15, 0);
1939
1940        if($ftpspid <= 0 || !pidexists($ftpspid)) {
1941            # it is NOT alive
1942            stopserver($server, "$pid2");
1943            displaylogs($testnumcheck);
1944            $doesntrun{$pidfile} = 1;
1945            $ftpspid = $pid2 = 0;
1946            next;
1947        }
1948
1949        $doesntrun{$pidfile} = 0;
1950        $runcert{$server} = $certfile;
1951
1952        if($verbose) {
1953            logmsg "RUN: $srvrname server is PID $ftpspid port $port\n";
1954        }
1955        last;
1956    }
1957
1958    logmsg "RUN: failed to start the $srvrname server\n" if(!$ftpspid);
1959
1960    return ($ftpspid, $pid2, $port);
1961}
1962
1963#######################################################################
1964# start the tftp server
1965#
1966sub runtftpserver {
1967    my ($id, $verbose, $ipv6) = @_;
1968    my $ip = $HOSTIP;
1969    my $proto = 'tftp';
1970    my $ipvnum = 4;
1971    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
1972    my $server;
1973    my $srvrname;
1974    my $pidfile;
1975    my $logfile;
1976    my $flags = "";
1977
1978    if($ipv6) {
1979        # if IPv6, use a different setup
1980        $ipvnum = 6;
1981        $ip = $HOST6IP;
1982    }
1983
1984    $server = servername_id($proto, $ipvnum, $idnum);
1985
1986    $pidfile = $serverpidfile{$server};
1987    my $portfile = $serverportfile{$server};
1988
1989    # don't retry if the server doesn't work
1990    if ($doesntrun{$pidfile}) {
1991        return (0, 0, 0);
1992    }
1993
1994    my $pid = processexists($pidfile);
1995    if($pid > 0) {
1996        stopserver($server, "$pid");
1997    }
1998    unlink($pidfile) if(-f $pidfile);
1999
2000    $srvrname = servername_str($proto, $ipvnum, $idnum);
2001
2002    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2003
2004    $flags .= "--verbose " if($debugprotocol);
2005    $flags .= "--pidfile \"$pidfile\" ".
2006        "--portfile \"$portfile\" ".
2007        "--logfile \"$logfile\" ";
2008    $flags .= "--id $idnum " if($idnum > 1);
2009    $flags .= "--ipv$ipvnum --port 0 --srcdir \"$srcdir\"";
2010
2011    my $cmd = "$perl $srcdir/tftpserver.pl $flags";
2012    my ($tftppid, $pid2) = startnew($cmd, $pidfile, 15, 0);
2013
2014    if($tftppid <= 0 || !pidexists($tftppid)) {
2015        # it is NOT alive
2016        logmsg "RUN: failed to start the $srvrname server\n";
2017        stopserver($server, "$pid2");
2018        displaylogs($testnumcheck);
2019        $doesntrun{$pidfile} = 1;
2020        return (0, 0, 0);
2021    }
2022
2023    my $port = pidfromfile($portfile);
2024
2025    # Server is up. Verify that we can speak to it.
2026    my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port);
2027    if(!$pid3) {
2028        logmsg "RUN: $srvrname server failed verification\n";
2029        # failed to talk to it properly. Kill the server and return failure
2030        stopserver($server, "$tftppid $pid2");
2031        displaylogs($testnumcheck);
2032        $doesntrun{$pidfile} = 1;
2033        return (0, 0, 0);
2034    }
2035    $pid2 = $pid3;
2036
2037    if($verbose) {
2038        logmsg "RUN: $srvrname server on PID $tftppid port $port\n";
2039    }
2040
2041    return ($pid2, $tftppid, $port);
2042}
2043
2044
2045#######################################################################
2046# start the rtsp server
2047#
2048sub runrtspserver {
2049    my ($verbose, $ipv6) = @_;
2050    my $ip = $HOSTIP;
2051    my $proto = 'rtsp';
2052    my $ipvnum = 4;
2053    my $idnum = 1;
2054    my $server;
2055    my $srvrname;
2056    my $pidfile;
2057    my $logfile;
2058    my $flags = "";
2059
2060    if($ipv6) {
2061        # if IPv6, use a different setup
2062        $ipvnum = 6;
2063        $ip = $HOST6IP;
2064    }
2065
2066    $server = servername_id($proto, $ipvnum, $idnum);
2067
2068    $pidfile = $serverpidfile{$server};
2069    my $portfile = $serverportfile{$server};
2070
2071    # don't retry if the server doesn't work
2072    if ($doesntrun{$pidfile}) {
2073        return (0, 0, 0);
2074    }
2075
2076    my $pid = processexists($pidfile);
2077    if($pid > 0) {
2078        stopserver($server, "$pid");
2079    }
2080    unlink($pidfile) if(-f $pidfile);
2081
2082    $srvrname = servername_str($proto, $ipvnum, $idnum);
2083
2084    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2085
2086    $flags .= "--verbose " if($debugprotocol);
2087    $flags .= "--pidfile \"$pidfile\" ".
2088         "--portfile \"$portfile\" ".
2089        "--logfile \"$logfile\" ";
2090    $flags .= "--id $idnum " if($idnum > 1);
2091    $flags .= "--ipv$ipvnum --port 0 --srcdir \"$srcdir\"";
2092
2093    my $cmd = "$perl $srcdir/rtspserver.pl $flags";
2094    my ($rtsppid, $pid2) = startnew($cmd, $pidfile, 15, 0);
2095
2096    if($rtsppid <= 0 || !pidexists($rtsppid)) {
2097        # it is NOT alive
2098        logmsg "RUN: failed to start the $srvrname server\n";
2099        stopserver($server, "$pid2");
2100        displaylogs($testnumcheck);
2101        $doesntrun{$pidfile} = 1;
2102        return (0, 0, 0);
2103    }
2104
2105    my $port = pidfromfile($portfile);
2106
2107    # Server is up. Verify that we can speak to it.
2108    my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port);
2109    if(!$pid3) {
2110        logmsg "RUN: $srvrname server failed verification\n";
2111        # failed to talk to it properly. Kill the server and return failure
2112        stopserver($server, "$rtsppid $pid2");
2113        displaylogs($testnumcheck);
2114        $doesntrun{$pidfile} = 1;
2115        return (0, 0, 0);
2116    }
2117    $pid2 = $pid3;
2118
2119    if($verbose) {
2120        logmsg "RUN: $srvrname server PID $rtsppid port $port\n";
2121    }
2122
2123    return ($rtsppid, $pid2, $port);
2124}
2125
2126
2127#######################################################################
2128# Start the ssh (scp/sftp) server
2129#
2130sub runsshserver {
2131    my ($id, $verbose, $ipv6) = @_;
2132    my $ip=$HOSTIP;
2133    my $proto = 'ssh';
2134    my $ipvnum = 4;
2135    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
2136    my $server;
2137    my $srvrname;
2138    my $pidfile;
2139    my $logfile;
2140    my $port = 20000; # no lower port
2141
2142    $server = servername_id($proto, $ipvnum, $idnum);
2143
2144    $pidfile = $serverpidfile{$server};
2145
2146    # don't retry if the server doesn't work
2147    if ($doesntrun{$pidfile}) {
2148        return (0, 0, 0);
2149    }
2150
2151    my $sshd = find_sshd();
2152    if($sshd) {
2153        ($sshdid,$sshdvernum,$sshdverstr,$sshderror) = sshversioninfo($sshd);
2154    }
2155
2156    my $pid = processexists($pidfile);
2157    if($pid > 0) {
2158        stopserver($server, "$pid");
2159    }
2160    unlink($pidfile) if(-f $pidfile);
2161
2162    $srvrname = servername_str($proto, $ipvnum, $idnum);
2163
2164    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2165
2166    my $flags = "";
2167    $flags .= "--verbose " if($verbose);
2168    $flags .= "--debugprotocol " if($debugprotocol);
2169    $flags .= "--pidfile \"$pidfile\" ";
2170    $flags .= "--id $idnum " if($idnum > 1);
2171    $flags .= "--ipv$ipvnum --addr \"$ip\" ";
2172    $flags .= "--user \"$USER\"";
2173
2174    my $sshpid;
2175    my $pid2;
2176
2177    my $wport = 0,
2178    my @tports;
2179    for(1 .. 10) {
2180
2181        # sshd doesn't have a way to pick an unused random port number, so
2182        # instead we iterate over possible port numbers to use until we find
2183        # one that works
2184        $port += int(rand(500));
2185        push @tports, $port;
2186
2187        my $options = "$flags --sshport $port";
2188
2189        my $cmd = "$perl $srcdir/sshserver.pl $options";
2190        ($sshpid, $pid2) = startnew($cmd, $pidfile, 60, 0);
2191
2192        # on loaded systems sshserver start up can take longer than the
2193        # timeout passed to startnew, when this happens startnew completes
2194        # without being able to read the pidfile and consequently returns a
2195        # zero pid2 above.
2196        if($sshpid <= 0 || !pidexists($sshpid)) {
2197            # it is NOT alive
2198            stopserver($server, "$pid2");
2199            $doesntrun{$pidfile} = 1;
2200            $sshpid = $pid2 = 0;
2201            next;
2202        }
2203
2204        # once it is known that the ssh server is alive, sftp server
2205        # verification is performed actually connecting to it, authenticating
2206        # and performing a very simple remote command.  This verification is
2207        # tried only one time.
2208
2209        $sshdlog = server_logfilename($LOGDIR, 'ssh', $ipvnum, $idnum);
2210        $sftplog = server_logfilename($LOGDIR, 'sftp', $ipvnum, $idnum);
2211
2212        if(verifysftp('sftp', $ipvnum, $idnum, $ip, $port) < 1) {
2213            logmsg "RUN: SFTP server failed verification\n";
2214            # failed to talk to it properly. Kill the server and return failure
2215            display_sftplog();
2216            display_sftpconfig();
2217            display_sshdlog();
2218            display_sshdconfig();
2219            stopserver($server, "$sshpid $pid2");
2220            $doesntrun{$pidfile} = 1;
2221            $sshpid = $pid2 = 0;
2222            next;
2223        }
2224        # we're happy, no need to loop anymore!
2225        $doesntrun{$pidfile} = 0;
2226        $wport = $port;
2227        last;
2228    }
2229    logmsg "RUN: failed to start the $srvrname server on $port\n" if(!$sshpid);
2230
2231    if(!$wport) {
2232        logmsg "RUN: couldn't start $srvrname. Tried these ports:";
2233        logmsg "RUN: ".join(", ", @tports);
2234        return (0,0,0);
2235    }
2236
2237    my $hstpubmd5f = "curl_host_rsa_key.pub_md5";
2238    if(!open(PUBMD5FILE, "<", $hstpubmd5f) ||
2239       (read(PUBMD5FILE, $SSHSRVMD5, 32) != 32) ||
2240       !close(PUBMD5FILE) ||
2241       ($SSHSRVMD5 !~ /^[a-f0-9]{32}$/i))
2242    {
2243        my $msg = "Fatal: $srvrname pubkey md5 missing : \"$hstpubmd5f\" : $!";
2244        logmsg "$msg\n";
2245        stopservers($verbose);
2246        die $msg;
2247    }
2248
2249    logmsg "RUN: $srvrname on PID $pid2 port $wport\n" if($verbose);
2250
2251    return ($pid2, $sshpid, $wport);
2252}
2253
2254#######################################################################
2255# Start the MQTT server
2256#
2257sub runmqttserver {
2258    my ($id, $verbose, $ipv6) = @_;
2259    my $ip=$HOSTIP;
2260    my $port = $MQTTPORT;
2261    my $proto = 'mqtt';
2262    my $ipvnum = 4;
2263    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
2264    my $server;
2265    my $srvrname;
2266    my $pidfile;
2267    my $portfile;
2268    my $logfile;
2269    my $flags = "";
2270
2271    $server = servername_id($proto, $ipvnum, $idnum);
2272    $pidfile = $serverpidfile{$server};
2273    $portfile = $serverportfile{$server};
2274
2275    # don't retry if the server doesn't work
2276    if ($doesntrun{$pidfile}) {
2277        return (0,0);
2278    }
2279
2280    my $pid = processexists($pidfile);
2281    if($pid > 0) {
2282        stopserver($server, "$pid");
2283    }
2284    unlink($pidfile) if(-f $pidfile);
2285
2286    $srvrname = servername_str($proto, $ipvnum, $idnum);
2287
2288    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2289
2290    # start our MQTT server - on a random port!
2291    my $cmd="server/mqttd".exe_ext('SRV').
2292        " --port 0 ".
2293        " --pidfile $pidfile".
2294        " --portfile $portfile".
2295        " --config $FTPDCMD";
2296    my ($sockspid, $pid2) = startnew($cmd, $pidfile, 30, 0);
2297
2298    if($sockspid <= 0 || !pidexists($sockspid)) {
2299        # it is NOT alive
2300        logmsg "RUN: failed to start the $srvrname server\n";
2301        stopserver($server, "$pid2");
2302        $doesntrun{$pidfile} = 1;
2303        return (0,0);
2304    }
2305
2306    $MQTTPORT = pidfromfile($portfile);
2307
2308    if($verbose) {
2309        logmsg "RUN: $srvrname server is now running PID $pid2 on PORT $MQTTPORT\n";
2310    }
2311
2312    return ($pid2, $sockspid);
2313}
2314
2315#######################################################################
2316# Start the socks server
2317#
2318sub runsocksserver {
2319    my ($id, $verbose, $ipv6) = @_;
2320    my $ip=$HOSTIP;
2321    my $proto = 'socks';
2322    my $ipvnum = 4;
2323    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
2324    my $server;
2325    my $srvrname;
2326    my $pidfile;
2327    my $logfile;
2328    my $flags = "";
2329
2330    $server = servername_id($proto, $ipvnum, $idnum);
2331
2332    $pidfile = $serverpidfile{$server};
2333    my $portfile = $serverportfile{$server};
2334
2335    # don't retry if the server doesn't work
2336    if ($doesntrun{$pidfile}) {
2337        return (0, 0, 0);
2338    }
2339
2340    my $pid = processexists($pidfile);
2341    if($pid > 0) {
2342        stopserver($server, "$pid");
2343    }
2344    unlink($pidfile) if(-f $pidfile);
2345
2346    $srvrname = servername_str($proto, $ipvnum, $idnum);
2347
2348    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2349
2350    # start our socks server, get commands from the FTP cmd file
2351    my $cmd="server/socksd".exe_ext('SRV').
2352        " --port 0 ".
2353        " --pidfile $pidfile".
2354        " --portfile $portfile".
2355        " --backend $HOSTIP".
2356        " --config $FTPDCMD";
2357    my ($sockspid, $pid2) = startnew($cmd, $pidfile, 30, 0);
2358
2359    if($sockspid <= 0 || !pidexists($sockspid)) {
2360        # it is NOT alive
2361        logmsg "RUN: failed to start the $srvrname server\n";
2362        stopserver($server, "$pid2");
2363        $doesntrun{$pidfile} = 1;
2364        return (0, 0, 0);
2365    }
2366
2367    my $port = pidfromfile($portfile);
2368
2369    if($verbose) {
2370        logmsg "RUN: $srvrname server is now running PID $pid2\n";
2371    }
2372
2373    return ($pid2, $sockspid, $port);
2374}
2375
2376#######################################################################
2377# start the dict server
2378#
2379sub rundictserver {
2380    my ($verbose, $alt) = @_;
2381    my $proto = "dict";
2382    my $ip = $HOSTIP;
2383    my $ipvnum = 4;
2384    my $idnum = 1;
2385    my $server;
2386    my $srvrname;
2387    my $pidfile;
2388    my $logfile;
2389    my $flags = "";
2390
2391    if($alt eq "ipv6") {
2392        # No IPv6
2393    }
2394
2395    $server = servername_id($proto, $ipvnum, $idnum);
2396
2397    $pidfile = $serverpidfile{$server};
2398
2399    # don't retry if the server doesn't work
2400    if ($doesntrun{$pidfile}) {
2401        return (0, 0, 0);
2402    }
2403
2404    my $pid = processexists($pidfile);
2405    if($pid > 0) {
2406        stopserver($server, "$pid");
2407    }
2408    unlink($pidfile) if(-f $pidfile);
2409
2410    $srvrname = servername_str($proto, $ipvnum, $idnum);
2411
2412    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2413
2414    $flags .= "--verbose 1 " if($debugprotocol);
2415    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
2416    $flags .= "--id $idnum " if($idnum > 1);
2417    $flags .= "--srcdir \"$srcdir\" ";
2418    $flags .= "--host $HOSTIP";
2419
2420    my $port = 29000;
2421    my ($dictpid, $pid2);
2422    for(1 .. 10) {
2423        $port += int(rand(900));
2424        my $aflags = "--port $port $flags";
2425        my $cmd = "$srcdir/dictserver.py $aflags";
2426        ($dictpid, $pid2) = startnew($cmd, $pidfile, 15, 0);
2427
2428        if($dictpid <= 0 || !pidexists($dictpid)) {
2429            # it is NOT alive
2430            stopserver($server, "$pid2");
2431            displaylogs($testnumcheck);
2432            $doesntrun{$pidfile} = 1;
2433            $dictpid = $pid2 = 0;
2434            next;
2435        }
2436        $doesntrun{$pidfile} = 0;
2437
2438        if($verbose) {
2439            logmsg "RUN: $srvrname server PID $dictpid port $port\n";
2440        }
2441        last;
2442    }
2443    logmsg "RUN: failed to start the $srvrname server\n" if(!$dictpid);
2444
2445    return ($dictpid, $pid2, $port);
2446}
2447
2448#######################################################################
2449# start the SMB server
2450#
2451sub runsmbserver {
2452    my ($verbose, $alt) = @_;
2453    my $proto = "smb";
2454    my $ip = $HOSTIP;
2455    my $ipvnum = 4;
2456    my $idnum = 1;
2457    my $server;
2458    my $srvrname;
2459    my $pidfile;
2460    my $logfile;
2461    my $flags = "";
2462
2463    if($alt eq "ipv6") {
2464        # No IPv6
2465    }
2466
2467    $server = servername_id($proto, $ipvnum, $idnum);
2468
2469    $pidfile = $serverpidfile{$server};
2470
2471    # don't retry if the server doesn't work
2472    if ($doesntrun{$pidfile}) {
2473        return (0, 0, 0);
2474    }
2475
2476    my $pid = processexists($pidfile);
2477    if($pid > 0) {
2478        stopserver($server, "$pid");
2479    }
2480    unlink($pidfile) if(-f $pidfile);
2481
2482    $srvrname = servername_str($proto, $ipvnum, $idnum);
2483
2484    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2485
2486    $flags .= "--verbose 1 " if($debugprotocol);
2487    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
2488    $flags .= "--id $idnum " if($idnum > 1);
2489    $flags .= "--srcdir \"$srcdir\" ";
2490    $flags .= "--host $HOSTIP";
2491
2492    my ($smbpid, $pid2);
2493    my $port = 31923;
2494    for(1 .. 10) {
2495        $port += int(rand(760));
2496        my $aflags = "--port $port $flags";
2497        my $cmd = "$srcdir/smbserver.py $aflags";
2498        ($smbpid, $pid2) = startnew($cmd, $pidfile, 15, 0);
2499
2500        if($smbpid <= 0 || !pidexists($smbpid)) {
2501            # it is NOT alive
2502            stopserver($server, "$pid2");
2503            displaylogs($testnumcheck);
2504            $doesntrun{$pidfile} = 1;
2505            $smbpid = $pid2 = 0;
2506            next;
2507        }
2508        $doesntrun{$pidfile} = 0;
2509
2510        if($verbose) {
2511            logmsg "RUN: $srvrname server PID $smbpid port $port\n";
2512        }
2513        last;
2514    }
2515    logmsg "RUN: failed to start the $srvrname server\n" if(!$smbpid);
2516
2517    return ($smbpid, $pid2, $port);
2518}
2519
2520#######################################################################
2521# start the telnet server
2522#
2523sub runnegtelnetserver {
2524    my ($verbose, $alt) = @_;
2525    my $proto = "telnet";
2526    my $ip = $HOSTIP;
2527    my $ipvnum = 4;
2528    my $idnum = 1;
2529    my $server;
2530    my $srvrname;
2531    my $pidfile;
2532    my $logfile;
2533    my $flags = "";
2534
2535    if($alt eq "ipv6") {
2536        # No IPv6
2537    }
2538
2539    $server = servername_id($proto, $ipvnum, $idnum);
2540
2541    $pidfile = $serverpidfile{$server};
2542
2543    # don't retry if the server doesn't work
2544    if ($doesntrun{$pidfile}) {
2545        return (0, 0, 0);
2546    }
2547
2548    my $pid = processexists($pidfile);
2549    if($pid > 0) {
2550        stopserver($server, "$pid");
2551    }
2552    unlink($pidfile) if(-f $pidfile);
2553
2554    $srvrname = servername_str($proto, $ipvnum, $idnum);
2555
2556    $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum);
2557
2558    $flags .= "--verbose 1 " if($debugprotocol);
2559    $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" ";
2560    $flags .= "--id $idnum " if($idnum > 1);
2561    $flags .= "--srcdir \"$srcdir\"";
2562
2563    my ($ntelpid, $pid2);
2564    my $port = 32000;
2565    for(1 .. 10) {
2566        $port += int(rand(800));
2567        my $aflags = "--port $port $flags";
2568        my $cmd = "$srcdir/negtelnetserver.py $aflags";
2569        ($ntelpid, $pid2) = startnew($cmd, $pidfile, 15, 0);
2570
2571        if($ntelpid <= 0 || !pidexists($ntelpid)) {
2572            # it is NOT alive
2573            stopserver($server, "$pid2");
2574            displaylogs($testnumcheck);
2575            $doesntrun{$pidfile} = 1;
2576            $ntelpid = $pid2 = 0;
2577            next;
2578        }
2579        $doesntrun{$pidfile} = 0;
2580
2581        if($verbose) {
2582            logmsg "RUN: $srvrname server PID $ntelpid port $port\n";
2583        }
2584        last;
2585    }
2586    logmsg "RUN: failed to start the $srvrname server\n" if(!$ntelpid);
2587
2588    return ($ntelpid, $pid2, $port);
2589}
2590
2591
2592#######################################################################
2593# Single shot http and gopher server responsiveness test. This should only
2594# be used to verify that a server present in %run hash is still functional
2595#
2596sub responsive_http_server {
2597    my ($proto, $verbose, $alt, $port_or_path) = @_;
2598    my $ip = $HOSTIP;
2599    my $ipvnum = 4;
2600    my $idnum = 1;
2601
2602    if($alt eq "ipv6") {
2603        # if IPv6, use a different setup
2604        $ipvnum = 6;
2605        $ip = $HOST6IP;
2606    }
2607    elsif($alt eq "proxy") {
2608        $idnum = 2;
2609    }
2610    elsif($alt eq "unix") {
2611        # IP (protocol) is mutually exclusive with Unix sockets
2612        $ipvnum = "unix";
2613    }
2614
2615    return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port_or_path);
2616}
2617
2618#######################################################################
2619# Single shot pingpong server responsiveness test. This should only be
2620# used to verify that a server present in %run hash is still functional
2621#
2622sub responsive_pingpong_server {
2623    my ($proto, $id, $verbose, $ipv6) = @_;
2624    my $port;
2625    my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
2626    my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
2627    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
2628
2629    if($proto eq "ftp") {
2630        $port = $FTPPORT;
2631
2632        if($ipvnum==6) {
2633            # if IPv6, use a different setup
2634            $port = $FTP6PORT;
2635        }
2636    }
2637    elsif($proto eq "pop3") {
2638        $port = ($ipvnum==6) ? $POP36PORT : $POP3PORT;
2639    }
2640    elsif($proto eq "imap") {
2641        $port = ($ipvnum==6) ? $IMAP6PORT : $IMAPPORT;
2642    }
2643    elsif($proto eq "smtp") {
2644        $port = ($ipvnum==6) ? $SMTP6PORT : $SMTPPORT;
2645    }
2646    else {
2647        print STDERR "Unsupported protocol $proto!!\n";
2648        return 0;
2649    }
2650
2651    return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port);
2652}
2653
2654#######################################################################
2655# Single shot rtsp server responsiveness test. This should only be
2656# used to verify that a server present in %run hash is still functional
2657#
2658sub responsive_rtsp_server {
2659    my ($verbose, $ipv6) = @_;
2660    my $port = $RTSPPORT;
2661    my $ip = $HOSTIP;
2662    my $proto = 'rtsp';
2663    my $ipvnum = 4;
2664    my $idnum = 1;
2665
2666    if($ipv6) {
2667        # if IPv6, use a different setup
2668        $ipvnum = 6;
2669        $port = $RTSP6PORT;
2670        $ip = $HOST6IP;
2671    }
2672
2673    return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port);
2674}
2675
2676#######################################################################
2677# Single shot tftp server responsiveness test. This should only be
2678# used to verify that a server present in %run hash is still functional
2679#
2680sub responsive_tftp_server {
2681    my ($id, $verbose, $ipv6) = @_;
2682    my $port = $TFTPPORT;
2683    my $ip = $HOSTIP;
2684    my $proto = 'tftp';
2685    my $ipvnum = 4;
2686    my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1;
2687
2688    if($ipv6) {
2689        # if IPv6, use a different setup
2690        $ipvnum = 6;
2691        $port = $TFTP6PORT;
2692        $ip = $HOST6IP;
2693    }
2694
2695    return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port);
2696}
2697
2698#######################################################################
2699# Single shot non-stunnel HTTP TLS extensions capable server
2700# responsiveness test. This should only be used to verify that a
2701# server present in %run hash is still functional
2702#
2703sub responsive_httptls_server {
2704    my ($verbose, $ipv6) = @_;
2705    my $proto = "httptls";
2706    my $port = ($ipv6 && ($ipv6 =~ /6$/)) ? $HTTPTLS6PORT : $HTTPTLSPORT;
2707    my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP";
2708    my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4;
2709    my $idnum = 1;
2710
2711    return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port);
2712}
2713
2714#######################################################################
2715# Remove all files in the specified directory
2716#
2717sub cleardir {
2718    my $dir = $_[0];
2719    my $count;
2720    my $file;
2721
2722    # Get all files
2723    opendir(my $dh, $dir) ||
2724        return 0; # can't open dir
2725    while($file = readdir($dh)) {
2726        if(($file !~ /^(\.|\.\.)\z/)) {
2727            if(-d "$dir/$file") {
2728                cleardir("$dir/$file");
2729                rmdir("$dir/$file");
2730            }
2731            else {
2732                unlink("$dir/$file");
2733            }
2734            $count++;
2735        }
2736    }
2737    closedir $dh;
2738    return $count;
2739}
2740
2741#######################################################################
2742# compare test results with the expected output, we might filter off
2743# some pattern that is allowed to differ, output test results
2744#
2745sub compare {
2746    my ($testnum, $testname, $subject, $firstref, $secondref)=@_;
2747
2748    my $result = compareparts($firstref, $secondref);
2749
2750    if($result) {
2751        # timestamp test result verification end
2752        $timevrfyend{$testnum} = Time::HiRes::time();
2753
2754        if(!$short) {
2755            logmsg "\n $testnum: $subject FAILED:\n";
2756            logmsg showdiff($LOGDIR, $firstref, $secondref);
2757        }
2758        elsif(!$automakestyle) {
2759            logmsg "FAILED\n";
2760        }
2761        else {
2762            # automakestyle
2763            logmsg "FAIL: $testnum - $testname - $subject\n";
2764        }
2765    }
2766    return $result;
2767}
2768
2769sub setupfeatures {
2770    $feature{"hyper"} = $has_hyper;
2771    $feature{"c-ares"} = $has_cares;
2772    $feature{"alt-svc"} = $has_altsvc;
2773    $feature{"HSTS"} = $has_hsts;
2774    $feature{"brotli"} = $has_brotli;
2775    $feature{"crypto"} = $has_crypto;
2776    $feature{"debug"} = $debug_build;
2777    $feature{"getrlimit"} = $has_getrlimit;
2778    $feature{"GnuTLS"} = $has_gnutls;
2779    $feature{"GSS-API"} = $has_gssapi;
2780    $feature{"http/2"} = $has_http2;
2781    $feature{"https-proxy"} = $has_httpsproxy;
2782    $feature{"idn"} = $has_idn;
2783    $feature{"ipv6"} = $has_ipv6;
2784    $feature{"Kerberos"} = $has_kerberos;
2785    $feature{"large_file"} = $has_largefile;
2786    $feature{"ld_preload"} = ($has_ldpreload && !$debug_build);
2787    $feature{"libz"} = $has_libz;
2788    $feature{"manual"} = $has_manual;
2789    $feature{"Metalink"} = $has_metalink;
2790    $feature{"MinGW"} = $has_mingw;
2791    $feature{"MultiSSL"} = $has_multissl;
2792    $feature{"NSS"} = $has_nss;
2793    $feature{"NTLM"} = $has_ntlm;
2794    $feature{"NTLM_WB"} = $has_ntlm_wb;
2795    $feature{"OpenSSL"} = $has_openssl || $has_libressl || $has_boringssl;
2796    $feature{"PSL"} = $has_psl;
2797    $feature{"Schannel"} = $has_schannel;
2798    $feature{"sectransp"} = $has_sectransp;
2799    $feature{"SPNEGO"} = $has_spnego;
2800    $feature{"SSL"} = $has_ssl;
2801    $feature{"SSLpinning"} = $has_sslpinning;
2802    $feature{"SSPI"} = $has_sspi;
2803    $feature{"threaded-resolver"} = $has_threadedres;
2804    $feature{"TLS-SRP"} = $has_tls_srp;
2805    $feature{"TrackMemory"} = $has_memory_tracking;
2806    $feature{"unittest"} = $debug_build;
2807    $feature{"unix-sockets"} = $has_unix;
2808    $feature{"win32"} = $has_win32;
2809    $feature{"zstd"} = $has_zstd;
2810
2811    # make each protocol an enabled "feature"
2812    for my $p (@protocols) {
2813        $feature{$p} = 1;
2814    }
2815    # 'socks' was once here but is now removed
2816
2817    #
2818    # strings that must match the names used in server/disabled.c
2819    #
2820    $feature{"cookies"} = 1;
2821    $feature{"DoH"} = 1;
2822    $feature{"HTTP-auth"} = 1;
2823    $feature{"Mime"} = 1;
2824    $feature{"netrc"} = 1;
2825    $feature{"parsedate"} = 1;
2826    $feature{"proxy"} = 1;
2827    $feature{"shuffle-dns"} = 1;
2828    $feature{"typecheck"} = 1;
2829    $feature{"verbose-strings"} = 1;
2830    $feature{"wakeup"} = 1;
2831
2832}
2833
2834#######################################################################
2835# display information about curl and the host the test suite runs on
2836#
2837sub checksystem {
2838
2839    unlink($memdump); # remove this if there was one left
2840
2841    my $feat;
2842    my $curl;
2843    my $libcurl;
2844    my $versretval;
2845    my $versnoexec;
2846    my @version=();
2847    my @disabled;
2848    my $dis = "";
2849
2850    my $curlverout="$LOGDIR/curlverout.log";
2851    my $curlvererr="$LOGDIR/curlvererr.log";
2852    my $versioncmd="$CURL --version 1>$curlverout 2>$curlvererr";
2853
2854    unlink($curlverout);
2855    unlink($curlvererr);
2856
2857    $versretval = runclient($versioncmd);
2858    $versnoexec = $!;
2859
2860    open(VERSOUT, "<$curlverout");
2861    @version = <VERSOUT>;
2862    close(VERSOUT);
2863
2864    open(DISABLED, "server/disabled".exe_ext('TOOL')."|");
2865    @disabled = <DISABLED>;
2866    close(DISABLED);
2867
2868    if($disabled[0]) {
2869        map s/[\r\n]//g, @disabled;
2870        $dis = join(", ", @disabled);
2871    }
2872
2873    $resolver="stock";
2874    for(@version) {
2875        chomp;
2876
2877        if($_ =~ /^curl ([^ ]*)/) {
2878            $curl = $_;
2879            $VERSION = $1;
2880            $curl =~ s/^(.*)(libcurl.*)/$1/g;
2881
2882            $libcurl = $2;
2883            if($curl =~ /linux|bsd|solaris/) {
2884                $has_ldpreload = 1;
2885            }
2886            if($curl =~ /win32|Windows|mingw(32|64)/) {
2887                # This is a Windows MinGW build or native build, we need to use
2888                # Win32-style path.
2889                $pwd = pathhelp::sys_native_current_path();
2890                $has_textaware = 1;
2891                $has_win32 = 1;
2892                $has_mingw = 1 if ($curl =~ /-pc-mingw32/);
2893            }
2894           if ($libcurl =~ /(winssl|schannel)/i) {
2895               $has_schannel=1;
2896               $has_sslpinning=1;
2897           }
2898           elsif ($libcurl =~ /openssl/i) {
2899               $has_openssl=1;
2900               $has_sslpinning=1;
2901           }
2902           elsif ($libcurl =~ /gnutls/i) {
2903               $has_gnutls=1;
2904               $has_sslpinning=1;
2905           }
2906           elsif ($libcurl =~ /nss/i) {
2907               $has_nss=1;
2908               $has_sslpinning=1;
2909           }
2910           elsif ($libcurl =~ /wolfssl/i) {
2911               $has_wolfssl=1;
2912               $has_sslpinning=1;
2913           }
2914           elsif ($libcurl =~ /securetransport/i) {
2915               $has_sectransp=1;
2916               $has_sslpinning=1;
2917           }
2918           elsif ($libcurl =~ /BoringSSL/i) {
2919               $has_boringssl=1;
2920               $has_sslpinning=1;
2921           }
2922           elsif ($libcurl =~ /libressl/i) {
2923               $has_libressl=1;
2924               $has_sslpinning=1;
2925           }
2926           elsif ($libcurl =~ /mbedTLS/i) {
2927               $has_mbedtls=1;
2928               $has_sslpinning=1;
2929           }
2930           if ($libcurl =~ /ares/i) {
2931               $has_cares=1;
2932               $resolver="c-ares";
2933           }
2934           if ($libcurl =~ /mesalink/i) {
2935               $has_mesalink=1;
2936           }
2937           if ($libcurl =~ /Hyper/i) {
2938               $has_hyper=1;
2939           }
2940        }
2941        elsif($_ =~ /^Protocols: (.*)/i) {
2942            # these are the protocols compiled in to this libcurl
2943            @protocols = split(' ', lc($1));
2944
2945            # Generate a "proto-ipv6" version of each protocol to match the
2946            # IPv6 <server> name and a "proto-unix" to match the variant which
2947            # uses Unix domain sockets. This works even if support isn't
2948            # compiled in because the <features> test will fail.
2949            push @protocols, map(("$_-ipv6", "$_-unix"), @protocols);
2950
2951            # 'http-proxy' is used in test cases to do CONNECT through
2952            push @protocols, 'http-proxy';
2953
2954            # 'none' is used in test cases to mean no server
2955            push @protocols, 'none';
2956        }
2957        elsif($_ =~ /^Features: (.*)/i) {
2958            $feat = $1;
2959            if($feat =~ /TrackMemory/i) {
2960                # built with memory tracking support (--enable-curldebug)
2961                $has_memory_tracking = 1;
2962            }
2963            if($feat =~ /debug/i) {
2964                # curl was built with --enable-debug
2965                $debug_build = 1;
2966            }
2967            if($feat =~ /SSL/i) {
2968                # ssl enabled
2969                $has_ssl=1;
2970            }
2971            if($feat =~ /MultiSSL/i) {
2972                # multiple ssl backends available.
2973                $has_multissl=1;
2974            }
2975            if($feat =~ /Largefile/i) {
2976                # large file support
2977                $has_largefile=1;
2978            }
2979            if($feat =~ /IDN/i) {
2980                # IDN support
2981                $has_idn=1;
2982            }
2983            if($feat =~ /IPv6/i) {
2984                $has_ipv6 = 1;
2985            }
2986            if($feat =~ /UnixSockets/i) {
2987                $has_unix = 1;
2988            }
2989            if($feat =~ /libz/i) {
2990                $has_libz = 1;
2991            }
2992            if($feat =~ /brotli/i) {
2993                $has_brotli = 1;
2994            }
2995            if($feat =~ /zstd/i) {
2996                $has_zstd = 1;
2997            }
2998            if($feat =~ /NTLM/i) {
2999                # NTLM enabled
3000                $has_ntlm=1;
3001
3002                # Use this as a proxy for any cryptographic authentication
3003                $has_crypto=1;
3004            }
3005            if($feat =~ /NTLM_WB/i) {
3006                # NTLM delegation to winbind daemon ntlm_auth helper enabled
3007                $has_ntlm_wb=1;
3008            }
3009            if($feat =~ /SSPI/i) {
3010                # SSPI enabled
3011                $has_sspi=1;
3012            }
3013            if($feat =~ /GSS-API/i) {
3014                # GSS-API enabled
3015                $has_gssapi=1;
3016            }
3017            if($feat =~ /Kerberos/i) {
3018                # Kerberos enabled
3019                $has_kerberos=1;
3020
3021                # Use this as a proxy for any cryptographic authentication
3022                $has_crypto=1;
3023            }
3024            if($feat =~ /SPNEGO/i) {
3025                # SPNEGO enabled
3026                $has_spnego=1;
3027
3028                # Use this as a proxy for any cryptographic authentication
3029                $has_crypto=1;
3030            }
3031            if($feat =~ /CharConv/i) {
3032                # CharConv enabled
3033                $has_charconv=1;
3034            }
3035            if($feat =~ /TLS-SRP/i) {
3036                # TLS-SRP enabled
3037                $has_tls_srp=1;
3038            }
3039            if($feat =~ /Metalink/i) {
3040                # Metalink enabled
3041                $has_metalink=1;
3042            }
3043            if($feat =~ /PSL/i) {
3044                # PSL enabled
3045                $has_psl=1;
3046            }
3047            if($feat =~ /alt-svc/i) {
3048                # alt-svc enabled
3049                $has_altsvc=1;
3050            }
3051            if($feat =~ /HSTS/i) {
3052                $has_hsts=1;
3053            }
3054            if($feat =~ /AsynchDNS/i) {
3055                if(!$has_cares) {
3056                    # this means threaded resolver
3057                    $has_threadedres=1;
3058                    $resolver="threaded";
3059                }
3060            }
3061            if($feat =~ /HTTP2/) {
3062                # http2 enabled
3063                $has_http2=1;
3064
3065                push @protocols, 'http/2';
3066            }
3067            if($feat =~ /HTTPS-proxy/) {
3068                $has_httpsproxy=1;
3069
3070                # 'https-proxy' is used as "server" so consider it a protocol
3071                push @protocols, 'https-proxy';
3072            }
3073        }
3074        #
3075        # Test harness currently uses a non-stunnel server in order to
3076        # run HTTP TLS-SRP tests required when curl is built with https
3077        # protocol support and TLS-SRP feature enabled. For convenience
3078        # 'httptls' may be included in the test harness protocols array
3079        # to differentiate this from classic stunnel based 'https' test
3080        # harness server.
3081        #
3082        if($has_tls_srp) {
3083            my $add_httptls;
3084            for(@protocols) {
3085                if($_ =~ /^https(-ipv6|)$/) {
3086                    $add_httptls=1;
3087                    last;
3088                }
3089            }
3090            if($add_httptls && (! grep /^httptls$/, @protocols)) {
3091                push @protocols, 'httptls';
3092                push @protocols, 'httptls-ipv6';
3093            }
3094        }
3095    }
3096    if(!$curl) {
3097        logmsg "unable to get curl's version, further details are:\n";
3098        logmsg "issued command: \n";
3099        logmsg "$versioncmd \n";
3100        if ($versretval == -1) {
3101            logmsg "command failed with: \n";
3102            logmsg "$versnoexec \n";
3103        }
3104        elsif ($versretval & 127) {
3105            logmsg sprintf("command died with signal %d, and %s coredump.\n",
3106                           ($versretval & 127), ($versretval & 128)?"a":"no");
3107        }
3108        else {
3109            logmsg sprintf("command exited with value %d \n", $versretval >> 8);
3110        }
3111        logmsg "contents of $curlverout: \n";
3112        displaylogcontent("$curlverout");
3113        logmsg "contents of $curlvererr: \n";
3114        displaylogcontent("$curlvererr");
3115        die "couldn't get curl's version";
3116    }
3117
3118    if(-r "../lib/curl_config.h") {
3119        open(CONF, "<../lib/curl_config.h");
3120        while(<CONF>) {
3121            if($_ =~ /^\#define HAVE_GETRLIMIT/) {
3122                $has_getrlimit = 1;
3123            }
3124        }
3125        close(CONF);
3126    }
3127
3128    if($has_ipv6) {
3129        # client has IPv6 support
3130
3131        # check if the HTTP server has it!
3132        my $cmd = "server/sws".exe_ext('SRV')." --version";
3133        my @sws = `$cmd`;
3134        if($sws[0] =~ /IPv6/) {
3135            # HTTP server has IPv6 support!
3136            $http_ipv6 = 1;
3137            $gopher_ipv6 = 1;
3138        }
3139
3140        # check if the FTP server has it!
3141        $cmd = "server/sockfilt".exe_ext('SRV')." --version";
3142        @sws = `$cmd`;
3143        if($sws[0] =~ /IPv6/) {
3144            # FTP server has IPv6 support!
3145            $ftp_ipv6 = 1;
3146        }
3147    }
3148
3149    if($has_unix) {
3150        # client has Unix sockets support, check whether the HTTP server has it
3151        my $cmd = "server/sws".exe_ext('SRV')." --version";
3152        my @sws = `$cmd`;
3153        $http_unix = 1 if($sws[0] =~ /unix/);
3154    }
3155
3156    if(!$has_memory_tracking && $torture) {
3157        die "can't run torture tests since curl was built without ".
3158            "TrackMemory feature (--enable-curldebug)";
3159    }
3160
3161    open(M, "$CURL -M 2>&1|");
3162    while(my $s = <M>) {
3163        if($s =~ /built-in manual was disabled at build-time/) {
3164            $has_manual = 0;
3165            last;
3166        }
3167        $has_manual = 1;
3168        last;
3169    }
3170    close(M);
3171
3172    $has_shared = `sh $CURLCONFIG --built-shared`;
3173    chomp $has_shared;
3174
3175    my $hostname=join(' ', runclientoutput("hostname"));
3176    my $hosttype=join(' ', runclientoutput("uname -a"));
3177    my $hostos=$^O;
3178
3179    logmsg ("********* System characteristics ******** \n",
3180            "* $curl\n",
3181            "* $libcurl\n",
3182            "* Features: $feat\n",
3183            "* Disabled: $dis\n",
3184            "* Host: $hostname",
3185            "* System: $hosttype",
3186            "* OS: $hostos\n");
3187
3188    if($has_memory_tracking && $has_threadedres) {
3189        $has_memory_tracking = 0;
3190        logmsg("*\n",
3191               "*** DISABLES memory tracking when using threaded resolver\n",
3192               "*\n");
3193    }
3194
3195    logmsg sprintf("* Servers: %s", $stunnel?"SSL ":"");
3196    logmsg sprintf("%s", $http_ipv6?"HTTP-IPv6 ":"");
3197    logmsg sprintf("%s", $http_unix?"HTTP-unix ":"");
3198    logmsg sprintf("%s\n", $ftp_ipv6?"FTP-IPv6 ":"");
3199
3200    logmsg sprintf("* Env: %s%s", $valgrind?"Valgrind ":"",
3201                   $run_event_based?"event-based ":"");
3202    logmsg sprintf("%s\n", $libtool?"Libtool ":"");
3203    logmsg ("* Seed: $randseed\n");
3204
3205    if($verbose) {
3206        if($has_unix) {
3207            logmsg "* Unix socket paths:\n";
3208            if($http_unix) {
3209                logmsg sprintf("*   HTTP-Unix:%s\n", $HTTPUNIXPATH);
3210            }
3211        }
3212    }
3213
3214    logmsg "***************************************** \n";
3215
3216    setupfeatures();
3217    # toggle off the features that were disabled in the build
3218    for my $d(@disabled) {
3219        $feature{$d} = 0;
3220    }
3221}
3222
3223#######################################################################
3224# substitute the variable stuff into either a joined up file or
3225# a command, in either case passed by reference
3226#
3227sub subVariables {
3228    my ($thing, $prefix) = @_;
3229
3230    if(!$prefix) {
3231        $prefix = "%";
3232    }
3233
3234    # test server ports
3235    $$thing =~ s/${prefix}FTP6PORT/$FTP6PORT/g;
3236    $$thing =~ s/${prefix}FTPSPORT/$FTPSPORT/g;
3237    $$thing =~ s/${prefix}FTPPORT/$FTPPORT/g;
3238    $$thing =~ s/${prefix}GOPHER6PORT/$GOPHER6PORT/g;
3239    $$thing =~ s/${prefix}GOPHERPORT/$GOPHERPORT/g;
3240    $$thing =~ s/${prefix}GOPHERSPORT/$GOPHERSPORT/g;
3241    $$thing =~ s/${prefix}HTTPTLS6PORT/$HTTPTLS6PORT/g;
3242    $$thing =~ s/${prefix}HTTPTLSPORT/$HTTPTLSPORT/g;
3243    $$thing =~ s/${prefix}HTTP6PORT/$HTTP6PORT/g;
3244    $$thing =~ s/${prefix}HTTPSPORT/$HTTPSPORT/g;
3245    $$thing =~ s/${prefix}HTTPSPROXYPORT/$HTTPSPROXYPORT/g;
3246    $$thing =~ s/${prefix}HTTP2PORT/$HTTP2PORT/g;
3247    $$thing =~ s/${prefix}HTTPPORT/$HTTPPORT/g;
3248    $$thing =~ s/${prefix}PROXYPORT/$HTTPPROXYPORT/g;
3249    $$thing =~ s/${prefix}MQTTPORT/$MQTTPORT/g;
3250    $$thing =~ s/${prefix}IMAP6PORT/$IMAP6PORT/g;
3251    $$thing =~ s/${prefix}IMAPPORT/$IMAPPORT/g;
3252    $$thing =~ s/${prefix}POP36PORT/$POP36PORT/g;
3253    $$thing =~ s/${prefix}POP3PORT/$POP3PORT/g;
3254    $$thing =~ s/${prefix}RTSP6PORT/$RTSP6PORT/g;
3255    $$thing =~ s/${prefix}RTSPPORT/$RTSPPORT/g;
3256    $$thing =~ s/${prefix}SMTP6PORT/$SMTP6PORT/g;
3257    $$thing =~ s/${prefix}SMTPPORT/$SMTPPORT/g;
3258    $$thing =~ s/${prefix}SOCKSPORT/$SOCKSPORT/g;
3259    $$thing =~ s/${prefix}SSHPORT/$SSHPORT/g;
3260    $$thing =~ s/${prefix}TFTP6PORT/$TFTP6PORT/g;
3261    $$thing =~ s/${prefix}TFTPPORT/$TFTPPORT/g;
3262    $$thing =~ s/${prefix}DICTPORT/$DICTPORT/g;
3263    $$thing =~ s/${prefix}SMBPORT/$SMBPORT/g;
3264    $$thing =~ s/${prefix}SMBSPORT/$SMBSPORT/g;
3265    $$thing =~ s/${prefix}TELNETPORT/$TELNETPORT/g;
3266    $$thing =~ s/${prefix}NOLISTENPORT/$NOLISTENPORT/g;
3267
3268    # server Unix domain socket paths
3269    $$thing =~ s/${prefix}HTTPUNIXPATH/$HTTPUNIXPATH/g;
3270
3271    # client IP addresses
3272    $$thing =~ s/${prefix}CLIENT6IP/$CLIENT6IP/g;
3273    $$thing =~ s/${prefix}CLIENTIP/$CLIENTIP/g;
3274
3275    # server IP addresses
3276    $$thing =~ s/${prefix}HOST6IP/$HOST6IP/g;
3277    $$thing =~ s/${prefix}HOSTIP/$HOSTIP/g;
3278
3279    # misc
3280    $$thing =~ s/${prefix}CURL/$CURL/g;
3281    $$thing =~ s/${prefix}PWD/$pwd/g;
3282    $$thing =~ s/${prefix}POSIX_PWD/$posix_pwd/g;
3283    $$thing =~ s/${prefix}VERSION/$VERSION/g;
3284
3285    my $file_pwd = $pwd;
3286    if($file_pwd !~ /^\//) {
3287        $file_pwd = "/$file_pwd";
3288    }
3289    my $ssh_pwd = $posix_pwd;
3290    if ($sshdid && $sshdid =~ /OpenSSH-Windows/) {
3291        $ssh_pwd = $file_pwd;
3292    }
3293
3294    $$thing =~ s/${prefix}FILE_PWD/$file_pwd/g;
3295    $$thing =~ s/${prefix}SSH_PWD/$ssh_pwd/g;
3296    $$thing =~ s/${prefix}SRCDIR/$srcdir/g;
3297    $$thing =~ s/${prefix}USER/$USER/g;
3298
3299    $$thing =~ s/${prefix}SSHSRVMD5/$SSHSRVMD5/g;
3300
3301    # The purpose of FTPTIME2 and FTPTIME3 is to provide times that can be
3302    # used for time-out tests and that would work on most hosts as these
3303    # adjust for the startup/check time for this particular host. We needed to
3304    # do this to make the test suite run better on very slow hosts.
3305    my $ftp2 = $ftpchecktime * 2;
3306    my $ftp3 = $ftpchecktime * 3;
3307
3308    $$thing =~ s/${prefix}FTPTIME2/$ftp2/g;
3309    $$thing =~ s/${prefix}FTPTIME3/$ftp3/g;
3310
3311    # HTTP2
3312    $$thing =~ s/${prefix}H2CVER/$h2cver/g;
3313}
3314
3315sub subBase64 {
3316    my ($thing) = @_;
3317
3318    # cut out the base64 piece
3319    if($$thing =~ s/%b64\[(.*)\]b64%/%%B64%%/i) {
3320        my $d = $1;
3321        # encode %NN characters
3322        $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
3323        my $enc = encode_base64($d, "");
3324        # put the result into there
3325        $$thing =~ s/%%B64%%/$enc/;
3326    }
3327    # hex decode
3328    if($$thing =~ s/%hex\[(.*)\]hex%/%%HEX%%/i) {
3329        # decode %NN characters
3330        my $d = $1;
3331        $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
3332        $$thing =~ s/%%HEX%%/$d/;
3333    }
3334    if($$thing =~ s/%repeat\[(\d+) x (.*)\]%/%%REPEAT%%/i) {
3335        # decode %NN characters
3336        my ($d, $n) = ($2, $1);
3337        $d =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
3338        my $all = $d x $n;
3339        $$thing =~ s/%%REPEAT%%/$all/;
3340    }
3341}
3342
3343my $prevupdate;
3344sub subNewlines {
3345    my ($thing) = @_;
3346
3347    # When curl is built with Hyper, it gets all response headers delivered as
3348    # name/value pairs and curl "invents" the newlines when it saves the
3349    # headers. Therefore, curl will always save headers with CRLF newlines
3350    # when built to use Hyper. By making sure we deliver all tests using CRLF
3351    # as well, all test comparisons will survive without knowing about this
3352    # little quirk.
3353
3354    if(($$thing =~ /^HTTP\/(1.1|1.0|2) [1-5][^\x0d]*\z/) ||
3355       (($$thing =~ /^[a-z0-9_-]+: [^\x0d]*\z/i) &&
3356        # skip curl error messages
3357        ($$thing !~ /^curl: \(\d+\) /))) {
3358        # enforce CRLF newline
3359        $$thing =~ s/\x0a/\x0d\x0a/;
3360        $prevupdate = 1;
3361    }
3362    else {
3363        if(($$thing =~ /^\n\z/) && $prevupdate) {
3364            # if there's a blank link after a line we update, we hope it is
3365            # the empty line following headers
3366            $$thing =~ s/\x0a/\x0d\x0a/;
3367        }
3368        $prevupdate = 0;
3369    }
3370}
3371
3372#######################################################################
3373# Provide time stamps for single test skipped events
3374#
3375sub timestampskippedevents {
3376    my $testnum = $_[0];
3377
3378    return if((not defined($testnum)) || ($testnum < 1));
3379
3380    if($timestats) {
3381
3382        if($timevrfyend{$testnum}) {
3383            return;
3384        }
3385        elsif($timesrvrlog{$testnum}) {
3386            $timevrfyend{$testnum} = $timesrvrlog{$testnum};
3387            return;
3388        }
3389        elsif($timetoolend{$testnum}) {
3390            $timevrfyend{$testnum} = $timetoolend{$testnum};
3391            $timesrvrlog{$testnum} = $timetoolend{$testnum};
3392        }
3393        elsif($timetoolini{$testnum}) {
3394            $timevrfyend{$testnum} = $timetoolini{$testnum};
3395            $timesrvrlog{$testnum} = $timetoolini{$testnum};
3396            $timetoolend{$testnum} = $timetoolini{$testnum};
3397        }
3398        elsif($timesrvrend{$testnum}) {
3399            $timevrfyend{$testnum} = $timesrvrend{$testnum};
3400            $timesrvrlog{$testnum} = $timesrvrend{$testnum};
3401            $timetoolend{$testnum} = $timesrvrend{$testnum};
3402            $timetoolini{$testnum} = $timesrvrend{$testnum};
3403        }
3404        elsif($timesrvrini{$testnum}) {
3405            $timevrfyend{$testnum} = $timesrvrini{$testnum};
3406            $timesrvrlog{$testnum} = $timesrvrini{$testnum};
3407            $timetoolend{$testnum} = $timesrvrini{$testnum};
3408            $timetoolini{$testnum} = $timesrvrini{$testnum};
3409            $timesrvrend{$testnum} = $timesrvrini{$testnum};
3410        }
3411        elsif($timeprepini{$testnum}) {
3412            $timevrfyend{$testnum} = $timeprepini{$testnum};
3413            $timesrvrlog{$testnum} = $timeprepini{$testnum};
3414            $timetoolend{$testnum} = $timeprepini{$testnum};
3415            $timetoolini{$testnum} = $timeprepini{$testnum};
3416            $timesrvrend{$testnum} = $timeprepini{$testnum};
3417            $timesrvrini{$testnum} = $timeprepini{$testnum};
3418        }
3419    }
3420}
3421
3422#
3423# 'prepro' processes the input array and replaces %-variables in the array
3424# etc. Returns the processed version of the array
3425
3426sub prepro {
3427    my (@entiretest) = @_;
3428    my $show = 1;
3429    my @out;
3430    for my $s (@entiretest) {
3431        my $f = $s;
3432        if($s =~ /^ *%if (.*)/) {
3433            my $cond = $1;
3434            my $rev = 0;
3435
3436            if($cond =~ /^!(.*)/) {
3437                $cond = $1;
3438                $rev = 1;
3439            }
3440            $rev ^= $feature{$cond} ? 1 : 0;
3441            $show = $rev;
3442            next;
3443        }
3444        elsif($s =~ /^ *%else/) {
3445            $show ^= 1;
3446            next;
3447        }
3448        elsif($s =~ /^ *%endif/) {
3449            $show = 1;
3450            next;
3451        }
3452        if($show) {
3453            subVariables(\$s, "%");
3454            subBase64(\$s);
3455            subNewlines(\$s) if($has_hyper);
3456            push @out, $s;
3457        }
3458    }
3459    return @out;
3460}
3461
3462#######################################################################
3463# Run a single specified test case
3464#
3465sub singletest {
3466    my ($evbased, # 1 means switch on if possible (and "curl" is tested)
3467                  # returns "not a test" if it can't be used for this test
3468        $testnum,
3469        $count,
3470        $total)=@_;
3471
3472    my @what;
3473    my $why;
3474    my $cmd;
3475    my $disablevalgrind;
3476    my $errorreturncode = 1; # 1 means normal error, 2 means ignored error
3477
3478    # fist, remove all lingering log files
3479    cleardir($LOGDIR);
3480
3481    # copy test number to a global scope var, this allows
3482    # testnum checking when starting test harness servers.
3483    $testnumcheck = $testnum;
3484
3485    # timestamp test preparation start
3486    $timeprepini{$testnum} = Time::HiRes::time();
3487
3488    if($disttests !~ /test$testnum\W/ ) {
3489        logmsg "Warning: test$testnum not present in tests/data/Makefile.inc\n";
3490    }
3491    if($disabled{$testnum}) {
3492        logmsg "Warning: test$testnum is explicitly disabled\n";
3493    }
3494    if($ignored{$testnum}) {
3495        logmsg "Warning: test$testnum result is ignored\n";
3496        $errorreturncode = 2;
3497    }
3498
3499    # load the test case file definition
3500    if(loadtest("${TESTDIR}/test${testnum}")) {
3501        if($verbose) {
3502            # this is not a test
3503            logmsg "RUN: $testnum doesn't look like a test case\n";
3504        }
3505        $why = "no test";
3506    }
3507    else {
3508        @what = getpart("client", "features");
3509    }
3510
3511    # We require a feature to be present
3512    for(@what) {
3513        my $f = $_;
3514        $f =~ s/\s//g;
3515
3516        if($f =~ /^([^!].*)$/) {
3517            if($feature{$1}) {
3518                next;
3519            }
3520
3521            $why = "curl lacks $1 support";
3522            last;
3523        }
3524    }
3525
3526    # We require a feature to not be present
3527    if(!$why) {
3528        for(@what) {
3529            my $f = $_;
3530            $f =~ s/\s//g;
3531
3532            if($f =~ /^!(.*)$/) {
3533                if(!$feature{$1}) {
3534                    next;
3535                }
3536            }
3537            else {
3538                next;
3539            }
3540
3541            $why = "curl has $1 support";
3542            last;
3543        }
3544    }
3545
3546    if(!$why) {
3547        my @info_keywords = getpart("info", "keywords");
3548        my $match;
3549        my $k;
3550
3551        # Clear the list of keywords from the last test
3552        %keywords = ();
3553
3554        if(!$info_keywords[0]) {
3555            $why = "missing the <keywords> section!";
3556        }
3557
3558        for $k (@info_keywords) {
3559            chomp $k;
3560            if ($disabled_keywords{lc($k)}) {
3561                $why = "disabled by keyword";
3562            } elsif ($enabled_keywords{lc($k)}) {
3563                $match = 1;
3564            }
3565            if ($ignored_keywords{lc($k)}) {
3566                logmsg "Warning: test$testnum result is ignored due to $k\n";
3567                $errorreturncode = 2;
3568            }
3569
3570            $keywords{$k} = 1;
3571        }
3572
3573        if(!$why && !$match && %enabled_keywords) {
3574            $why = "disabled by missing keyword";
3575        }
3576    }
3577
3578    # test definition may instruct to (un)set environment vars
3579    # this is done this early, so that the precheck can use environment
3580    # variables and still bail out fine on errors
3581
3582    # restore environment variables that were modified in a previous run
3583    foreach my $var (keys %oldenv) {
3584        if($oldenv{$var} eq 'notset') {
3585            delete $ENV{$var} if($ENV{$var});
3586        }
3587        else {
3588            $ENV{$var} = $oldenv{$var};
3589        }
3590        delete $oldenv{$var};
3591    }
3592
3593    # get the name of the test early
3594    my @testname= getpart("client", "name");
3595    my $testname = $testname[0];
3596    $testname =~ s/\n//g;
3597
3598    # create test result in CI services
3599    if(azure_check_environment() && $AZURE_RUN_ID) {
3600        $AZURE_RESULT_ID = azure_create_test_result($VCURL, $AZURE_RUN_ID, $testnum, $testname);
3601    }
3602    elsif(appveyor_check_environment()) {
3603        appveyor_create_test_result($VCURL, $testnum, $testname);
3604    }
3605
3606    # remove test server commands file before servers are started/verified
3607    unlink($FTPDCMD) if(-f $FTPDCMD);
3608
3609    # timestamp required servers verification start
3610    $timesrvrini{$testnum} = Time::HiRes::time();
3611
3612    if(!$why) {
3613        $why = serverfortest($testnum);
3614    }
3615
3616    # Save a preprocessed version of the entire test file. This allows more
3617    # "basic" test case readers to enjoy variable replacements.
3618    my @entiretest = fulltest();
3619    my $otest = "log/test$testnum";
3620
3621    @entiretest = prepro(@entiretest);
3622
3623    # save the new version
3624    open(D, ">$otest");
3625    print D @entiretest;
3626    close(D);
3627
3628    # in case the process changed the file, reload it
3629    loadtest("log/test${testnum}");
3630
3631    # timestamp required servers verification end
3632    $timesrvrend{$testnum} = Time::HiRes::time();
3633
3634    my @setenv = getpart("client", "setenv");
3635    if(@setenv) {
3636        foreach my $s (@setenv) {
3637            chomp $s;
3638            if($s =~ /([^=]*)=(.*)/) {
3639                my ($var, $content) = ($1, $2);
3640                # remember current setting, to restore it once test runs
3641                $oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset';
3642                # set new value
3643                if(!$content) {
3644                    delete $ENV{$var} if($ENV{$var});
3645                }
3646                else {
3647                    if($var =~ /^LD_PRELOAD/) {
3648                        if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) {
3649                            # print "Skipping LD_PRELOAD due to lack of OS support\n";
3650                            next;
3651                        }
3652                        if($debug_build || ($has_shared ne "yes")) {
3653                            # print "Skipping LD_PRELOAD due to no release shared build\n";
3654                            next;
3655                        }
3656                    }
3657                    $ENV{$var} = "$content";
3658                    print "setenv $var = $content\n" if($verbose);
3659                }
3660            }
3661        }
3662    }
3663
3664    if(!$why) {
3665        my @precheck = getpart("client", "precheck");
3666        if(@precheck) {
3667            $cmd = $precheck[0];
3668            chomp $cmd;
3669            if($cmd) {
3670                my @p = split(/ /, $cmd);
3671                if($p[0] !~ /\//) {
3672                    # the first word, the command, does not contain a slash so
3673                    # we will scan the "improved" PATH to find the command to
3674                    # be able to run it
3675                    my $fullp = checktestcmd($p[0]);
3676
3677                    if($fullp) {
3678                        $p[0] = $fullp;
3679                    }
3680                    $cmd = join(" ", @p);
3681                }
3682
3683                my @o = `$cmd 2>/dev/null`;
3684                if($o[0]) {
3685                    $why = $o[0];
3686                    chomp $why;
3687                } elsif($?) {
3688                    $why = "precheck command error";
3689                }
3690                logmsg "prechecked $cmd\n" if($verbose);
3691            }
3692        }
3693    }
3694
3695    if($why && !$listonly) {
3696        # there's a problem, count it as "skipped"
3697        $skipped++;
3698        $skipped{$why}++;
3699        $teststat[$testnum]=$why; # store reason for this test case
3700
3701        if(!$short) {
3702            if($skipped{$why} <= 3) {
3703                # show only the first three skips for each reason
3704                logmsg sprintf("test %04d SKIPPED: $why\n", $testnum);
3705            }
3706        }
3707
3708        timestampskippedevents($testnum);
3709        return -1;
3710    }
3711    logmsg sprintf("test %04d...", $testnum) if(!$automakestyle);
3712
3713    my %replyattr = getpartattr("reply", "data");
3714    my @reply;
3715    if (partexists("reply", "datacheck")) {
3716        for my $partsuffix (('', '1', '2', '3', '4')) {
3717            my @replycheckpart = getpart("reply", "datacheck".$partsuffix);
3718            if(@replycheckpart) {
3719                my %replycheckpartattr = getpartattr("reply", "datacheck".$partsuffix);
3720                # get the mode attribute
3721                my $filemode=$replycheckpartattr{'mode'};
3722                if($filemode && ($filemode eq "text") && $has_textaware) {
3723                    # text mode when running on windows: fix line endings
3724                    map s/\r\n/\n/g, @replycheckpart;
3725                    map s/\n/\r\n/g, @replycheckpart;
3726                }
3727                if($replycheckpartattr{'nonewline'}) {
3728                    # Yes, we must cut off the final newline from the final line
3729                    # of the datacheck
3730                    chomp($replycheckpart[$#replycheckpart]);
3731                }
3732                push(@reply, @replycheckpart);
3733            }
3734        }
3735    }
3736    else {
3737        # check against the data section
3738        @reply = getpart("reply", "data");
3739        # get the mode attribute
3740        my $filemode=$replyattr{'mode'};
3741        if($filemode && ($filemode eq "text") && $has_textaware) {
3742            # text mode when running on windows: fix line endings
3743            map s/\r\n/\n/g, @reply;
3744            map s/\n/\r\n/g, @reply;
3745        }
3746    }
3747
3748    # this is the valid protocol blurb curl should generate
3749    my @protocol= getpart("verify", "protocol");
3750
3751    # this is the valid protocol blurb curl should generate to a proxy
3752    my @proxyprot = getpart("verify", "proxy");
3753
3754    # redirected stdout/stderr to these files
3755    $STDOUT="$LOGDIR/stdout$testnum";
3756    $STDERR="$LOGDIR/stderr$testnum";
3757
3758    # if this section exists, we verify that the stdout contained this:
3759    my @validstdout = getpart("verify", "stdout");
3760    my @validstderr = getpart("verify", "stderr");
3761
3762    # if this section exists, we verify upload
3763    my @upload = getpart("verify", "upload");
3764    if(@upload) {
3765      my %hash = getpartattr("verify", "upload");
3766      if($hash{'nonewline'}) {
3767          # cut off the final newline from the final line of the upload data
3768          chomp($upload[$#upload]);
3769      }
3770    }
3771
3772    # if this section exists, it might be FTP server instructions:
3773    my @ftpservercmd = getpart("reply", "servercmd");
3774
3775    my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout
3776
3777    # name of the test
3778    logmsg "[$testname]\n" if(!$short);
3779
3780    if($listonly) {
3781        timestampskippedevents($testnum);
3782        return 0; # look successful
3783    }
3784
3785    my @codepieces = getpart("client", "tool");
3786
3787    my $tool="";
3788    if(@codepieces) {
3789        $tool = $codepieces[0];
3790        chomp $tool;
3791        $tool .= exe_ext('TOOL');
3792    }
3793
3794    # remove server output logfile
3795    unlink($SERVERIN);
3796    unlink($SERVER2IN);
3797    unlink($PROXYIN);
3798
3799    push @ftpservercmd, "Testnum $testnum\n";
3800    # write the instructions to file
3801    writearray($FTPDCMD, \@ftpservercmd);
3802
3803    # get the command line options to use
3804    my @blaha;
3805    ($cmd, @blaha)= getpart("client", "command");
3806
3807    if($cmd) {
3808        # make some nice replace operations
3809        $cmd =~ s/\n//g; # no newlines please
3810        # substitute variables in the command line
3811    }
3812    else {
3813        # there was no command given, use something silly
3814        $cmd="-";
3815    }
3816    if($has_memory_tracking) {
3817        unlink($memdump);
3818    }
3819
3820    # create (possibly-empty) files before starting the test
3821    for my $partsuffix (('', '1', '2', '3', '4')) {
3822        my @inputfile=getpart("client", "file".$partsuffix);
3823        my %fileattr = getpartattr("client", "file".$partsuffix);
3824        my $filename=$fileattr{'name'};
3825        if(@inputfile || $filename) {
3826            if(!$filename) {
3827                logmsg "ERROR: section client=>file has no name attribute\n";
3828                timestampskippedevents($testnum);
3829                return -1;
3830            }
3831            my $fileContent = join('', @inputfile);
3832            open(OUTFILE, ">$filename");
3833            binmode OUTFILE; # for crapage systems, use binary
3834            if($fileattr{'nonewline'}) {
3835                # cut off the final newline
3836                chomp($fileContent);
3837            }
3838            print OUTFILE $fileContent;
3839            close(OUTFILE);
3840        }
3841    }
3842
3843    my %cmdhash = getpartattr("client", "command");
3844
3845    my $out="";
3846
3847    if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-output/)) {
3848        #We may slap on --output!
3849        if (!@validstdout ||
3850                ($cmdhash{'option'} && $cmdhash{'option'} =~ /force-output/)) {
3851            $out=" --output $CURLOUT ";
3852        }
3853    }
3854
3855    my $serverlogslocktimeout = $defserverlogslocktimeout;
3856    if($cmdhash{'timeout'}) {
3857        # test is allowed to override default server logs lock timeout
3858        if($cmdhash{'timeout'} =~ /(\d+)/) {
3859            $serverlogslocktimeout = $1 if($1 >= 0);
3860        }
3861    }
3862
3863    my $postcommanddelay = $defpostcommanddelay;
3864    if($cmdhash{'delay'}) {
3865        # test is allowed to specify a delay after command is executed
3866        if($cmdhash{'delay'} =~ /(\d+)/) {
3867            $postcommanddelay = $1 if($1 > 0);
3868        }
3869    }
3870
3871    my $CMDLINE;
3872    my $cmdargs;
3873    my $cmdtype = $cmdhash{'type'} || "default";
3874    my $fail_due_event_based = $evbased;
3875    if($cmdtype eq "perl") {
3876        # run the command line prepended with "perl"
3877        $cmdargs ="$cmd";
3878        $CMDLINE = "$perl ";
3879        $tool=$CMDLINE;
3880        $disablevalgrind=1;
3881    }
3882    elsif($cmdtype eq "shell") {
3883        # run the command line prepended with "/bin/sh"
3884        $cmdargs ="$cmd";
3885        $CMDLINE = "/bin/sh ";
3886        $tool=$CMDLINE;
3887        $disablevalgrind=1;
3888    }
3889    elsif(!$tool && !$keywords{"unittest"}) {
3890        # run curl, add suitable command line options
3891        my $inc="";
3892        if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-include/)) {
3893            $inc = " --include";
3894        }
3895        $cmdargs = "$out$inc ";
3896
3897        if($cmdhash{'option'} && ($cmdhash{'option'} =~ /binary-trace/)) {
3898            $cmdargs .= "--trace log/trace$testnum ";
3899        }
3900        else {
3901            $cmdargs .= "--trace-ascii log/trace$testnum ";
3902        }
3903        $cmdargs .= "--trace-time ";
3904        if($evbased) {
3905            $cmdargs .= "--test-event ";
3906            $fail_due_event_based--;
3907        }
3908        $cmdargs .= $cmd;
3909    }
3910    else {
3911        $cmdargs = " $cmd"; # $cmd is the command line for the test file
3912        $CURLOUT = $STDOUT; # sends received data to stdout
3913
3914        # Default the tool to a unit test with the same name as the test spec
3915        if($keywords{"unittest"} && !$tool) {
3916            $tool="unit$testnum";
3917        }
3918
3919        if($tool =~ /^lib/) {
3920            $CMDLINE="$LIBDIR/$tool";
3921        }
3922        elsif($tool =~ /^unit/) {
3923            $CMDLINE="$UNITDIR/$tool";
3924        }
3925
3926        if(! -f $CMDLINE) {
3927            logmsg "The tool set in the test case for this: '$tool' does not exist\n";
3928            timestampskippedevents($testnum);
3929            return -1;
3930        }
3931        $DBGCURL=$CMDLINE;
3932    }
3933
3934    if($gdbthis) {
3935        # gdb is incompatible with valgrind, so disable it when debugging
3936        # Perhaps a better approach would be to run it under valgrind anyway
3937        # with --db-attach=yes or --vgdb=yes.
3938        $disablevalgrind=1;
3939    }
3940
3941    if($fail_due_event_based) {
3942        logmsg "This test cannot run event based\n";
3943        return -1;
3944    }
3945
3946    my @stdintest = getpart("client", "stdin");
3947
3948    if(@stdintest) {
3949        my $stdinfile="$LOGDIR/stdin-for-$testnum";
3950
3951        my %hash = getpartattr("client", "stdin");
3952        if($hash{'nonewline'}) {
3953            # cut off the final newline from the final line of the stdin data
3954            chomp($stdintest[$#stdintest]);
3955        }
3956
3957        writearray($stdinfile, \@stdintest);
3958
3959        $cmdargs .= " <$stdinfile";
3960    }
3961
3962    if(!$tool) {
3963        $CMDLINE="$CURL";
3964    }
3965
3966    my $usevalgrind;
3967    if($valgrind && !$disablevalgrind) {
3968        my @valgrindoption = getpart("verify", "valgrind");
3969        if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) {
3970            $usevalgrind = 1;
3971            my $valgrindcmd = "$valgrind ";
3972            $valgrindcmd .= "$valgrind_tool " if($valgrind_tool);
3973            $valgrindcmd .= "--quiet --leak-check=yes ";
3974            $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp ";
3975           # $valgrindcmd .= "--gen-suppressions=all ";
3976            $valgrindcmd .= "--num-callers=16 ";
3977            $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum";
3978            $CMDLINE = "$valgrindcmd $CMDLINE";
3979        }
3980    }
3981
3982    $CMDLINE .= "$cmdargs >$STDOUT 2>$STDERR";
3983
3984    if($verbose) {
3985        logmsg "$CMDLINE\n";
3986    }
3987
3988    open(CMDLOG, ">", "$LOGDIR/$CURLLOG");
3989    print CMDLOG "$CMDLINE\n";
3990    close(CMDLOG);
3991
3992    unlink("core");
3993
3994    my $dumped_core;
3995    my $cmdres;
3996
3997    if($gdbthis) {
3998        my $gdbinit = "$TESTDIR/gdbinit$testnum";
3999        open(GDBCMD, ">$LOGDIR/gdbcmd");
4000        print GDBCMD "set args $cmdargs\n";
4001        print GDBCMD "show args\n";
4002        print GDBCMD "source $gdbinit\n" if -e $gdbinit;
4003        close(GDBCMD);
4004    }
4005
4006    # timestamp starting of test command
4007    $timetoolini{$testnum} = Time::HiRes::time();
4008
4009    # run the command line we built
4010    if ($torture) {
4011        $cmdres = torture($CMDLINE,
4012                          $testnum,
4013                          "$gdb --directory $LIBDIR $DBGCURL -x $LOGDIR/gdbcmd");
4014    }
4015    elsif($gdbthis) {
4016        my $GDBW = ($gdbxwin) ? "-w" : "";
4017        runclient("$gdb --directory $LIBDIR $DBGCURL $GDBW -x $LOGDIR/gdbcmd");
4018        $cmdres=0; # makes it always continue after a debugged run
4019    }
4020    else {
4021        $cmdres = runclient("$CMDLINE");
4022        my $signal_num  = $cmdres & 127;
4023        $dumped_core = $cmdres & 128;
4024
4025        if(!$anyway && ($signal_num || $dumped_core)) {
4026            $cmdres = 1000;
4027        }
4028        else {
4029            $cmdres >>= 8;
4030            $cmdres = (2000 + $signal_num) if($signal_num && !$cmdres);
4031        }
4032    }
4033
4034    # timestamp finishing of test command
4035    $timetoolend{$testnum} = Time::HiRes::time();
4036
4037    if(!$dumped_core) {
4038        if(-r "core") {
4039            # there's core file present now!
4040            $dumped_core = 1;
4041        }
4042    }
4043
4044    if($dumped_core) {
4045        logmsg "core dumped\n";
4046        if(0 && $gdb) {
4047            logmsg "running gdb for post-mortem analysis:\n";
4048            open(GDBCMD, ">$LOGDIR/gdbcmd2");
4049            print GDBCMD "bt\n";
4050            close(GDBCMD);
4051            runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch $DBGCURL core ");
4052     #       unlink("$LOGDIR/gdbcmd2");
4053        }
4054    }
4055
4056    # If a server logs advisor read lock file exists, it is an indication
4057    # that the server has not yet finished writing out all its log files,
4058    # including server request log files used for protocol verification.
4059    # So, if the lock file exists the script waits here a certain amount
4060    # of time until the server removes it, or the given time expires.
4061
4062    if($serverlogslocktimeout) {
4063        my $lockretry = $serverlogslocktimeout * 20;
4064        while((-f $SERVERLOGS_LOCK) && $lockretry--) {
4065            portable_sleep(0.05);
4066        }
4067        if(($lockretry < 0) &&
4068           ($serverlogslocktimeout >= $defserverlogslocktimeout)) {
4069            logmsg "Warning: server logs lock timeout ",
4070                   "($serverlogslocktimeout seconds) expired\n";
4071        }
4072    }
4073
4074    # Test harness ssh server does not have this synchronization mechanism,
4075    # this implies that some ssh server based tests might need a small delay
4076    # once that the client command has run to avoid false test failures.
4077    #
4078    # gnutls-serv also lacks this synchronization mechanism, so gnutls-serv
4079    # based tests might need a small delay once that the client command has
4080    # run to avoid false test failures.
4081
4082    portable_sleep($postcommanddelay) if($postcommanddelay);
4083
4084    # timestamp removal of server logs advisor read lock
4085    $timesrvrlog{$testnum} = Time::HiRes::time();
4086
4087    # test definition might instruct to stop some servers
4088    # stop also all servers relative to the given one
4089
4090    my @killtestservers = getpart("client", "killserver");
4091    if(@killtestservers) {
4092        foreach my $server (@killtestservers) {
4093            chomp $server;
4094            stopserver($server);
4095        }
4096    }
4097
4098    # run the postcheck command
4099    my @postcheck= getpart("client", "postcheck");
4100    if(@postcheck) {
4101        $cmd = join("", @postcheck);
4102        chomp $cmd;
4103        if($cmd) {
4104            logmsg "postcheck $cmd\n" if($verbose);
4105            my $rc = runclient("$cmd");
4106            # Must run the postcheck command in torture mode in order
4107            # to clean up, but the result can't be relied upon.
4108            if($rc != 0 && !$torture) {
4109                logmsg " postcheck FAILED\n";
4110                # timestamp test result verification end
4111                $timevrfyend{$testnum} = Time::HiRes::time();
4112                return $errorreturncode;
4113            }
4114        }
4115    }
4116
4117    # restore environment variables that were modified
4118    if(%oldenv) {
4119        foreach my $var (keys %oldenv) {
4120            if($oldenv{$var} eq 'notset') {
4121                delete $ENV{$var} if($ENV{$var});
4122            }
4123            else {
4124                $ENV{$var} = "$oldenv{$var}";
4125            }
4126        }
4127    }
4128
4129    # Skip all the verification on torture tests
4130    if ($torture) {
4131        # timestamp test result verification end
4132        $timevrfyend{$testnum} = Time::HiRes::time();
4133        return $cmdres;
4134    }
4135
4136    my @err = getpart("verify", "errorcode");
4137    my $errorcode = $err[0] || "0";
4138    my $ok="";
4139    my $res;
4140    chomp $errorcode;
4141    if (@validstdout) {
4142        # verify redirected stdout
4143        my @actual = loadarray($STDOUT);
4144
4145        # what parts to cut off from stdout
4146        my @stripfile = getpart("verify", "stripfile");
4147
4148        foreach my $strip (@stripfile) {
4149            chomp $strip;
4150            my @newgen;
4151            for(@actual) {
4152                eval $strip;
4153                if($_) {
4154                    push @newgen, $_;
4155                }
4156            }
4157            # this is to get rid of array entries that vanished (zero
4158            # length) because of replacements
4159            @actual = @newgen;
4160        }
4161
4162        # get all attributes
4163        my %hash = getpartattr("verify", "stdout");
4164
4165        # get the mode attribute
4166        my $filemode=$hash{'mode'};
4167        if($filemode && ($filemode eq "text") && $has_textaware) {
4168            # text mode when running on windows: fix line endings
4169            map s/\r\n/\n/g, @validstdout;
4170            map s/\n/\r\n/g, @validstdout;
4171        }
4172
4173        if($hash{'nonewline'}) {
4174            # Yes, we must cut off the final newline from the final line
4175            # of the protocol data
4176            chomp($validstdout[$#validstdout]);
4177        }
4178
4179        $res = compare($testnum, $testname, "stdout", \@actual, \@validstdout);
4180        if($res) {
4181            return $errorreturncode;
4182        }
4183        $ok .= "s";
4184    }
4185    else {
4186        $ok .= "-"; # stdout not checked
4187    }
4188
4189    if (@validstderr) {
4190        # verify redirected stderr
4191        my @actual = loadarray($STDERR);
4192
4193        # what parts to cut off from stderr
4194        my @stripfile = getpart("verify", "stripfile");
4195
4196        foreach my $strip (@stripfile) {
4197            chomp $strip;
4198            my @newgen;
4199            for(@actual) {
4200                eval $strip;
4201                if($_) {
4202                    push @newgen, $_;
4203                }
4204            }
4205            # this is to get rid of array entries that vanished (zero
4206            # length) because of replacements
4207            @actual = @newgen;
4208        }
4209
4210        # get all attributes
4211        my %hash = getpartattr("verify", "stderr");
4212
4213        # get the mode attribute
4214        my $filemode=$hash{'mode'};
4215        if($filemode && ($filemode eq "text") && $has_textaware) {
4216            # text mode when running on windows: fix line endings
4217            map s/\r\n/\n/g, @validstderr;
4218            map s/\n/\r\n/g, @validstderr;
4219        }
4220
4221        if($hash{'nonewline'}) {
4222            # Yes, we must cut off the final newline from the final line
4223            # of the protocol data
4224            chomp($validstderr[$#validstderr]);
4225        }
4226
4227        $res = compare($testnum, $testname, "stderr", \@actual, \@validstderr);
4228        if($res) {
4229            return $errorreturncode;
4230        }
4231        $ok .= "r";
4232    }
4233    else {
4234        $ok .= "-"; # stderr not checked
4235    }
4236
4237    if(@protocol) {
4238        # Verify the sent request
4239        my @out = loadarray($SERVERIN);
4240
4241        # what to cut off from the live protocol sent by curl
4242        my @strip = getpart("verify", "strip");
4243
4244        my @protstrip=@protocol;
4245
4246        # check if there's any attributes on the verify/protocol section
4247        my %hash = getpartattr("verify", "protocol");
4248
4249        if($hash{'nonewline'}) {
4250            # Yes, we must cut off the final newline from the final line
4251            # of the protocol data
4252            chomp($protstrip[$#protstrip]);
4253        }
4254
4255        for(@strip) {
4256            # strip off all lines that match the patterns from both arrays
4257            chomp $_;
4258            @out = striparray( $_, \@out);
4259            @protstrip= striparray( $_, \@protstrip);
4260        }
4261
4262        # what parts to cut off from the protocol
4263        my @strippart = getpart("verify", "strippart");
4264        my $strip;
4265
4266        for $strip (@strippart) {
4267            chomp $strip;
4268            for(@out) {
4269                eval $strip;
4270            }
4271        }
4272
4273        if((!$out[0] || ($out[0] eq "")) && $protstrip[0]) {
4274            logmsg "\n $testnum: protocol FAILED!\n".
4275                " There was no content at all in the file $SERVERIN.\n".
4276                " Server glitch? Total curl failure? Returned: $cmdres\n";
4277            return $errorreturncode;
4278        }
4279
4280        $res = compare($testnum, $testname, "protocol", \@out, \@protstrip);
4281        if($res) {
4282            return $errorreturncode;
4283        }
4284
4285        $ok .= "p";
4286
4287    }
4288    else {
4289        $ok .= "-"; # protocol not checked
4290    }
4291
4292    if(!$replyattr{'nocheck'} && (@reply || $replyattr{'sendzero'})) {
4293        # verify the received data
4294        my @out = loadarray($CURLOUT);
4295        $res = compare($testnum, $testname, "data", \@out, \@reply);
4296        if ($res) {
4297            return $errorreturncode;
4298        }
4299        $ok .= "d";
4300    }
4301    else {
4302        $ok .= "-"; # data not checked
4303    }
4304
4305    if(@upload) {
4306        # verify uploaded data
4307        my @out = loadarray("$LOGDIR/upload.$testnum");
4308
4309        # what parts to cut off from the upload
4310        my @strippart = getpart("verify", "strippart");
4311        my $strip;
4312        for $strip (@strippart) {
4313            chomp $strip;
4314            for(@out) {
4315                eval $strip;
4316            }
4317        }
4318
4319        $res = compare($testnum, $testname, "upload", \@out, \@upload);
4320        if ($res) {
4321            return $errorreturncode;
4322        }
4323        $ok .= "u";
4324    }
4325    else {
4326        $ok .= "-"; # upload not checked
4327    }
4328
4329    if(@proxyprot) {
4330        # Verify the sent proxy request
4331        my @out = loadarray($PROXYIN);
4332
4333        # what to cut off from the live protocol sent by curl, we use the
4334        # same rules as for <protocol>
4335        my @strip = getpart("verify", "strip");
4336
4337        my @protstrip=@proxyprot;
4338
4339        # check if there's any attributes on the verify/protocol section
4340        my %hash = getpartattr("verify", "proxy");
4341
4342        if($hash{'nonewline'}) {
4343            # Yes, we must cut off the final newline from the final line
4344            # of the protocol data
4345            chomp($protstrip[$#protstrip]);
4346        }
4347
4348        for(@strip) {
4349            # strip off all lines that match the patterns from both arrays
4350            chomp $_;
4351            @out = striparray( $_, \@out);
4352            @protstrip= striparray( $_, \@protstrip);
4353        }
4354
4355        # what parts to cut off from the protocol
4356        my @strippart = getpart("verify", "strippart");
4357        my $strip;
4358        for $strip (@strippart) {
4359            chomp $strip;
4360            for(@out) {
4361                eval $strip;
4362            }
4363        }
4364
4365        $res = compare($testnum, $testname, "proxy", \@out, \@protstrip);
4366        if($res) {
4367            return $errorreturncode;
4368        }
4369
4370        $ok .= "P";
4371
4372    }
4373    else {
4374        $ok .= "-"; # protocol not checked
4375    }
4376
4377    my $outputok;
4378    for my $partsuffix (('', '1', '2', '3', '4')) {
4379        my @outfile=getpart("verify", "file".$partsuffix);
4380        if(@outfile || partexists("verify", "file".$partsuffix) ) {
4381            # we're supposed to verify a dynamically generated file!
4382            my %hash = getpartattr("verify", "file".$partsuffix);
4383
4384            my $filename=$hash{'name'};
4385            if(!$filename) {
4386                logmsg "ERROR: section verify=>file$partsuffix ".
4387                       "has no name attribute\n";
4388                stopservers($verbose);
4389                # timestamp test result verification end
4390                $timevrfyend{$testnum} = Time::HiRes::time();
4391                return -1;
4392            }
4393            my @generated=loadarray($filename);
4394
4395            # what parts to cut off from the file
4396            my @stripfile = getpart("verify", "stripfile".$partsuffix);
4397
4398            my $filemode=$hash{'mode'};
4399            if($filemode && ($filemode eq "text") && $has_textaware) {
4400                # text mode when running on windows: fix line endings
4401                map s/\r\n/\n/g, @outfile;
4402                map s/\n/\r\n/g, @outfile;
4403            }
4404
4405            my $strip;
4406            for $strip (@stripfile) {
4407                chomp $strip;
4408                my @newgen;
4409                for(@generated) {
4410                    eval $strip;
4411                    if($_) {
4412                        push @newgen, $_;
4413                    }
4414                }
4415                # this is to get rid of array entries that vanished (zero
4416                # length) because of replacements
4417                @generated = @newgen;
4418            }
4419
4420            $res = compare($testnum, $testname, "output ($filename)",
4421                           \@generated, \@outfile);
4422            if($res) {
4423                return $errorreturncode;
4424            }
4425
4426            $outputok = 1; # output checked
4427        }
4428    }
4429    $ok .= ($outputok) ? "o" : "-"; # output checked or not
4430
4431    # accept multiple comma-separated error codes
4432    my @splerr = split(/ *, */, $errorcode);
4433    my $errok;
4434    foreach my $e (@splerr) {
4435        if($e == $cmdres) {
4436            # a fine error code
4437            $errok = 1;
4438            last;
4439        }
4440    }
4441
4442    if($errok) {
4443        $ok .= "e";
4444    }
4445    else {
4446        if(!$short) {
4447            logmsg sprintf("\n%s returned $cmdres, when expecting %s\n",
4448                           (!$tool)?"curl":$tool, $errorcode);
4449        }
4450        logmsg " exit FAILED\n";
4451        # timestamp test result verification end
4452        $timevrfyend{$testnum} = Time::HiRes::time();
4453        return $errorreturncode;
4454    }
4455
4456    if($has_memory_tracking) {
4457        if(! -f $memdump) {
4458            logmsg "\n** ALERT! memory tracking with no output file?\n"
4459                if(!$cmdtype eq "perl");
4460        }
4461        else {
4462            my @memdata=`$memanalyze $memdump`;
4463            my $leak=0;
4464            for(@memdata) {
4465                if($_ ne "") {
4466                    # well it could be other memory problems as well, but
4467                    # we call it leak for short here
4468                    $leak=1;
4469                }
4470            }
4471            if($leak) {
4472                logmsg "\n** MEMORY FAILURE\n";
4473                logmsg @memdata;
4474                # timestamp test result verification end
4475                $timevrfyend{$testnum} = Time::HiRes::time();
4476                return $errorreturncode;
4477            }
4478            else {
4479                $ok .= "m";
4480            }
4481        }
4482    }
4483    else {
4484        $ok .= "-"; # memory not checked
4485    }
4486
4487    if($valgrind) {
4488        if($usevalgrind) {
4489            unless(opendir(DIR, "$LOGDIR")) {
4490                logmsg "ERROR: unable to read $LOGDIR\n";
4491                # timestamp test result verification end
4492                $timevrfyend{$testnum} = Time::HiRes::time();
4493                return $errorreturncode;
4494            }
4495            my @files = readdir(DIR);
4496            closedir(DIR);
4497            my $vgfile;
4498            foreach my $file (@files) {
4499                if($file =~ /^valgrind$testnum(\..*|)$/) {
4500                    $vgfile = $file;
4501                    last;
4502                }
4503            }
4504            if(!$vgfile) {
4505                logmsg "ERROR: valgrind log file missing for test $testnum\n";
4506                # timestamp test result verification end
4507                $timevrfyend{$testnum} = Time::HiRes::time();
4508                return $errorreturncode;
4509            }
4510            my @e = valgrindparse("$LOGDIR/$vgfile");
4511            if(@e && $e[0]) {
4512                if($automakestyle) {
4513                    logmsg "FAIL: $testnum - $testname - valgrind\n";
4514                }
4515                else {
4516                    logmsg " valgrind ERROR ";
4517                    logmsg @e;
4518                }
4519                # timestamp test result verification end
4520                $timevrfyend{$testnum} = Time::HiRes::time();
4521                return $errorreturncode;
4522            }
4523            $ok .= "v";
4524        }
4525        else {
4526            if($verbose && !$disablevalgrind) {
4527                logmsg " valgrind SKIPPED\n";
4528            }
4529            $ok .= "-"; # skipped
4530        }
4531    }
4532    else {
4533        $ok .= "-"; # valgrind not checked
4534    }
4535    # add 'E' for event-based
4536    $ok .= $evbased ? "E" : "-";
4537
4538    logmsg "$ok " if(!$short);
4539
4540    # timestamp test result verification end
4541    $timevrfyend{$testnum} = Time::HiRes::time();
4542
4543    my $sofar= time()-$start;
4544    my $esttotal = $sofar/$count * $total;
4545    my $estleft = $esttotal - $sofar;
4546    my $left=sprintf("remaining: %02d:%02d",
4547                     $estleft/60,
4548                     $estleft%60);
4549    my $took = $timevrfyend{$testnum} - $timeprepini{$testnum};
4550    my $duration = sprintf("duration: %02d:%02d",
4551                           $sofar/60, $sofar%60);
4552    if(!$automakestyle) {
4553        logmsg sprintf("OK (%-3d out of %-3d, %s, took %.3fs, %s)\n",
4554                       $count, $total, $left, $took, $duration);
4555    }
4556    else {
4557        logmsg "PASS: $testnum - $testname\n";
4558    }
4559
4560    if($errorreturncode==2) {
4561        logmsg "Warning: test$testnum result is ignored, but passed!\n";
4562    }
4563
4564    return 0;
4565}
4566
4567#######################################################################
4568# Stop all running test servers
4569#
4570sub stopservers {
4571    my $verbose = $_[0];
4572    #
4573    # kill sockfilter processes for all pingpong servers
4574    #
4575    killallsockfilters($verbose);
4576    #
4577    # kill all server pids from %run hash clearing them
4578    #
4579    my $pidlist;
4580    foreach my $server (keys %run) {
4581        if($run{$server}) {
4582            if($verbose) {
4583                my $prev = 0;
4584                my $pids = $run{$server};
4585                foreach my $pid (split(' ', $pids)) {
4586                    if($pid != $prev) {
4587                        logmsg sprintf("* kill pid for %s => %d\n",
4588                            $server, $pid);
4589                        $prev = $pid;
4590                    }
4591                }
4592            }
4593            $pidlist .= "$run{$server} ";
4594            $run{$server} = 0;
4595        }
4596        $runcert{$server} = 0 if($runcert{$server});
4597    }
4598    killpid($verbose, $pidlist);
4599    #
4600    # cleanup all server pid files
4601    #
4602    foreach my $server (keys %serverpidfile) {
4603        my $pidfile = $serverpidfile{$server};
4604        my $pid = processexists($pidfile);
4605        if($pid > 0) {
4606            logmsg "Warning: $server server unexpectedly alive\n";
4607            killpid($verbose, $pid);
4608        }
4609        unlink($pidfile) if(-f $pidfile);
4610    }
4611}
4612
4613#######################################################################
4614# startservers() starts all the named servers
4615#
4616# Returns: string with error reason or blank for success
4617#
4618sub startservers {
4619    my @what = @_;
4620    my ($pid, $pid2);
4621    for(@what) {
4622        my (@whatlist) = split(/\s+/,$_);
4623        my $what = lc($whatlist[0]);
4624        $what =~ s/[^a-z0-9\/-]//g;
4625
4626        my $certfile;
4627        if($what =~ /^(ftp|gopher|http|imap|pop3|smtp)s((\d*)(-ipv6|-unix|))$/) {
4628            $certfile = ($whatlist[1]) ? $whatlist[1] : 'stunnel.pem';
4629        }
4630
4631        if(($what eq "pop3") ||
4632           ($what eq "ftp") ||
4633           ($what eq "imap") ||
4634           ($what eq "smtp")) {
4635            if($torture && $run{$what} &&
4636               !responsive_pingpong_server($what, "", $verbose)) {
4637                stopserver($what);
4638            }
4639            if(!$run{$what}) {
4640                ($pid, $pid2) = runpingpongserver($what, "", $verbose);
4641                if($pid <= 0) {
4642                    return "failed starting ". uc($what) ." server";
4643                }
4644                printf ("* pid $what => %d %d\n", $pid, $pid2) if($verbose);
4645                $run{$what}="$pid $pid2";
4646            }
4647        }
4648        elsif($what eq "ftp-ipv6") {
4649            if($torture && $run{'ftp-ipv6'} &&
4650               !responsive_pingpong_server("ftp", "", $verbose, "ipv6")) {
4651                stopserver('ftp-ipv6');
4652            }
4653            if(!$run{'ftp-ipv6'}) {
4654                ($pid, $pid2) = runpingpongserver("ftp", "", $verbose, "ipv6");
4655                if($pid <= 0) {
4656                    return "failed starting FTP-IPv6 server";
4657                }
4658                logmsg sprintf("* pid ftp-ipv6 => %d %d\n", $pid,
4659                       $pid2) if($verbose);
4660                $run{'ftp-ipv6'}="$pid $pid2";
4661            }
4662        }
4663        elsif($what eq "gopher") {
4664            if($torture && $run{'gopher'} &&
4665               !responsive_http_server("gopher", $verbose, 0, $GOPHERPORT)) {
4666                stopserver('gopher');
4667            }
4668            if(!$run{'gopher'}) {
4669                ($pid, $pid2, $GOPHERPORT) =
4670                    runhttpserver("gopher", $verbose, 0);
4671                if($pid <= 0) {
4672                    return "failed starting GOPHER server";
4673                }
4674                logmsg sprintf ("* pid gopher => %d %d\n", $pid, $pid2)
4675                    if($verbose);
4676                $run{'gopher'}="$pid $pid2";
4677            }
4678        }
4679        elsif($what eq "gopher-ipv6") {
4680            if($torture && $run{'gopher-ipv6'} &&
4681               !responsive_http_server("gopher", $verbose, "ipv6",
4682                                       $GOPHER6PORT)) {
4683                stopserver('gopher-ipv6');
4684            }
4685            if(!$run{'gopher-ipv6'}) {
4686                ($pid, $pid2, $GOPHER6PORT) =
4687                    runhttpserver("gopher", $verbose, "ipv6");
4688                if($pid <= 0) {
4689                    return "failed starting GOPHER-IPv6 server";
4690                }
4691                logmsg sprintf("* pid gopher-ipv6 => %d %d\n", $pid,
4692                               $pid2) if($verbose);
4693                $run{'gopher-ipv6'}="$pid $pid2";
4694            }
4695        }
4696        elsif($what eq "http/2") {
4697            if(!$run{'http/2'}) {
4698                ($pid, $pid2, $HTTP2PORT) = runhttp2server($verbose);
4699                if($pid <= 0) {
4700                    return "failed starting HTTP/2 server";
4701                }
4702                logmsg sprintf ("* pid http/2 => %d %d\n", $pid, $pid2)
4703                    if($verbose);
4704                $run{'http/2'}="$pid $pid2";
4705            }
4706        }
4707        elsif($what eq "http") {
4708            if($torture && $run{'http'} &&
4709               !responsive_http_server("http", $verbose, 0, $HTTPPORT)) {
4710                stopserver('http');
4711            }
4712            if(!$run{'http'}) {
4713                ($pid, $pid2, $HTTPPORT) =
4714                    runhttpserver("http", $verbose, 0);
4715                if($pid <= 0) {
4716                    return "failed starting HTTP server";
4717                }
4718                logmsg sprintf ("* pid http => %d %d\n", $pid, $pid2)
4719                    if($verbose);
4720                $run{'http'}="$pid $pid2";
4721            }
4722        }
4723        elsif($what eq "http-proxy") {
4724            if($torture && $run{'http-proxy'} &&
4725               !responsive_http_server("http", $verbose, "proxy",
4726                                       $HTTPPROXYPORT)) {
4727                stopserver('http-proxy');
4728            }
4729            if(!$run{'http-proxy'}) {
4730                ($pid, $pid2, $HTTPPROXYPORT) =
4731                    runhttpserver("http", $verbose, "proxy");
4732                if($pid <= 0) {
4733                    return "failed starting HTTP-proxy server";
4734                }
4735                logmsg sprintf ("* pid http-proxy => %d %d\n", $pid, $pid2)
4736                    if($verbose);
4737                $run{'http-proxy'}="$pid $pid2";
4738            }
4739        }
4740        elsif($what eq "http-ipv6") {
4741            if($torture && $run{'http-ipv6'} &&
4742               !responsive_http_server("http", $verbose, "ipv6", $HTTP6PORT)) {
4743                stopserver('http-ipv6');
4744            }
4745            if(!$run{'http-ipv6'}) {
4746                ($pid, $pid2, $HTTP6PORT) =
4747                    runhttpserver("http", $verbose, "ipv6");
4748                if($pid <= 0) {
4749                    return "failed starting HTTP-IPv6 server";
4750                }
4751                logmsg sprintf("* pid http-ipv6 => %d %d\n", $pid, $pid2)
4752                    if($verbose);
4753                $run{'http-ipv6'}="$pid $pid2";
4754            }
4755        }
4756        elsif($what eq "rtsp") {
4757            if($torture && $run{'rtsp'} &&
4758               !responsive_rtsp_server($verbose)) {
4759                stopserver('rtsp');
4760            }
4761            if(!$run{'rtsp'}) {
4762                ($pid, $pid2, $RTSPPORT) = runrtspserver($verbose);
4763                if($pid <= 0) {
4764                    return "failed starting RTSP server";
4765                }
4766                printf ("* pid rtsp => %d %d\n", $pid, $pid2) if($verbose);
4767                $run{'rtsp'}="$pid $pid2";
4768            }
4769        }
4770        elsif($what eq "rtsp-ipv6") {
4771            if($torture && $run{'rtsp-ipv6'} &&
4772               !responsive_rtsp_server($verbose, "ipv6")) {
4773                stopserver('rtsp-ipv6');
4774            }
4775            if(!$run{'rtsp-ipv6'}) {
4776                ($pid, $pid2, $RTSP6PORT) = runrtspserver($verbose, "ipv6");
4777                if($pid <= 0) {
4778                    return "failed starting RTSP-IPv6 server";
4779                }
4780                logmsg sprintf("* pid rtsp-ipv6 => %d %d\n", $pid, $pid2)
4781                    if($verbose);
4782                $run{'rtsp-ipv6'}="$pid $pid2";
4783            }
4784        }
4785        elsif($what eq "ftps") {
4786            if(!$stunnel) {
4787                # we can't run ftps tests without stunnel
4788                return "no stunnel";
4789            }
4790            if($runcert{'ftps'} && ($runcert{'ftps'} ne $certfile)) {
4791                # stop server when running and using a different cert
4792                stopserver('ftps');
4793            }
4794            if($torture && $run{'ftp'} &&
4795               !responsive_pingpong_server("ftp", "", $verbose)) {
4796                stopserver('ftp');
4797            }
4798            if(!$run{'ftp'}) {
4799                ($pid, $pid2) = runpingpongserver("ftp", "", $verbose);
4800                if($pid <= 0) {
4801                    return "failed starting FTP server";
4802                }
4803                printf ("* pid ftp => %d %d\n", $pid, $pid2) if($verbose);
4804                $run{'ftp'}="$pid $pid2";
4805            }
4806            if(!$run{'ftps'}) {
4807                ($pid, $pid2, $FTPSPORT) =
4808                    runftpsserver($verbose, "", $certfile);
4809                if($pid <= 0) {
4810                    return "failed starting FTPS server (stunnel)";
4811                }
4812                logmsg sprintf("* pid ftps => %d %d\n", $pid, $pid2)
4813                    if($verbose);
4814                $run{'ftps'}="$pid $pid2";
4815            }
4816        }
4817        elsif($what eq "file") {
4818            # we support it but have no server!
4819        }
4820        elsif($what eq "https") {
4821            if(!$stunnel) {
4822                # we can't run https tests without stunnel
4823                return "no stunnel";
4824            }
4825            if($runcert{'https'} && ($runcert{'https'} ne $certfile)) {
4826                # stop server when running and using a different cert
4827                stopserver('https');
4828            }
4829            if($torture && $run{'http'} &&
4830               !responsive_http_server("http", $verbose, 0, $HTTPPORT)) {
4831                stopserver('http');
4832            }
4833            if(!$run{'http'}) {
4834                ($pid, $pid2, $HTTPPORT) =
4835                    runhttpserver("http", $verbose, 0);
4836                if($pid <= 0) {
4837                    return "failed starting HTTP server";
4838                }
4839                printf ("* pid http => %d %d\n", $pid, $pid2) if($verbose);
4840                $run{'http'}="$pid $pid2";
4841            }
4842            if(!$run{'https'}) {
4843                ($pid, $pid2, $HTTPSPORT) =
4844                    runhttpsserver($verbose, "https", "", $certfile);
4845                if($pid <= 0) {
4846                    return "failed starting HTTPS server (stunnel)";
4847                }
4848                logmsg sprintf("* pid https => %d %d\n", $pid, $pid2)
4849                    if($verbose);
4850                $run{'https'}="$pid $pid2";
4851            }
4852        }
4853        elsif($what eq "gophers") {
4854            if(!$stunnel) {
4855                # we can't run TLS tests without stunnel
4856                return "no stunnel";
4857            }
4858            if($runcert{'gophers'} && ($runcert{'gophers'} ne $certfile)) {
4859                # stop server when running and using a different cert
4860                stopserver('gophers');
4861            }
4862            if($torture && $run{'gopher'} &&
4863               !responsive_http_server("gopher", $verbose, 0, $GOPHERPORT)) {
4864                stopserver('gopher');
4865            }
4866            if(!$run{'gopher'}) {
4867                ($pid, $pid2, $GOPHERPORT) =
4868                    runhttpserver("gopher", $verbose, 0);
4869                if($pid <= 0) {
4870                    return "failed starting GOPHER server";
4871                }
4872                printf ("* pid gopher => %d %d\n", $pid, $pid2) if($verbose);
4873                print "GOPHERPORT => $GOPHERPORT\n" if($verbose);
4874                $run{'gopher'}="$pid $pid2";
4875            }
4876            if(!$run{'gophers'}) {
4877                ($pid, $pid2, $GOPHERSPORT) =
4878                    runhttpsserver($verbose, "gophers", "", $certfile);
4879                if($pid <= 0) {
4880                    return "failed starting GOPHERS server (stunnel)";
4881                }
4882                logmsg sprintf("* pid gophers => %d %d\n", $pid, $pid2)
4883                    if($verbose);
4884                print "GOPHERSPORT => $GOPHERSPORT\n" if($verbose);
4885                $run{'gophers'}="$pid $pid2";
4886            }
4887        }
4888        elsif($what eq "https-proxy") {
4889            if(!$stunnel) {
4890                # we can't run https-proxy tests without stunnel
4891                return "no stunnel";
4892            }
4893            if($runcert{'https-proxy'} &&
4894               ($runcert{'https-proxy'} ne $certfile)) {
4895                # stop server when running and using a different cert
4896                stopserver('https-proxy');
4897            }
4898
4899            # we front the http-proxy with stunnel so we need to make sure the
4900            # proxy runs as well
4901            my $f = startservers("http-proxy");
4902            if($f) {
4903                return $f;1
4904            }
4905
4906            if(!$run{'https-proxy'}) {
4907                ($pid, $pid2, $HTTPSPROXYPORT) =
4908                    runhttpsserver($verbose, "https", "proxy", $certfile);
4909                if($pid <= 0) {
4910                    return "failed starting HTTPS-proxy (stunnel)";
4911                }
4912                logmsg sprintf("* pid https-proxy => %d %d\n", $pid, $pid2)
4913                    if($verbose);
4914                $run{'https-proxy'}="$pid $pid2";
4915            }
4916        }
4917        elsif($what eq "httptls") {
4918            if(!$httptlssrv) {
4919                # for now, we can't run http TLS-EXT tests without gnutls-serv
4920                return "no gnutls-serv";
4921            }
4922            if($torture && $run{'httptls'} &&
4923               !responsive_httptls_server($verbose, "IPv4")) {
4924                stopserver('httptls');
4925            }
4926            if(!$run{'httptls'}) {
4927                ($pid, $pid2, $HTTPTLSPORT) =
4928                    runhttptlsserver($verbose, "IPv4");
4929                if($pid <= 0) {
4930                    return "failed starting HTTPTLS server (gnutls-serv)";
4931                }
4932                logmsg sprintf("* pid httptls => %d %d\n", $pid, $pid2)
4933                    if($verbose);
4934                $run{'httptls'}="$pid $pid2";
4935            }
4936        }
4937        elsif($what eq "httptls-ipv6") {
4938            if(!$httptlssrv) {
4939                # for now, we can't run http TLS-EXT tests without gnutls-serv
4940                return "no gnutls-serv";
4941            }
4942            if($torture && $run{'httptls-ipv6'} &&
4943               !responsive_httptls_server($verbose, "ipv6")) {
4944                stopserver('httptls-ipv6');
4945            }
4946            if(!$run{'httptls-ipv6'}) {
4947                ($pid, $pid2, $HTTPTLS6PORT) =
4948                    runhttptlsserver($verbose, "ipv6");
4949                if($pid <= 0) {
4950                    return "failed starting HTTPTLS-IPv6 server (gnutls-serv)";
4951                }
4952                logmsg sprintf("* pid httptls-ipv6 => %d %d\n", $pid, $pid2)
4953                    if($verbose);
4954                $run{'httptls-ipv6'}="$pid $pid2";
4955            }
4956        }
4957        elsif($what eq "tftp") {
4958            if($torture && $run{'tftp'} &&
4959               !responsive_tftp_server("", $verbose)) {
4960                stopserver('tftp');
4961            }
4962            if(!$run{'tftp'}) {
4963                ($pid, $pid2, $TFTPPORT) =
4964                    runtftpserver("", $verbose);
4965                if($pid <= 0) {
4966                    return "failed starting TFTP server";
4967                }
4968                printf ("* pid tftp => %d %d\n", $pid, $pid2) if($verbose);
4969                $run{'tftp'}="$pid $pid2";
4970            }
4971        }
4972        elsif($what eq "tftp-ipv6") {
4973            if($torture && $run{'tftp-ipv6'} &&
4974               !responsive_tftp_server("", $verbose, "ipv6")) {
4975                stopserver('tftp-ipv6');
4976            }
4977            if(!$run{'tftp-ipv6'}) {
4978                ($pid, $pid2, $TFTP6PORT) =
4979                    runtftpserver("", $verbose, "ipv6");
4980                if($pid <= 0) {
4981                    return "failed starting TFTP-IPv6 server";
4982                }
4983                printf("* pid tftp-ipv6 => %d %d\n", $pid, $pid2) if($verbose);
4984                $run{'tftp-ipv6'}="$pid $pid2";
4985            }
4986        }
4987        elsif($what eq "sftp" || $what eq "scp") {
4988            if(!$run{'ssh'}) {
4989                ($pid, $pid2, $SSHPORT) = runsshserver("", $verbose);
4990                if($pid <= 0) {
4991                    return "failed starting SSH server";
4992                }
4993                printf ("* pid ssh => %d %d\n", $pid, $pid2) if($verbose);
4994                $run{'ssh'}="$pid $pid2";
4995            }
4996        }
4997        elsif($what eq "socks4" || $what eq "socks5" ) {
4998            if(!$run{'socks'}) {
4999                ($pid, $pid2, $SOCKSPORT) = runsocksserver("", $verbose);
5000                if($pid <= 0) {
5001                    return "failed starting socks server";
5002                }
5003                printf ("* pid socks => %d %d\n", $pid, $pid2) if($verbose);
5004                $run{'socks'}="$pid $pid2";
5005            }
5006        }
5007        elsif($what eq "mqtt" ) {
5008            if(!$run{'mqtt'}) {
5009                ($pid, $pid2) = runmqttserver("", $verbose);
5010                if($pid <= 0) {
5011                    return "failed starting mqtt server";
5012                }
5013                printf ("* pid mqtt => %d %d\n", $pid, $pid2) if($verbose);
5014                $run{'mqtt'}="$pid $pid2";
5015            }
5016        }
5017        elsif($what eq "http-unix") {
5018            if($torture && $run{'http-unix'} &&
5019               !responsive_http_server("http", $verbose, "unix", $HTTPUNIXPATH)) {
5020                stopserver('http-unix');
5021            }
5022            if(!$run{'http-unix'}) {
5023                my $unused;
5024                ($pid, $pid2, $unused) =
5025                    runhttpserver("http", $verbose, "unix", $HTTPUNIXPATH);
5026                if($pid <= 0) {
5027                    return "failed starting HTTP-unix server";
5028                }
5029                logmsg sprintf("* pid http-unix => %d %d\n", $pid, $pid2)
5030                    if($verbose);
5031                $run{'http-unix'}="$pid $pid2";
5032            }
5033        }
5034        elsif($what eq "dict") {
5035            if(!$run{'dict'}) {
5036                ($pid, $pid2, $DICTPORT) = rundictserver($verbose, "");
5037                if($pid <= 0) {
5038                    return "failed starting DICT server";
5039                }
5040                logmsg sprintf ("* pid DICT => %d %d\n", $pid, $pid2)
5041                    if($verbose);
5042                $run{'dict'}="$pid $pid2";
5043            }
5044        }
5045        elsif($what eq "smb") {
5046            if(!$run{'smb'}) {
5047                ($pid, $pid2, $SMBPORT) = runsmbserver($verbose, "");
5048                if($pid <= 0) {
5049                    return "failed starting SMB server";
5050                }
5051                logmsg sprintf ("* pid SMB => %d %d\n", $pid, $pid2)
5052                    if($verbose);
5053                $run{'dict'}="$pid $pid2";
5054            }
5055        }
5056        elsif($what eq "telnet") {
5057            if(!$run{'telnet'}) {
5058                ($pid, $pid2, $TELNETPORT) =
5059                    runnegtelnetserver($verbose, "");
5060                if($pid <= 0) {
5061                    return "failed starting neg TELNET server";
5062                }
5063                logmsg sprintf ("* pid neg TELNET => %d %d\n", $pid, $pid2)
5064                    if($verbose);
5065                $run{'dict'}="$pid $pid2";
5066            }
5067        }
5068        elsif($what eq "none") {
5069            logmsg "* starts no server\n" if ($verbose);
5070        }
5071        else {
5072            warn "we don't support a server for $what";
5073            return "no server for $what";
5074        }
5075    }
5076    return 0;
5077}
5078
5079##############################################################################
5080# This function makes sure the right set of server is running for the
5081# specified test case. This is a useful design when we run single tests as not
5082# all servers need to run then!
5083#
5084# Returns: a string, blank if everything is fine or a reason why it failed
5085#
5086sub serverfortest {
5087    my ($testnum)=@_;
5088
5089    my @what = getpart("client", "server");
5090
5091    if(!$what[0]) {
5092        warn "Test case $testnum has no server(s) specified";
5093        return "no server specified";
5094    }
5095
5096    for(my $i = scalar(@what) - 1; $i >= 0; $i--) {
5097        my $srvrline = $what[$i];
5098        chomp $srvrline if($srvrline);
5099        if($srvrline =~ /^(\S+)((\s*)(.*))/) {
5100            my $server = "${1}";
5101            my $lnrest = "${2}";
5102            my $tlsext;
5103            if($server =~ /^(httptls)(\+)(ext|srp)(\d*)(-ipv6|)$/) {
5104                $server = "${1}${4}${5}";
5105                $tlsext = uc("TLS-${3}");
5106            }
5107            if(! grep /^\Q$server\E$/, @protocols) {
5108                if(substr($server,0,5) ne "socks") {
5109                    if($tlsext) {
5110                        return "curl lacks $tlsext support";
5111                    }
5112                    else {
5113                        return "curl lacks $server server support";
5114                    }
5115                }
5116            }
5117            $what[$i] = "$server$lnrest" if($tlsext);
5118        }
5119    }
5120
5121    return &startservers(@what);
5122}
5123
5124#######################################################################
5125# runtimestats displays test-suite run time statistics
5126#
5127sub runtimestats {
5128    my $lasttest = $_[0];
5129
5130    return if(not $timestats);
5131
5132    logmsg "\nTest suite total running time breakdown per task...\n\n";
5133
5134    my @timesrvr;
5135    my @timeprep;
5136    my @timetool;
5137    my @timelock;
5138    my @timevrfy;
5139    my @timetest;
5140    my $timesrvrtot = 0.0;
5141    my $timepreptot = 0.0;
5142    my $timetooltot = 0.0;
5143    my $timelocktot = 0.0;
5144    my $timevrfytot = 0.0;
5145    my $timetesttot = 0.0;
5146    my $counter;
5147
5148    for my $testnum (1 .. $lasttest) {
5149        if($timesrvrini{$testnum}) {
5150            $timesrvrtot += $timesrvrend{$testnum} - $timesrvrini{$testnum};
5151            $timepreptot +=
5152                (($timetoolini{$testnum} - $timeprepini{$testnum}) -
5153                 ($timesrvrend{$testnum} - $timesrvrini{$testnum}));
5154            $timetooltot += $timetoolend{$testnum} - $timetoolini{$testnum};
5155            $timelocktot += $timesrvrlog{$testnum} - $timetoolend{$testnum};
5156            $timevrfytot += $timevrfyend{$testnum} - $timesrvrlog{$testnum};
5157            $timetesttot += $timevrfyend{$testnum} - $timeprepini{$testnum};
5158            push @timesrvr, sprintf("%06.3f  %04d",
5159                $timesrvrend{$testnum} - $timesrvrini{$testnum}, $testnum);
5160            push @timeprep, sprintf("%06.3f  %04d",
5161                ($timetoolini{$testnum} - $timeprepini{$testnum}) -
5162                ($timesrvrend{$testnum} - $timesrvrini{$testnum}), $testnum);
5163            push @timetool, sprintf("%06.3f  %04d",
5164                $timetoolend{$testnum} - $timetoolini{$testnum}, $testnum);
5165            push @timelock, sprintf("%06.3f  %04d",
5166                $timesrvrlog{$testnum} - $timetoolend{$testnum}, $testnum);
5167            push @timevrfy, sprintf("%06.3f  %04d",
5168                $timevrfyend{$testnum} - $timesrvrlog{$testnum}, $testnum);
5169            push @timetest, sprintf("%06.3f  %04d",
5170                $timevrfyend{$testnum} - $timeprepini{$testnum}, $testnum);
5171        }
5172    }
5173
5174    {
5175        no warnings 'numeric';
5176        @timesrvr = sort { $b <=> $a } @timesrvr;
5177        @timeprep = sort { $b <=> $a } @timeprep;
5178        @timetool = sort { $b <=> $a } @timetool;
5179        @timelock = sort { $b <=> $a } @timelock;
5180        @timevrfy = sort { $b <=> $a } @timevrfy;
5181        @timetest = sort { $b <=> $a } @timetest;
5182    }
5183
5184    logmsg "Spent ". sprintf("%08.3f ", $timesrvrtot) .
5185           "seconds starting and verifying test harness servers.\n";
5186    logmsg "Spent ". sprintf("%08.3f ", $timepreptot) .
5187           "seconds reading definitions and doing test preparations.\n";
5188    logmsg "Spent ". sprintf("%08.3f ", $timetooltot) .
5189           "seconds actually running test tools.\n";
5190    logmsg "Spent ". sprintf("%08.3f ", $timelocktot) .
5191           "seconds awaiting server logs lock removal.\n";
5192    logmsg "Spent ". sprintf("%08.3f ", $timevrfytot) .
5193           "seconds verifying test results.\n";
5194    logmsg "Spent ". sprintf("%08.3f ", $timetesttot) .
5195           "seconds doing all of the above.\n";
5196
5197    $counter = 25;
5198    logmsg "\nTest server starting and verification time per test ".
5199        sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full");
5200    logmsg "-time-  test\n";
5201    logmsg "------  ----\n";
5202    foreach my $txt (@timesrvr) {
5203        last if((not $fullstats) && (not $counter--));
5204        logmsg "$txt\n";
5205    }
5206
5207    $counter = 10;
5208    logmsg "\nTest definition reading and preparation time per test ".
5209        sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full");
5210    logmsg "-time-  test\n";
5211    logmsg "------  ----\n";
5212    foreach my $txt (@timeprep) {
5213        last if((not $fullstats) && (not $counter--));
5214        logmsg "$txt\n";
5215    }
5216
5217    $counter = 25;
5218    logmsg "\nTest tool execution time per test ".
5219        sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full");
5220    logmsg "-time-  test\n";
5221    logmsg "------  ----\n";
5222    foreach my $txt (@timetool) {
5223        last if((not $fullstats) && (not $counter--));
5224        logmsg "$txt\n";
5225    }
5226
5227    $counter = 15;
5228    logmsg "\nTest server logs lock removal time per test ".
5229        sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full");
5230    logmsg "-time-  test\n";
5231    logmsg "------  ----\n";
5232    foreach my $txt (@timelock) {
5233        last if((not $fullstats) && (not $counter--));
5234        logmsg "$txt\n";
5235    }
5236
5237    $counter = 10;
5238    logmsg "\nTest results verification time per test ".
5239        sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full");
5240    logmsg "-time-  test\n";
5241    logmsg "------  ----\n";
5242    foreach my $txt (@timevrfy) {
5243        last if((not $fullstats) && (not $counter--));
5244        logmsg "$txt\n";
5245    }
5246
5247    $counter = 50;
5248    logmsg "\nTotal time per test ".
5249        sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full");
5250    logmsg "-time-  test\n";
5251    logmsg "------  ----\n";
5252    foreach my $txt (@timetest) {
5253        last if((not $fullstats) && (not $counter--));
5254        logmsg "$txt\n";
5255    }
5256
5257    logmsg "\n";
5258}
5259
5260#######################################################################
5261# Check options to this test program
5262#
5263
5264# Special case for CMake: replace '$TFLAGS' by the contents of the
5265# environment variable (if any).
5266if(@ARGV && $ARGV[-1] eq '$TFLAGS') {
5267    pop @ARGV;
5268    push(@ARGV, split(' ', $ENV{'TFLAGS'})) if defined($ENV{'TFLAGS'});
5269}
5270
5271my $number=0;
5272my $fromnum=-1;
5273my @testthis;
5274while(@ARGV) {
5275    if ($ARGV[0] eq "-v") {
5276        # verbose output
5277        $verbose=1;
5278    }
5279    elsif ($ARGV[0] eq "-c") {
5280        # use this path to curl instead of default
5281        $DBGCURL=$CURL="\"$ARGV[1]\"";
5282        shift @ARGV;
5283    }
5284    elsif ($ARGV[0] eq "-vc") {
5285        # use this path to a curl used to verify servers
5286
5287        # Particularly useful when you introduce a crashing bug somewhere in
5288        # the development version as then it won't be able to run any tests
5289        # since it can't verify the servers!
5290
5291        $VCURL="\"$ARGV[1]\"";
5292        shift @ARGV;
5293    }
5294    elsif ($ARGV[0] eq "-d") {
5295        # have the servers display protocol output
5296        $debugprotocol=1;
5297    }
5298    elsif($ARGV[0] eq "-e") {
5299        # run the tests cases event based if possible
5300        $run_event_based=1;
5301    }
5302    elsif ($ARGV[0] eq "-g") {
5303        # run this test with gdb
5304        $gdbthis=1;
5305    }
5306    elsif ($ARGV[0] eq "-gw") {
5307        # run this test with windowed gdb
5308        $gdbthis=1;
5309        $gdbxwin=1;
5310    }
5311    elsif($ARGV[0] eq "-s") {
5312        # short output
5313        $short=1;
5314    }
5315    elsif($ARGV[0] eq "-am") {
5316        # automake-style output
5317        $short=1;
5318        $automakestyle=1;
5319    }
5320    elsif($ARGV[0] eq "-n") {
5321        # no valgrind
5322        undef $valgrind;
5323    }
5324    elsif ($ARGV[0] eq "-R") {
5325        # execute in scrambled order
5326        $scrambleorder=1;
5327    }
5328    elsif($ARGV[0] =~ /^-t(.*)/) {
5329        # torture
5330        $torture=1;
5331        my $xtra = $1;
5332
5333        if($xtra =~ s/(\d+)$//) {
5334            $tortalloc = $1;
5335        }
5336    }
5337    elsif($ARGV[0] =~ /--shallow=(\d+)/) {
5338        # Fail no more than this amount per tests when running
5339        # torture.
5340        my ($num)=($1);
5341        $shallow=$num;
5342    }
5343    elsif($ARGV[0] =~ /--repeat=(\d+)/) {
5344        # Repeat-run the given tests this many times
5345        $repeat = $1;
5346    }
5347    elsif($ARGV[0] =~ /--seed=(\d+)/) {
5348        # Set a fixed random seed (used for -R and --shallow)
5349        $randseed = $1;
5350    }
5351    elsif($ARGV[0] eq "-a") {
5352        # continue anyway, even if a test fail
5353        $anyway=1;
5354    }
5355    elsif($ARGV[0] eq "-p") {
5356        $postmortem=1;
5357    }
5358    elsif($ARGV[0] eq "-l") {
5359        # lists the test case names only
5360        $listonly=1;
5361    }
5362    elsif($ARGV[0] eq "-k") {
5363        # keep stdout and stderr files after tests
5364        $keepoutfiles=1;
5365    }
5366    elsif($ARGV[0] eq "-r") {
5367        # run time statistics needs Time::HiRes
5368        if($Time::HiRes::VERSION) {
5369            keys(%timeprepini) = 1000;
5370            keys(%timesrvrini) = 1000;
5371            keys(%timesrvrend) = 1000;
5372            keys(%timetoolini) = 1000;
5373            keys(%timetoolend) = 1000;
5374            keys(%timesrvrlog) = 1000;
5375            keys(%timevrfyend) = 1000;
5376            $timestats=1;
5377            $fullstats=0;
5378        }
5379    }
5380    elsif($ARGV[0] eq "-rf") {
5381        # run time statistics needs Time::HiRes
5382        if($Time::HiRes::VERSION) {
5383            keys(%timeprepini) = 1000;
5384            keys(%timesrvrini) = 1000;
5385            keys(%timesrvrend) = 1000;
5386            keys(%timetoolini) = 1000;
5387            keys(%timetoolend) = 1000;
5388            keys(%timesrvrlog) = 1000;
5389            keys(%timevrfyend) = 1000;
5390            $timestats=1;
5391            $fullstats=1;
5392        }
5393    }
5394    elsif(($ARGV[0] eq "-h") || ($ARGV[0] eq "--help")) {
5395        # show help text
5396        print <<EOHELP
5397Usage: runtests.pl [options] [test selection(s)]
5398  -a       continue even if a test fails
5399  -am      automake style output PASS/FAIL: [number] [name]
5400  -c path  use this curl executable
5401  -d       display server debug info
5402  -e       event-based execution
5403  -g       run the test case with gdb
5404  -gw      run the test case with gdb as a windowed application
5405  -h       this help text
5406  -k       keep stdout and stderr files present after tests
5407  -l       list all test case names/descriptions
5408  -n       no valgrind
5409  -p       print log file contents when a test fails
5410  -R       scrambled order (uses the random seed, see --seed)
5411  -r       run time statistics
5412  -rf      full run time statistics
5413  -s       short output
5414  --seed=[num] set the random seed to a fixed number
5415  --shallow=[num] randomly makes the torture tests "thinner"
5416  -t[N]    torture (simulate function failures); N means fail Nth function
5417  -v       verbose output
5418  -vc path use this curl only to verify the existing servers
5419  [num]    like "5 6 9" or " 5 to 22 " to run those tests only
5420  [!num]   like "!5 !6 !9" to disable those tests
5421  [~num]   like "~5 ~6 ~9" to ignore the result of those tests
5422  [keyword] like "IPv6" to select only tests containing the key word
5423  [!keyword] like "!cookies" to disable any tests containing the key word
5424  [~keyword] like "~cookies" to ignore results of tests containing key word
5425EOHELP
5426    ;
5427        exit;
5428    }
5429    elsif($ARGV[0] =~ /^(\d+)/) {
5430        $number = $1;
5431        if($fromnum >= 0) {
5432            for my $n ($fromnum .. $number) {
5433                if($disabled{$n}) {
5434                    # skip disabled test cases
5435                    my $why = "configured as DISABLED";
5436                    $skipped++;
5437                    $skipped{$why}++;
5438                    $teststat[$n]=$why; # store reason for this test case
5439                }
5440                else {
5441                    push @testthis, $n;
5442                }
5443            }
5444            $fromnum = -1;
5445        }
5446        else {
5447            push @testthis, $1;
5448        }
5449    }
5450    elsif($ARGV[0] =~ /^to$/i) {
5451        $fromnum = $number+1;
5452    }
5453    elsif($ARGV[0] =~ /^!(\d+)/) {
5454        $fromnum = -1;
5455        $disabled{$1}=$1;
5456    }
5457    elsif($ARGV[0] =~ /^~(\d+)/) {
5458        $fromnum = -1;
5459        $ignored{$1}=$1;
5460    }
5461    elsif($ARGV[0] =~ /^!(.+)/) {
5462        $disabled_keywords{lc($1)}=$1;
5463    }
5464    elsif($ARGV[0] =~ /^~(.+)/) {
5465        $ignored_keywords{lc($1)}=$1;
5466    }
5467    elsif($ARGV[0] =~ /^([-[{a-zA-Z].*)/) {
5468        $enabled_keywords{lc($1)}=$1;
5469    }
5470    else {
5471        print "Unknown option: $ARGV[0]\n";
5472        exit;
5473    }
5474    shift @ARGV;
5475}
5476
5477if(!$randseed) {
5478    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
5479        localtime(time);
5480    # seed of the month. December 2019 becomes 201912
5481    $randseed = ($year+1900)*100 + $mon+1;
5482    open(C, "$CURL --version 2>/dev/null|");
5483    my @c = <C>;
5484    close(C);
5485    # use the first line of output and get the md5 out of it
5486    my $str = md5($c[0]);
5487    $randseed += unpack('S', $str);  # unsigned 16 bit value
5488}
5489srand $randseed;
5490
5491if(@testthis && ($testthis[0] ne "")) {
5492    $TESTCASES=join(" ", @testthis);
5493}
5494
5495if($valgrind) {
5496    # we have found valgrind on the host, use it
5497
5498    # verify that we can invoke it fine
5499    my $code = runclient("valgrind >/dev/null 2>&1");
5500
5501    if(($code>>8) != 1) {
5502        #logmsg "Valgrind failure, disable it\n";
5503        undef $valgrind;
5504    } else {
5505
5506        # since valgrind 2.1.x, '--tool' option is mandatory
5507        # use it, if it is supported by the version installed on the system
5508        runclient("valgrind --help 2>&1 | grep -- --tool > /dev/null 2>&1");
5509        if (($? >> 8)==0) {
5510            $valgrind_tool="--tool=memcheck";
5511        }
5512        open(C, "<$CURL");
5513        my $l = <C>;
5514        if($l =~ /^\#\!/) {
5515            # A shell script. This is typically when built with libtool,
5516            $valgrind="../libtool --mode=execute $valgrind";
5517        }
5518        close(C);
5519
5520        # valgrind 3 renamed the --logfile option to --log-file!!!
5521        my $ver=join(' ', runclientoutput("valgrind --version"));
5522        # cut off all but digits and dots
5523        $ver =~ s/[^0-9.]//g;
5524
5525        if($ver =~ /^(\d+)/) {
5526            $ver = $1;
5527            if($ver >= 3) {
5528                $valgrind_logfile="--log-file";
5529            }
5530        }
5531    }
5532}
5533
5534if ($gdbthis) {
5535    # open the executable curl and read the first 4 bytes of it
5536    open(CHECK, "<$CURL");
5537    my $c;
5538    sysread CHECK, $c, 4;
5539    close(CHECK);
5540    if($c eq "#! /") {
5541        # A shell script. This is typically when built with libtool,
5542        $libtool = 1;
5543        $gdb = "../libtool --mode=execute gdb";
5544    }
5545}
5546
5547$HTTPUNIXPATH    = "http$$.sock"; # HTTP server Unix domain socket path
5548
5549#######################################################################
5550# clear and create logging directory:
5551#
5552
5553cleardir($LOGDIR);
5554mkdir($LOGDIR, 0777);
5555
5556#######################################################################
5557# initialize some variables
5558#
5559
5560get_disttests();
5561init_serverpidfile_hash();
5562
5563#######################################################################
5564# Output curl version and host info being tested
5565#
5566
5567if(!$listonly) {
5568    checksystem();
5569}
5570
5571# globally disabled tests
5572disabledtests("$TESTDIR/DISABLED");
5573
5574#######################################################################
5575# Fetch all disabled tests, if there are any
5576#
5577
5578sub disabledtests {
5579    my ($file) = @_;
5580    my @input;
5581
5582    if(open(D, "<$file")) {
5583        while(<D>) {
5584            if(/^ *\#/) {
5585                # allow comments
5586                next;
5587            }
5588            push @input, $_;
5589        }
5590        close(D);
5591
5592        # preprocess the input to make conditionally disabled tests depending
5593        # on variables
5594        my @pp = prepro(@input);
5595        for my $t (@pp) {
5596            if($t =~ /(\d+)/) {
5597                my ($n) = $1;
5598                $disabled{$n}=$n; # disable this test number
5599                if(! -f "$srcdir/data/test$n") {
5600                    print STDERR "WARNING! Non-existing test $n in $file!\n";
5601                    # fail hard to make user notice
5602                    exit 1;
5603                }
5604                logmsg "DISABLED: test $n\n" if ($verbose);
5605            }
5606            else {
5607                print STDERR "$file: rubbish content: $t\n";
5608                exit 2;
5609            }
5610        }
5611    }
5612}
5613
5614#######################################################################
5615# If 'all' tests are requested, find out all test numbers
5616#
5617
5618if ( $TESTCASES eq "all") {
5619    # Get all commands and find out their test numbers
5620    opendir(DIR, $TESTDIR) || die "can't opendir $TESTDIR: $!";
5621    my @cmds = grep { /^test([0-9]+)$/ && -f "$TESTDIR/$_" } readdir(DIR);
5622    closedir(DIR);
5623
5624    $TESTCASES=""; # start with no test cases
5625
5626    # cut off everything but the digits
5627    for(@cmds) {
5628        $_ =~ s/[a-z\/\.]*//g;
5629    }
5630    # sort the numbers from low to high
5631    foreach my $n (sort { $a <=> $b } @cmds) {
5632        if($disabled{$n}) {
5633            # skip disabled test cases
5634            my $why = "configured as DISABLED";
5635            $skipped++;
5636            $skipped{$why}++;
5637            $teststat[$n]=$why; # store reason for this test case
5638            next;
5639        }
5640        $TESTCASES .= " $n";
5641    }
5642}
5643else {
5644    my $verified="";
5645    map {
5646        if (-e "$TESTDIR/test$_") {
5647            $verified.="$_ ";
5648        }
5649    } split(" ", $TESTCASES);
5650    if($verified eq "") {
5651        print "No existing test cases were specified\n";
5652        exit;
5653    }
5654    $TESTCASES = $verified;
5655}
5656if($repeat) {
5657    my $s;
5658    for(1 .. $repeat) {
5659        $s .= $TESTCASES;
5660    }
5661    $TESTCASES = $s;
5662}
5663
5664if($scrambleorder) {
5665    # scramble the order of the test cases
5666    my @rand;
5667    while($TESTCASES) {
5668        my @all = split(/ +/, $TESTCASES);
5669        if(!$all[0]) {
5670            # if the first is blank, shift away it
5671            shift @all;
5672        }
5673        my $r = rand @all;
5674        push @rand, $all[$r];
5675        $all[$r]="";
5676        $TESTCASES = join(" ", @all);
5677    }
5678    $TESTCASES = join(" ", @rand);
5679}
5680
5681# Display the contents of the given file.  Line endings are canonicalized
5682# and excessively long files are elided
5683sub displaylogcontent {
5684    my ($file)=@_;
5685    if(open(SINGLE, "<$file")) {
5686        my $linecount = 0;
5687        my $truncate;
5688        my @tail;
5689        while(my $string = <SINGLE>) {
5690            $string =~ s/\r\n/\n/g;
5691            $string =~ s/[\r\f\032]/\n/g;
5692            $string .= "\n" unless ($string =~ /\n$/);
5693            $string =~ tr/\n//;
5694            for my $line (split("\n", $string)) {
5695                $line =~ s/\s*\!$//;
5696                if ($truncate) {
5697                    push @tail, " $line\n";
5698                } else {
5699                    logmsg " $line\n";
5700                }
5701                $linecount++;
5702                $truncate = $linecount > 1000;
5703            }
5704        }
5705        if(@tail) {
5706            my $tailshow = 200;
5707            my $tailskip = 0;
5708            my $tailtotal = scalar @tail;
5709            if($tailtotal > $tailshow) {
5710                $tailskip = $tailtotal - $tailshow;
5711                logmsg "=== File too long: $tailskip lines omitted here\n";
5712            }
5713            for($tailskip .. $tailtotal-1) {
5714                logmsg "$tail[$_]";
5715            }
5716        }
5717        close(SINGLE);
5718    }
5719}
5720
5721sub displaylogs {
5722    my ($testnum)=@_;
5723    opendir(DIR, "$LOGDIR") ||
5724        die "can't open dir: $!";
5725    my @logs = readdir(DIR);
5726    closedir(DIR);
5727
5728    logmsg "== Contents of files in the $LOGDIR/ dir after test $testnum\n";
5729    foreach my $log (sort @logs) {
5730        if($log =~ /\.(\.|)$/) {
5731            next; # skip "." and ".."
5732        }
5733        if($log =~ /^\.nfs/) {
5734            next; # skip ".nfs"
5735        }
5736        if(($log eq "memdump") || ($log eq "core")) {
5737            next; # skip "memdump" and  "core"
5738        }
5739        if((-d "$LOGDIR/$log") || (! -s "$LOGDIR/$log")) {
5740            next; # skip directory and empty files
5741        }
5742        if(($log =~ /^stdout\d+/) && ($log !~ /^stdout$testnum/)) {
5743            next; # skip stdoutNnn of other tests
5744        }
5745        if(($log =~ /^stderr\d+/) && ($log !~ /^stderr$testnum/)) {
5746            next; # skip stderrNnn of other tests
5747        }
5748        if(($log =~ /^upload\d+/) && ($log !~ /^upload$testnum/)) {
5749            next; # skip uploadNnn of other tests
5750        }
5751        if(($log =~ /^curl\d+\.out/) && ($log !~ /^curl$testnum\.out/)) {
5752            next; # skip curlNnn.out of other tests
5753        }
5754        if(($log =~ /^test\d+\.txt/) && ($log !~ /^test$testnum\.txt/)) {
5755            next; # skip testNnn.txt of other tests
5756        }
5757        if(($log =~ /^file\d+\.txt/) && ($log !~ /^file$testnum\.txt/)) {
5758            next; # skip fileNnn.txt of other tests
5759        }
5760        if(($log =~ /^netrc\d+/) && ($log !~ /^netrc$testnum/)) {
5761            next; # skip netrcNnn of other tests
5762        }
5763        if(($log =~ /^trace\d+/) && ($log !~ /^trace$testnum/)) {
5764            next; # skip traceNnn of other tests
5765        }
5766        if(($log =~ /^valgrind\d+/) && ($log !~ /^valgrind$testnum(\..*|)$/)) {
5767            next; # skip valgrindNnn of other tests
5768        }
5769        if(($log =~ /^test$testnum$/)) {
5770            next; # skip test$testnum since it can be very big
5771        }
5772        logmsg "=== Start of file $log\n";
5773        displaylogcontent("$LOGDIR/$log");
5774        logmsg "=== End of file $log\n";
5775    }
5776}
5777
5778#######################################################################
5779# Setup Azure Pipelines Test Run (if running in Azure DevOps)
5780#
5781
5782if(azure_check_environment()) {
5783    $AZURE_RUN_ID = azure_create_test_run($VCURL);
5784    logmsg "Azure Run ID: $AZURE_RUN_ID\n" if ($verbose);
5785}
5786
5787#######################################################################
5788# The main test-loop
5789#
5790
5791my $failed;
5792my $testnum;
5793my $ok=0;
5794my $ign=0;
5795my $total=0;
5796my $lasttest=0;
5797my @at = split(" ", $TESTCASES);
5798my $count=0;
5799
5800$start = time();
5801
5802foreach $testnum (@at) {
5803
5804    $lasttest = $testnum if($testnum > $lasttest);
5805    $count++;
5806
5807    my $error = singletest($run_event_based, $testnum, $count, scalar(@at));
5808
5809    # update test result in CI services
5810    if(azure_check_environment() && $AZURE_RUN_ID && $AZURE_RESULT_ID) {
5811        $AZURE_RESULT_ID = azure_update_test_result($VCURL, $AZURE_RUN_ID, $AZURE_RESULT_ID, $testnum, $error,
5812                                                    $timeprepini{$testnum}, $timevrfyend{$testnum});
5813    }
5814    elsif(appveyor_check_environment()) {
5815        appveyor_update_test_result($VCURL, $testnum, $error, $timeprepini{$testnum}, $timevrfyend{$testnum});
5816    }
5817
5818    if($error < 0) {
5819        # not a test we can run
5820        next;
5821    }
5822
5823    $total++; # number of tests we've run
5824
5825    if($error>0) {
5826        if($error==2) {
5827            # ignored test failures are wrapped in ()
5828            $failed.= "($testnum) ";
5829        }
5830        else {
5831            $failed.= "$testnum ";
5832        }
5833        if($postmortem) {
5834            # display all files in log/ in a nice way
5835            displaylogs($testnum);
5836        }
5837        if($error==2) {
5838            $ign++; # ignored test result counter
5839        }
5840        elsif(!$anyway) {
5841            # a test failed, abort
5842            logmsg "\n - abort tests\n";
5843            last;
5844        }
5845    }
5846    elsif(!$error) {
5847        $ok++; # successful test counter
5848    }
5849
5850    # loop for next test
5851}
5852
5853my $sofar = time() - $start;
5854
5855#######################################################################
5856# Finish Azure Pipelines Test Run (if running in Azure DevOps)
5857#
5858
5859if(azure_check_environment() && $AZURE_RUN_ID) {
5860    $AZURE_RUN_ID = azure_update_test_run($VCURL, $AZURE_RUN_ID);
5861}
5862
5863# Tests done, stop the servers
5864stopservers($verbose);
5865
5866my $all = $total + $skipped;
5867
5868runtimestats($lasttest);
5869
5870if($total) {
5871    logmsg sprintf("TESTDONE: $ok tests out of $total reported OK: %d%%\n",
5872                   $ok/$total*100);
5873
5874    if($ok != $total) {
5875        logmsg "\nTESTFAIL: These test cases failed: $failed\n\n";
5876    }
5877}
5878else {
5879    logmsg "\nTESTFAIL: No tests were performed\n\n";
5880    if(scalar(keys %enabled_keywords)) {
5881        logmsg "TESTFAIL: Nothing matched these keywords: ";
5882        for(keys %enabled_keywords) {
5883            logmsg "$_ ";
5884        }
5885        logmsg "\n";
5886    }
5887}
5888
5889if($all) {
5890    logmsg "TESTDONE: $all tests were considered during ".
5891        sprintf("%.0f", $sofar) ." seconds.\n";
5892}
5893
5894if($skipped && !$short) {
5895    my $s=0;
5896    logmsg "TESTINFO: $skipped tests were skipped due to these restraints:\n";
5897
5898    for(keys %skipped) {
5899        my $r = $_;
5900        printf "TESTINFO: \"%s\" %d times (", $r, $skipped{$_};
5901
5902        # now show all test case numbers that had this reason for being
5903        # skipped
5904        my $c=0;
5905        my $max = 9;
5906        for(0 .. scalar @teststat) {
5907            my $t = $_;
5908            if($teststat[$_] && ($teststat[$_] eq $r)) {
5909                if($c < $max) {
5910                    logmsg ", " if($c);
5911                    logmsg $_;
5912                }
5913                $c++;
5914            }
5915        }
5916        if($c > $max) {
5917            logmsg " and ".($c-$max)." more";
5918        }
5919        logmsg ")\n";
5920    }
5921}
5922
5923if(($total && (($ok+$ign) != $total)) || !$total) {
5924    exit 1;
5925}
5926