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