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