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