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