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