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