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