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