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