1#!/usr/bin/env perl 2#*************************************************************************** 3# _ _ ____ _ 4# Project ___| | | | _ \| | 5# / __| | | | |_) | | 6# | (__| |_| | _ <| |___ 7# \___|\___/|_| \_\_____| 8# 9# Copyright (C) 1998 - 2011, 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 http://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 @INC=(@INC, $ENV{'srcdir'}, "."); 60 # run time statistics needs Time::HiRes 61 eval { 62 no warnings "all"; 63 require Time::HiRes; 64 import Time::HiRes qw( time ); 65 } 66} 67 68use strict; 69use warnings; 70use Cwd; 71 72# Subs imported from serverhelp module 73use serverhelp qw( 74 serverfactors 75 servername_id 76 servername_str 77 servername_canon 78 server_pidfilename 79 server_logfilename 80 ); 81 82# Variables and subs imported from sshhelp module 83use sshhelp qw( 84 $sshdexe 85 $sshexe 86 $sftpexe 87 $sshconfig 88 $sftpconfig 89 $sshdlog 90 $sshlog 91 $sftplog 92 $sftpcmds 93 display_sshdconfig 94 display_sshconfig 95 display_sftpconfig 96 display_sshdlog 97 display_sshlog 98 display_sftplog 99 exe_ext 100 find_sshd 101 find_ssh 102 find_sftp 103 find_httptlssrv 104 sshversioninfo 105 ); 106 107require "getpart.pm"; # array functions 108require "valgrind.pm"; # valgrind report parser 109require "ftp.pm"; 110 111my $HOSTIP="127.0.0.1"; # address on which the test server listens 112my $HOST6IP="[::1]"; # address on which the test server listens 113my $CLIENTIP="127.0.0.1"; # address which curl uses for incoming connections 114my $CLIENT6IP="[::1]"; # address which curl uses for incoming connections 115 116my $base = 8990; # base port number 117 118my $HTTPPORT; # HTTP server port 119my $HTTP6PORT; # HTTP IPv6 server port 120my $HTTPSPORT; # HTTPS (stunnel) server port 121my $FTPPORT; # FTP server port 122my $FTP2PORT; # FTP server 2 port 123my $FTPSPORT; # FTPS (stunnel) server port 124my $FTP6PORT; # FTP IPv6 server port 125my $TFTPPORT; # TFTP 126my $TFTP6PORT; # TFTP 127my $SSHPORT; # SCP/SFTP 128my $SOCKSPORT; # SOCKS4/5 port 129my $POP3PORT; # POP3 130my $POP36PORT; # POP3 IPv6 server port 131my $IMAPPORT; # IMAP 132my $IMAP6PORT; # IMAP IPv6 server port 133my $SMTPPORT; # SMTP 134my $SMTP6PORT; # SMTP IPv6 server port 135my $RTSPPORT; # RTSP 136my $RTSP6PORT; # RTSP IPv6 server port 137my $GOPHERPORT; # Gopher 138my $GOPHER6PORT; # Gopher IPv6 server port 139my $HTTPTLSPORT; # HTTP TLS (non-stunnel) server port 140my $HTTPTLS6PORT; # HTTP TLS (non-stunnel) IPv6 server port 141 142my $srcdir = $ENV{'srcdir'} || '.'; 143my $CURL="../src/curl".exe_ext(); # what curl executable to run on the tests 144my $VCURL=$CURL; # what curl binary to use to verify the servers with 145 # VCURL is handy to set to the system one when the one you 146 # just built hangs or crashes and thus prevent verification 147my $DBGCURL=$CURL; #"../src/.libs/curl"; # alternative for debugging 148my $LOGDIR="log"; 149my $TESTDIR="$srcdir/data"; 150my $LIBDIR="./libtest"; 151my $UNITDIR="./unit"; 152my $SERVERIN="$LOGDIR/server.input"; # what curl sent the server 153my $SERVER2IN="$LOGDIR/server2.input"; # what curl sent the second server 154my $CURLLOG="$LOGDIR/curl.log"; # all command lines run 155my $FTPDCMD="$LOGDIR/ftpserver.cmd"; # copy ftp server instructions here 156my $SERVERLOGS_LOCK="$LOGDIR/serverlogs.lock"; # server logs advisor read lock 157my $CURLCONFIG="../curl-config"; # curl-config from current build 158 159# Normally, all test cases should be run, but at times it is handy to 160# simply run a particular one: 161my $TESTCASES="all"; 162 163# To run specific test cases, set them like: 164# $TESTCASES="1 2 3 7 8"; 165 166####################################################################### 167# No variables below this point should need to be modified 168# 169 170# invoke perl like this: 171my $perl="perl -I$srcdir"; 172my $server_response_maxtime=13; 173 174my $debug_build=0; # curl built with --enable-debug 175my $curl_debug=0; # curl built with --enable-curldebug (memory tracking) 176my $libtool; 177 178# name of the file that the memory debugging creates: 179my $memdump="$LOGDIR/memdump"; 180 181# the path to the script that analyzes the memory debug output file: 182my $memanalyze="$perl $srcdir/memanalyze.pl"; 183 184my $pwd = getcwd(); # current working directory 185 186my $start; 187my $forkserver=0; 188my $ftpchecktime=1; # time it took to verify our test FTP server 189 190my $stunnel = checkcmd("stunnel4") || checkcmd("stunnel"); 191my $valgrind = checktestcmd("valgrind"); 192my $valgrind_logfile="--logfile"; 193my $valgrind_tool; 194my $gdb = checktestcmd("gdb"); 195my $httptlssrv = find_httptlssrv(); 196 197my $ssl_version; # set if libcurl is built with SSL support 198my $large_file; # set if libcurl is built with large file support 199my $has_idn; # set if libcurl is built with IDN support 200my $http_ipv6; # set if HTTP server has IPv6 support 201my $ftp_ipv6; # set if FTP server has IPv6 support 202my $tftp_ipv6; # set if TFTP server has IPv6 support 203my $gopher_ipv6; # set if Gopher server has IPv6 support 204my $has_ipv6; # set if libcurl is built with IPv6 support 205my $has_libz; # set if libcurl is built with libz support 206my $has_getrlimit; # set if system has getrlimit() 207my $has_ntlm; # set if libcurl is built with NTLM support 208my $has_ntlm_wb; # set if libcurl is built with NTLM delegation to winbind 209my $has_charconv;# set if libcurl is built with CharConv support 210my $has_tls_srp; # set if libcurl is built with TLS-SRP support 211 212my $has_openssl; # built with a lib using an OpenSSL-like API 213my $has_gnutls; # built with GnuTLS 214my $has_nss; # built with NSS 215my $has_yassl; # built with yassl 216my $has_polarssl;# built with polarssl 217my $has_axtls; # built with axTLS 218 219my $has_shared; # built shared 220 221my $ssllib; # name of the lib we use (for human presentation) 222my $has_crypto; # set if libcurl is built with cryptographic support 223my $has_textaware; # set if running on a system that has a text mode concept 224 # on files. Windows for example 225 226my @protocols; # array of lowercase supported protocol servers 227 228my $skipped=0; # number of tests skipped; reported in main loop 229my %skipped; # skipped{reason}=counter, reasons for skip 230my @teststat; # teststat[testnum]=reason, reasons for skip 231my %disabled_keywords; # key words of tests to skip 232my %enabled_keywords; # key words of tests to run 233my %disabled; # disabled test cases 234 235my $sshdid; # for socks server, ssh daemon version id 236my $sshdvernum; # for socks server, ssh daemon version number 237my $sshdverstr; # for socks server, ssh daemon version string 238my $sshderror; # for socks server, ssh daemon version error 239 240my $defserverlogslocktimeout = 20; # timeout to await server logs lock removal 241my $defpostcommanddelay = 0; # delay between command and postcheck sections 242 243my $timestats; # time stamping and stats generation 244my $fullstats; # show time stats for every single test 245my %timeprepini; # timestamp for each test preparation start 246my %timesrvrini; # timestamp for each test required servers verification start 247my %timesrvrend; # timestamp for each test required servers verification end 248my %timetoolini; # timestamp for each test command run starting 249my %timetoolend; # timestamp for each test command run stopping 250my %timesrvrlog; # timestamp for each test server logs lock removal 251my %timevrfyend; # timestamp for each test result verification end 252 253my $testnumcheck; # test number, set in singletest sub. 254my %oldenv; 255 256####################################################################### 257# variables the command line options may set 258# 259 260my $short; 261my $verbose; 262my $debugprotocol; 263my $anyway; 264my $gdbthis; # run test case with gdb debugger 265my $gdbxwin; # use windowed gdb when using gdb 266my $keepoutfiles; # keep stdout and stderr files after tests 267my $listonly; # only list the tests 268my $postmortem; # display detailed info about failed tests 269 270my %run; # running server 271my %doesntrun; # servers that don't work, identified by pidfile 272my %serverpidfile;# all server pid file names, identified by server id 273my %runcert; # cert file currently in use by an ssl running server 274 275# torture test variables 276my $torture; 277my $tortnum; 278my $tortalloc; 279 280####################################################################### 281# logmsg is our general message logging subroutine. 282# 283sub logmsg { 284 for(@_) { 285 print "$_"; 286 } 287} 288 289# get the name of the current user 290my $USER = $ENV{USER}; # Linux 291if (!$USER) { 292 $USER = $ENV{USERNAME}; # Windows 293 if (!$USER) { 294 $USER = $ENV{LOGNAME}; # Some UNIX (I think) 295 } 296} 297 298# enable memory debugging if curl is compiled with it 299$ENV{'CURL_MEMDEBUG'} = $memdump; 300$ENV{'HOME'}=$pwd; 301 302sub catch_zap { 303 my $signame = shift; 304 logmsg "runtests.pl received SIG$signame, exiting\n"; 305 stopservers($verbose); 306 die "Somebody sent me a SIG$signame"; 307} 308$SIG{INT} = \&catch_zap; 309$SIG{TERM} = \&catch_zap; 310 311########################################################################## 312# Clear all possible '*_proxy' environment variables for various protocols 313# to prevent them to interfere with our testing! 314 315my $protocol; 316foreach $protocol (('ftp', 'http', 'ftps', 'https', 'no', 'all')) { 317 my $proxy = "${protocol}_proxy"; 318 # clear lowercase version 319 delete $ENV{$proxy} if($ENV{$proxy}); 320 # clear uppercase version 321 delete $ENV{uc($proxy)} if($ENV{uc($proxy)}); 322} 323 324# make sure we don't get affected by other variables that control our 325# behaviour 326 327delete $ENV{'SSL_CERT_DIR'} if($ENV{'SSL_CERT_DIR'}); 328delete $ENV{'SSL_CERT_PATH'} if($ENV{'SSL_CERT_PATH'}); 329delete $ENV{'CURL_CA_BUNDLE'} if($ENV{'CURL_CA_BUNDLE'}); 330 331####################################################################### 332# Load serverpidfile hash with pidfile names for all possible servers. 333# 334sub init_serverpidfile_hash { 335 for my $proto (('ftp', 'http', 'imap', 'pop3', 'smtp')) { 336 for my $ssl (('', 's')) { 337 for my $ipvnum ((4, 6)) { 338 for my $idnum ((1, 2)) { 339 my $serv = servername_id("$proto$ssl", $ipvnum, $idnum); 340 my $pidf = server_pidfilename("$proto$ssl", $ipvnum, $idnum); 341 $serverpidfile{$serv} = $pidf; 342 } 343 } 344 } 345 } 346 for my $proto (('tftp', 'sftp', 'socks', 'ssh', 'rtsp', 'gopher', 'httptls')) { 347 for my $ipvnum ((4, 6)) { 348 for my $idnum ((1, 2)) { 349 my $serv = servername_id($proto, $ipvnum, $idnum); 350 my $pidf = server_pidfilename($proto, $ipvnum, $idnum); 351 $serverpidfile{$serv} = $pidf; 352 } 353 } 354 } 355} 356 357####################################################################### 358# Check if a given child process has just died. Reaps it if so. 359# 360sub checkdied { 361 use POSIX ":sys_wait_h"; 362 my $pid = $_[0]; 363 if(not defined $pid || $pid <= 0) { 364 return 0; 365 } 366 my $rc = waitpid($pid, &WNOHANG); 367 return ($rc == $pid)?1:0; 368} 369 370####################################################################### 371# Start a new thread/process and run the given command line in there. 372# Return the pids (yes plural) of the new child process to the parent. 373# 374sub startnew { 375 my ($cmd, $pidfile, $timeout, $fake)=@_; 376 377 logmsg "startnew: $cmd\n" if ($verbose); 378 379 my $child = fork(); 380 my $pid2 = 0; 381 382 if(not defined $child) { 383 logmsg "startnew: fork() failure detected\n"; 384 return (-1,-1); 385 } 386 387 if(0 == $child) { 388 # Here we are the child. Run the given command. 389 390 # Put an "exec" in front of the command so that the child process 391 # keeps this child's process ID. 392 exec("exec $cmd") || die "Can't exec() $cmd: $!"; 393 394 # exec() should never return back here to this process. We protect 395 # ourselves by calling die() just in case something goes really bad. 396 die "error: exec() has returned"; 397 } 398 399 # Ugly hack but ssh client and gnutls-serv don't support pid files 400 if ($fake) { 401 if(open(OUT, ">$pidfile")) { 402 print OUT $child . "\n"; 403 close(OUT); 404 logmsg "startnew: $pidfile faked with pid=$child\n" if($verbose); 405 } 406 else { 407 logmsg "startnew: failed to write fake $pidfile with pid=$child\n"; 408 } 409 # could/should do a while connect fails sleep a bit and loop 410 sleep $timeout; 411 if (checkdied($child)) { 412 logmsg "startnew: child process has failed to start\n" if($verbose); 413 return (-1,-1); 414 } 415 } 416 417 my $count = $timeout; 418 while($count--) { 419 if(-f $pidfile && -s $pidfile && open(PID, "<$pidfile")) { 420 $pid2 = 0 + <PID>; 421 close(PID); 422 if(($pid2 > 0) && kill(0, $pid2)) { 423 # if $pid2 is valid, then make sure this pid is alive, as 424 # otherwise it is just likely to be the _previous_ pidfile or 425 # similar! 426 last; 427 } 428 # invalidate $pid2 if not actually alive 429 $pid2 = 0; 430 } 431 if (checkdied($child)) { 432 logmsg "startnew: child process has died, server might start up\n" 433 if($verbose); 434 # We can't just abort waiting for the server with a 435 # return (-1,-1); 436 # because the server might have forked and could still start 437 # up normally. Instead, just reduce the amount of time we remain 438 # waiting. 439 $count >>= 2; 440 } 441 sleep(1); 442 } 443 444 # Return two PIDs, the one for the child process we spawned and the one 445 # reported by the server itself (in case it forked again on its own). 446 # Both (potentially) need to be killed at the end of the test. 447 return ($child, $pid2); 448} 449 450 451####################################################################### 452# Check for a command in the PATH of the test server. 453# 454sub checkcmd { 455 my ($cmd)=@_; 456 my @paths=(split(":", $ENV{'PATH'}), "/usr/sbin", "/usr/local/sbin", 457 "/sbin", "/usr/bin", "/usr/local/bin", 458 "./libtest/.libs", "./libtest"); 459 for(@paths) { 460 if( -x "$_/$cmd" && ! -d "$_/$cmd") { 461 # executable bit but not a directory! 462 return "$_/$cmd"; 463 } 464 } 465} 466 467####################################################################### 468# Get the list of tests that the tests/data/Makefile.am knows about! 469# 470my $disttests; 471sub get_disttests { 472 my @dist = `cd data && make show`; 473 $disttests = join("", @dist); 474} 475 476####################################################################### 477# Check for a command in the PATH of the machine running curl. 478# 479sub checktestcmd { 480 my ($cmd)=@_; 481 return checkcmd($cmd); 482} 483 484####################################################################### 485# Run the application under test and return its return code 486# 487sub runclient { 488 my ($cmd)=@_; 489 return system($cmd); 490 491# This is one way to test curl on a remote machine 492# my $out = system("ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'"); 493# sleep 2; # time to allow the NFS server to be updated 494# return $out; 495} 496 497####################################################################### 498# Run the application under test and return its stdout 499# 500sub runclientoutput { 501 my ($cmd)=@_; 502 return `$cmd`; 503 504# This is one way to test curl on a remote machine 505# my @out = `ssh $CLIENTIP cd \'$pwd\' \\; \'$cmd\'`; 506# sleep 2; # time to allow the NFS server to be updated 507# return @out; 508 } 509 510####################################################################### 511# Memory allocation test and failure torture testing. 512# 513sub torture { 514 my $testcmd = shift; 515 my $gdbline = shift; 516 517 # remove memdump first to be sure we get a new nice and clean one 518 unlink($memdump); 519 520 # First get URL from test server, ignore the output/result 521 runclient($testcmd); 522 523 logmsg " CMD: $testcmd\n" if($verbose); 524 525 # memanalyze -v is our friend, get the number of allocations made 526 my $count=0; 527 my @out = `$memanalyze -v $memdump`; 528 for(@out) { 529 if(/^Allocations: (\d+)/) { 530 $count = $1; 531 last; 532 } 533 } 534 if(!$count) { 535 logmsg " found no allocs to make fail\n"; 536 return 0; 537 } 538 539 logmsg " $count allocations to make fail\n"; 540 541 for ( 1 .. $count ) { 542 my $limit = $_; 543 my $fail; 544 my $dumped_core; 545 546 if($tortalloc && ($tortalloc != $limit)) { 547 next; 548 } 549 550 if($verbose) { 551 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 552 localtime(time()); 553 my $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec); 554 logmsg "Fail alloc no: $limit at $now\r"; 555 } 556 557 # make the memory allocation function number $limit return failure 558 $ENV{'CURL_MEMLIMIT'} = $limit; 559 560 # remove memdump first to be sure we get a new nice and clean one 561 unlink($memdump); 562 563 logmsg "*** Alloc number $limit is now set to fail ***\n" if($gdbthis); 564 565 my $ret = 0; 566 if($gdbthis) { 567 runclient($gdbline) 568 } 569 else { 570 $ret = runclient($testcmd); 571 } 572 #logmsg "$_ Returned " . $ret >> 8 . "\n"; 573 574 # Now clear the variable again 575 delete $ENV{'CURL_MEMLIMIT'} if($ENV{'CURL_MEMLIMIT'}); 576 577 if(-r "core") { 578 # there's core file present now! 579 logmsg " core dumped\n"; 580 $dumped_core = 1; 581 $fail = 2; 582 } 583 584 # verify that it returns a proper error code, doesn't leak memory 585 # and doesn't core dump 586 if($ret & 255) { 587 logmsg " system() returned $ret\n"; 588 $fail=1; 589 } 590 else { 591 my @memdata=`$memanalyze $memdump`; 592 my $leak=0; 593 for(@memdata) { 594 if($_ ne "") { 595 # well it could be other memory problems as well, but 596 # we call it leak for short here 597 $leak=1; 598 } 599 } 600 if($leak) { 601 logmsg "** MEMORY FAILURE\n"; 602 logmsg @memdata; 603 logmsg `$memanalyze -l $memdump`; 604 $fail = 1; 605 } 606 } 607 if($fail) { 608 logmsg " Failed on alloc number $limit in test.\n", 609 " invoke with \"-t$limit\" to repeat this single case.\n"; 610 stopservers($verbose); 611 return 1; 612 } 613 } 614 615 logmsg "torture OK\n"; 616 return 0; 617} 618 619####################################################################### 620# Stop a test server along with pids which aren't in the %run hash yet. 621# This also stops all servers which are relative to the given one. 622# 623sub stopserver { 624 my ($server, $pidlist) = @_; 625 # 626 # kill sockfilter processes for pingpong relative server 627 # 628 if($server =~ /^(ftp|imap|pop3|smtp)s?(\d*)(-ipv6|)$/) { 629 my $proto = $1; 630 my $idnum = ($2 && ($2 > 1)) ? $2 : 1; 631 my $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4; 632 killsockfilters($proto, $ipvnum, $idnum, $verbose); 633 } 634 # 635 # All servers relative to the given one must be stopped also 636 # 637 my @killservers; 638 if($server =~ /^(ftp|http|imap|pop3|smtp)s((\d*)(-ipv6|))$/) { 639 # given a stunnel based ssl server, also kill non-ssl underlying one 640 push @killservers, "${1}${2}"; 641 } 642 elsif($server =~ /^(ftp|http|imap|pop3|smtp)((\d*)(-ipv6|))$/) { 643 # given a non-ssl server, also kill stunnel based ssl piggybacking one 644 push @killservers, "${1}s${2}"; 645 } 646 elsif($server =~ /^(socks)((\d*)(-ipv6|))$/) { 647 # given a socks server, also kill ssh underlying one 648 push @killservers, "ssh${2}"; 649 } 650 elsif($server =~ /^(ssh)((\d*)(-ipv6|))$/) { 651 # given a ssh server, also kill socks piggybacking one 652 push @killservers, "socks${2}"; 653 } 654 push @killservers, $server; 655 # 656 # kill given pids and server relative ones clearing them in %run hash 657 # 658 foreach my $server (@killservers) { 659 if($run{$server}) { 660 # we must prepend a space since $pidlist may already contain a pid 661 $pidlist .= " $run{$server}"; 662 $run{$server} = 0; 663 } 664 $runcert{$server} = 0 if($runcert{$server}); 665 } 666 killpid($verbose, $pidlist); 667 # 668 # cleanup server pid files 669 # 670 foreach my $server (@killservers) { 671 my $pidfile = $serverpidfile{$server}; 672 my $pid = processexists($pidfile); 673 if($pid > 0) { 674 logmsg "Warning: $server server unexpectedly alive\n"; 675 killpid($verbose, $pid); 676 } 677 unlink($pidfile) if(-f $pidfile); 678 } 679} 680 681####################################################################### 682# Verify that the server that runs on $ip, $port is our server. This also 683# implies that we can speak with it, as there might be occasions when the 684# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't 685# assign requested address") 686# 687sub verifyhttp { 688 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 689 my $server = servername_id($proto, $ipvnum, $idnum); 690 my $pid = 0; 691 my $bonus=""; 692 693 my $verifyout = "$LOGDIR/". 694 servername_canon($proto, $ipvnum, $idnum) .'_verify.out'; 695 unlink($verifyout) if(-f $verifyout); 696 697 my $verifylog = "$LOGDIR/". 698 servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; 699 unlink($verifylog) if(-f $verifylog); 700 701 if($proto eq "gopher") { 702 # gopher is funny 703 $bonus="1/"; 704 } 705 706 my $flags = "--max-time $server_response_maxtime "; 707 $flags .= "--output $verifyout "; 708 $flags .= "--silent "; 709 $flags .= "--verbose "; 710 $flags .= "--globoff "; 711 $flags .= "-1 " if($has_axtls); 712 $flags .= "--insecure " if($proto eq 'https'); 713 $flags .= "\"$proto://$ip:$port/${bonus}verifiedserver\""; 714 715 my $cmd = "$VCURL $flags 2>$verifylog"; 716 717 # verify if our/any server is running on this port 718 logmsg "RUN: $cmd\n" if($verbose); 719 my $res = runclient($cmd); 720 721 $res >>= 8; # rotate the result 722 if($res & 128) { 723 logmsg "RUN: curl command died with a coredump\n"; 724 return -1; 725 } 726 727 if($res && $verbose) { 728 logmsg "RUN: curl command returned $res\n"; 729 if(open(FILE, "<$verifylog")) { 730 while(my $string = <FILE>) { 731 logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); 732 } 733 close(FILE); 734 } 735 } 736 737 my $data; 738 if(open(FILE, "<$verifyout")) { 739 while(my $string = <FILE>) { 740 $data = $string; 741 last; # only want first line 742 } 743 close(FILE); 744 } 745 746 if($data && ($data =~ /WE ROOLZ: (\d+)/)) { 747 $pid = 0+$1; 748 } 749 elsif($res == 6) { 750 # curl: (6) Couldn't resolve host '::1' 751 logmsg "RUN: failed to resolve host ($proto://$ip:$port/verifiedserver)\n"; 752 return -1; 753 } 754 elsif($data || ($res && ($res != 7))) { 755 logmsg "RUN: Unknown server on our $server port: $port ($res)\n"; 756 return -1; 757 } 758 return $pid; 759} 760 761####################################################################### 762# Verify that the server that runs on $ip, $port is our server. This also 763# implies that we can speak with it, as there might be occasions when the 764# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't 765# assign requested address") 766# 767sub verifyftp { 768 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 769 my $server = servername_id($proto, $ipvnum, $idnum); 770 my $pid = 0; 771 my $time=time(); 772 my $extra=""; 773 774 my $verifylog = "$LOGDIR/". 775 servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; 776 unlink($verifylog) if(-f $verifylog); 777 778 if($proto eq "ftps") { 779 $extra .= "--insecure --ftp-ssl-control "; 780 } 781 elsif($proto eq "smtp") { 782 # SMTP is a bit different since it requires more options and it 783 # has _no_ output! 784 $extra .= "--mail-rcpt verifiedserver "; 785 $extra .= "--mail-from fake "; 786 $extra .= "--upload /dev/null "; 787 $extra .= "--stderr - "; # move stderr to parse the verbose stuff 788 } 789 790 my $flags = "--max-time $server_response_maxtime "; 791 $flags .= "--silent "; 792 $flags .= "--verbose "; 793 $flags .= "--globoff "; 794 $flags .= $extra; 795 $flags .= "\"$proto://$ip:$port/verifiedserver\""; 796 797 my $cmd = "$VCURL $flags 2>$verifylog"; 798 799 # check if this is our server running on this port: 800 logmsg "RUN: $cmd\n" if($verbose); 801 my @data = runclientoutput($cmd); 802 803 my $res = $? >> 8; # rotate the result 804 if($res & 128) { 805 logmsg "RUN: curl command died with a coredump\n"; 806 return -1; 807 } 808 809 foreach my $line (@data) { 810 if($line =~ /WE ROOLZ: (\d+)/) { 811 # this is our test server with a known pid! 812 $pid = 0+$1; 813 last; 814 } 815 } 816 if($pid <= 0 && @data && $data[0]) { 817 # this is not a known server 818 logmsg "RUN: Unknown server on our $server port: $port\n"; 819 return 0; 820 } 821 # we can/should use the time it took to verify the FTP server as a measure 822 # on how fast/slow this host/FTP is. 823 my $took = int(0.5+time()-$time); 824 825 if($verbose) { 826 logmsg "RUN: Verifying our test $server server took $took seconds\n"; 827 } 828 $ftpchecktime = $took>=1?$took:1; # make sure it never is below 1 829 830 return $pid; 831} 832 833####################################################################### 834# Verify that the server that runs on $ip, $port is our server. This also 835# implies that we can speak with it, as there might be occasions when the 836# server runs fine but we cannot talk to it ("Failed to connect to ::1: Can't 837# assign requested address") 838# 839sub verifyrtsp { 840 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 841 my $server = servername_id($proto, $ipvnum, $idnum); 842 my $pid = 0; 843 844 my $verifyout = "$LOGDIR/". 845 servername_canon($proto, $ipvnum, $idnum) .'_verify.out'; 846 unlink($verifyout) if(-f $verifyout); 847 848 my $verifylog = "$LOGDIR/". 849 servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; 850 unlink($verifylog) if(-f $verifylog); 851 852 my $flags = "--max-time $server_response_maxtime "; 853 $flags .= "--output $verifyout "; 854 $flags .= "--silent "; 855 $flags .= "--verbose "; 856 $flags .= "--globoff "; 857 # currently verification is done using http 858 $flags .= "\"http://$ip:$port/verifiedserver\""; 859 860 my $cmd = "$VCURL $flags 2>$verifylog"; 861 862 # verify if our/any server is running on this port 863 logmsg "RUN: $cmd\n" if($verbose); 864 my $res = runclient($cmd); 865 866 $res >>= 8; # rotate the result 867 if($res & 128) { 868 logmsg "RUN: curl command died with a coredump\n"; 869 return -1; 870 } 871 872 if($res && $verbose) { 873 logmsg "RUN: curl command returned $res\n"; 874 if(open(FILE, "<$verifylog")) { 875 while(my $string = <FILE>) { 876 logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); 877 } 878 close(FILE); 879 } 880 } 881 882 my $data; 883 if(open(FILE, "<$verifyout")) { 884 while(my $string = <FILE>) { 885 $data = $string; 886 last; # only want first line 887 } 888 close(FILE); 889 } 890 891 if($data && ($data =~ /RTSP_SERVER WE ROOLZ: (\d+)/)) { 892 $pid = 0+$1; 893 } 894 elsif($res == 6) { 895 # curl: (6) Couldn't resolve host '::1' 896 logmsg "RUN: failed to resolve host ($proto://$ip:$port/verifiedserver)\n"; 897 return -1; 898 } 899 elsif($data || ($res != 7)) { 900 logmsg "RUN: Unknown server on our $server port: $port\n"; 901 return -1; 902 } 903 return $pid; 904} 905 906####################################################################### 907# Verify that the ssh server has written out its pidfile, recovering 908# the pid from the file and returning it if a process with that pid is 909# actually alive. 910# 911sub verifyssh { 912 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 913 my $server = servername_id($proto, $ipvnum, $idnum); 914 my $pidfile = server_pidfilename($proto, $ipvnum, $idnum); 915 my $pid = 0; 916 if(open(FILE, "<$pidfile")) { 917 $pid=0+<FILE>; 918 close(FILE); 919 } 920 if($pid > 0) { 921 # if we have a pid it is actually our ssh server, 922 # since runsshserver() unlinks previous pidfile 923 if(!kill(0, $pid)) { 924 logmsg "RUN: SSH server has died after starting up\n"; 925 checkdied($pid); 926 unlink($pidfile); 927 $pid = -1; 928 } 929 } 930 return $pid; 931} 932 933####################################################################### 934# Verify that we can connect to the sftp server, properly authenticate 935# with generated config and key files and run a simple remote pwd. 936# 937sub verifysftp { 938 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 939 my $server = servername_id($proto, $ipvnum, $idnum); 940 my $verified = 0; 941 # Find out sftp client canonical file name 942 my $sftp = find_sftp(); 943 if(!$sftp) { 944 logmsg "RUN: SFTP server cannot find $sftpexe\n"; 945 return -1; 946 } 947 # Find out ssh client canonical file name 948 my $ssh = find_ssh(); 949 if(!$ssh) { 950 logmsg "RUN: SFTP server cannot find $sshexe\n"; 951 return -1; 952 } 953 # Connect to sftp server, authenticate and run a remote pwd 954 # command using our generated configuration and key files 955 my $cmd = "$sftp -b $sftpcmds -F $sftpconfig -S $ssh $ip > $sftplog 2>&1"; 956 my $res = runclient($cmd); 957 # Search for pwd command response in log file 958 if(open(SFTPLOGFILE, "<$sftplog")) { 959 while(<SFTPLOGFILE>) { 960 if(/^Remote working directory: /) { 961 $verified = 1; 962 last; 963 } 964 } 965 close(SFTPLOGFILE); 966 } 967 return $verified; 968} 969 970####################################################################### 971# Verify that the non-stunnel HTTP TLS extensions capable server that runs 972# on $ip, $port is our server. This also implies that we can speak with it, 973# as there might be occasions when the server runs fine but we cannot talk 974# to it ("Failed to connect to ::1: Can't assign requested address") 975# 976sub verifyhttptls { 977 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 978 my $server = servername_id($proto, $ipvnum, $idnum); 979 my $pidfile = server_pidfilename($proto, $ipvnum, $idnum); 980 my $pid = 0; 981 982 my $verifyout = "$LOGDIR/". 983 servername_canon($proto, $ipvnum, $idnum) .'_verify.out'; 984 unlink($verifyout) if(-f $verifyout); 985 986 my $verifylog = "$LOGDIR/". 987 servername_canon($proto, $ipvnum, $idnum) .'_verify.log'; 988 unlink($verifylog) if(-f $verifylog); 989 990 my $flags = "--max-time $server_response_maxtime "; 991 $flags .= "--output $verifyout "; 992 $flags .= "--verbose "; 993 $flags .= "--globoff "; 994 $flags .= "--insecure "; 995 $flags .= "--tlsauthtype SRP "; 996 $flags .= "--tlsuser jsmith "; 997 $flags .= "--tlspassword abc "; 998 $flags .= "\"https://$ip:$port/verifiedserver\""; 999 1000 my $cmd = "$VCURL $flags 2>$verifylog"; 1001 1002 # verify if our/any server is running on this port 1003 logmsg "RUN: $cmd\n" if($verbose); 1004 my $res = runclient($cmd); 1005 1006 $res >>= 8; # rotate the result 1007 if($res & 128) { 1008 logmsg "RUN: curl command died with a coredump\n"; 1009 return -1; 1010 } 1011 1012 if($res && $verbose) { 1013 logmsg "RUN: curl command returned $res\n"; 1014 if(open(FILE, "<$verifylog")) { 1015 while(my $string = <FILE>) { 1016 logmsg "RUN: $string" if($string !~ /^([ \t]*)$/); 1017 } 1018 close(FILE); 1019 } 1020 } 1021 1022 my $data; 1023 if(open(FILE, "<$verifyout")) { 1024 while(my $string = <FILE>) { 1025 $data .= $string; 1026 } 1027 close(FILE); 1028 } 1029 1030 if($data && ($data =~ /GNUTLS/) && open(FILE, "<$pidfile")) { 1031 $pid=0+<FILE>; 1032 close(FILE); 1033 if($pid > 0) { 1034 # if we have a pid it is actually our httptls server, 1035 # since runhttptlsserver() unlinks previous pidfile 1036 if(!kill(0, $pid)) { 1037 logmsg "RUN: $server server has died after starting up\n"; 1038 checkdied($pid); 1039 unlink($pidfile); 1040 $pid = -1; 1041 } 1042 } 1043 return $pid; 1044 } 1045 elsif($res == 6) { 1046 # curl: (6) Couldn't resolve host '::1' 1047 logmsg "RUN: failed to resolve host (https://$ip:$port/verifiedserver)\n"; 1048 return -1; 1049 } 1050 elsif($data || ($res && ($res != 7))) { 1051 logmsg "RUN: Unknown server on our $server port: $port ($res)\n"; 1052 return -1; 1053 } 1054 return $pid; 1055} 1056 1057####################################################################### 1058# STUB for verifying socks 1059# 1060sub verifysocks { 1061 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 1062 my $server = servername_id($proto, $ipvnum, $idnum); 1063 my $pidfile = server_pidfilename($proto, $ipvnum, $idnum); 1064 my $pid = 0; 1065 if(open(FILE, "<$pidfile")) { 1066 $pid=0+<FILE>; 1067 close(FILE); 1068 } 1069 if($pid > 0) { 1070 # if we have a pid it is actually our socks server, 1071 # since runsocksserver() unlinks previous pidfile 1072 if(!kill(0, $pid)) { 1073 logmsg "RUN: SOCKS server has died after starting up\n"; 1074 checkdied($pid); 1075 unlink($pidfile); 1076 $pid = -1; 1077 } 1078 } 1079 return $pid; 1080} 1081 1082####################################################################### 1083# Verify that the server that runs on $ip, $port is our server. 1084# Retry over several seconds before giving up. The ssh server in 1085# particular can take a long time to start if it needs to generate 1086# keys on a slow or loaded host. 1087# 1088# Just for convenience, test harness uses 'https' and 'httptls' literals 1089# as values for 'proto' variable in order to differentiate different 1090# servers. 'https' literal is used for stunnel based https test servers, 1091# and 'httptls' is used for non-stunnel https test servers. 1092# 1093 1094my %protofunc = ('http' => \&verifyhttp, 1095 'https' => \&verifyhttp, 1096 'rtsp' => \&verifyrtsp, 1097 'ftp' => \&verifyftp, 1098 'pop3' => \&verifyftp, 1099 'imap' => \&verifyftp, 1100 'smtp' => \&verifyftp, 1101 'ftps' => \&verifyftp, 1102 'tftp' => \&verifyftp, 1103 'ssh' => \&verifyssh, 1104 'socks' => \&verifysocks, 1105 'gopher' => \&verifyhttp, 1106 'httptls' => \&verifyhttptls); 1107 1108sub verifyserver { 1109 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 1110 1111 my $count = 30; # try for this many seconds 1112 my $pid; 1113 1114 while($count--) { 1115 my $fun = $protofunc{$proto}; 1116 1117 $pid = &$fun($proto, $ipvnum, $idnum, $ip, $port); 1118 1119 if($pid > 0) { 1120 last; 1121 } 1122 elsif($pid < 0) { 1123 # a real failure, stop trying and bail out 1124 return 0; 1125 } 1126 sleep(1); 1127 } 1128 return $pid; 1129} 1130 1131####################################################################### 1132# Single shot server responsiveness test. This should only be used 1133# to verify that a server present in %run hash is still functional 1134# 1135sub responsiveserver { 1136 my ($proto, $ipvnum, $idnum, $ip, $port) = @_; 1137 my $prev_verbose = $verbose; 1138 1139 $verbose = 0; 1140 my $fun = $protofunc{$proto}; 1141 my $pid = &$fun($proto, $ipvnum, $idnum, $ip, $port); 1142 $verbose = $prev_verbose; 1143 1144 if($pid > 0) { 1145 return 1; # responsive 1146 } 1147 1148 my $srvrname = servername_str($proto, $ipvnum, $idnum); 1149 logmsg " server precheck FAILED (unresponsive $srvrname server)\n"; 1150 return 0; 1151} 1152 1153####################################################################### 1154# start the http server 1155# 1156sub runhttpserver { 1157 my ($proto, $verbose, $ipv6, $port) = @_; 1158 my $ip = $HOSTIP; 1159 my $ipvnum = 4; 1160 my $idnum = 1; 1161 my $server; 1162 my $srvrname; 1163 my $pidfile; 1164 my $logfile; 1165 my $flags = ""; 1166 1167 if($ipv6) { 1168 # if IPv6, use a different setup 1169 $ipvnum = 6; 1170 $ip = $HOST6IP; 1171 } 1172 1173 $server = servername_id($proto, $ipvnum, $idnum); 1174 1175 $pidfile = $serverpidfile{$server}; 1176 1177 # don't retry if the server doesn't work 1178 if ($doesntrun{$pidfile}) { 1179 return (0,0); 1180 } 1181 1182 my $pid = processexists($pidfile); 1183 if($pid > 0) { 1184 stopserver($server, "$pid"); 1185 } 1186 unlink($pidfile) if(-f $pidfile); 1187 1188 $srvrname = servername_str($proto, $ipvnum, $idnum); 1189 1190 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1191 1192 $flags .= "--fork " if($forkserver); 1193 $flags .= "--gopher " if($proto eq "gopher"); 1194 $flags .= "--verbose " if($debugprotocol); 1195 $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; 1196 $flags .= "--id $idnum " if($idnum > 1); 1197 $flags .= "--ipv$ipvnum --port $port --srcdir \"$srcdir\""; 1198 1199 my $cmd = "$perl $srcdir/httpserver.pl $flags"; 1200 my ($httppid, $pid2) = startnew($cmd, $pidfile, 15, 0); 1201 1202 if($httppid <= 0 || !kill(0, $httppid)) { 1203 # it is NOT alive 1204 logmsg "RUN: failed to start the $srvrname server\n"; 1205 stopserver($server, "$pid2"); 1206 displaylogs($testnumcheck); 1207 $doesntrun{$pidfile} = 1; 1208 return (0,0); 1209 } 1210 1211 # Server is up. Verify that we can speak to it. 1212 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1213 if(!$pid3) { 1214 logmsg "RUN: $srvrname server failed verification\n"; 1215 # failed to talk to it properly. Kill the server and return failure 1216 stopserver($server, "$httppid $pid2"); 1217 displaylogs($testnumcheck); 1218 $doesntrun{$pidfile} = 1; 1219 return (0,0); 1220 } 1221 $pid2 = $pid3; 1222 1223 if($verbose) { 1224 logmsg "RUN: $srvrname server is now running PID $httppid\n"; 1225 } 1226 1227 sleep(1); 1228 1229 return ($httppid, $pid2); 1230} 1231 1232####################################################################### 1233# start the https stunnel based server 1234# 1235sub runhttpsserver { 1236 my ($verbose, $ipv6, $certfile) = @_; 1237 my $proto = 'https'; 1238 my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; 1239 my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 1240 my $idnum = 1; 1241 my $server; 1242 my $srvrname; 1243 my $pidfile; 1244 my $logfile; 1245 my $flags = ""; 1246 1247 if(!$stunnel) { 1248 return (0,0); 1249 } 1250 1251 $server = servername_id($proto, $ipvnum, $idnum); 1252 1253 $pidfile = $serverpidfile{$server}; 1254 1255 # don't retry if the server doesn't work 1256 if ($doesntrun{$pidfile}) { 1257 return (0,0); 1258 } 1259 1260 my $pid = processexists($pidfile); 1261 if($pid > 0) { 1262 stopserver($server, "$pid"); 1263 } 1264 unlink($pidfile) if(-f $pidfile); 1265 1266 $srvrname = servername_str($proto, $ipvnum, $idnum); 1267 1268 $certfile = 'stunnel.pem' unless($certfile); 1269 1270 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1271 1272 $flags .= "--verbose " if($debugprotocol); 1273 $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; 1274 $flags .= "--id $idnum " if($idnum > 1); 1275 $flags .= "--ipv$ipvnum --proto $proto "; 1276 $flags .= "--certfile \"$certfile\" " if($certfile ne 'stunnel.pem'); 1277 $flags .= "--stunnel \"$stunnel\" --srcdir \"$srcdir\" "; 1278 $flags .= "--connect $HTTPPORT --accept $HTTPSPORT"; 1279 1280 my $cmd = "$perl $srcdir/secureserver.pl $flags"; 1281 my ($httpspid, $pid2) = startnew($cmd, $pidfile, 15, 0); 1282 1283 if($httpspid <= 0 || !kill(0, $httpspid)) { 1284 # it is NOT alive 1285 logmsg "RUN: failed to start the $srvrname server\n"; 1286 stopserver($server, "$pid2"); 1287 displaylogs($testnumcheck); 1288 $doesntrun{$pidfile} = 1; 1289 return(0,0); 1290 } 1291 1292 # Server is up. Verify that we can speak to it. 1293 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $HTTPSPORT); 1294 if(!$pid3) { 1295 logmsg "RUN: $srvrname server failed verification\n"; 1296 # failed to talk to it properly. Kill the server and return failure 1297 stopserver($server, "$httpspid $pid2"); 1298 displaylogs($testnumcheck); 1299 $doesntrun{$pidfile} = 1; 1300 return (0,0); 1301 } 1302 # Here pid3 is actually the pid returned by the unsecure-http server. 1303 1304 $runcert{$server} = $certfile; 1305 1306 if($verbose) { 1307 logmsg "RUN: $srvrname server is now running PID $httpspid\n"; 1308 } 1309 1310 sleep(1); 1311 1312 return ($httpspid, $pid2); 1313} 1314 1315####################################################################### 1316# start the non-stunnel HTTP TLS extensions capable server 1317# 1318sub runhttptlsserver { 1319 my ($verbose, $ipv6) = @_; 1320 my $proto = "httptls"; 1321 my $port = ($ipv6 && ($ipv6 =~ /6$/)) ? $HTTPTLS6PORT : $HTTPTLSPORT; 1322 my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; 1323 my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 1324 my $idnum = 1; 1325 my $server; 1326 my $srvrname; 1327 my $pidfile; 1328 my $logfile; 1329 my $flags = ""; 1330 1331 if(!$httptlssrv) { 1332 return (0,0); 1333 } 1334 1335 $server = servername_id($proto, $ipvnum, $idnum); 1336 1337 $pidfile = $serverpidfile{$server}; 1338 1339 # don't retry if the server doesn't work 1340 if ($doesntrun{$pidfile}) { 1341 return (0,0); 1342 } 1343 1344 my $pid = processexists($pidfile); 1345 if($pid > 0) { 1346 stopserver($server, "$pid"); 1347 } 1348 unlink($pidfile) if(-f $pidfile); 1349 1350 $srvrname = servername_str($proto, $ipvnum, $idnum); 1351 1352 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1353 1354 $flags .= "--http "; 1355 $flags .= "--debug 1 " if($debugprotocol); 1356 $flags .= "--port $port "; 1357 $flags .= "--srppasswd certs/srp-verifier-db "; 1358 $flags .= "--srppasswdconf certs/srp-verifier-conf"; 1359 1360 my $cmd = "$httptlssrv $flags > $logfile 2>&1"; 1361 my ($httptlspid, $pid2) = startnew($cmd, $pidfile, 10, 1); # fake pidfile 1362 1363 if($httptlspid <= 0 || !kill(0, $httptlspid)) { 1364 # it is NOT alive 1365 logmsg "RUN: failed to start the $srvrname server\n"; 1366 stopserver($server, "$pid2"); 1367 displaylogs($testnumcheck); 1368 $doesntrun{$pidfile} = 1; 1369 return (0,0); 1370 } 1371 1372 # Server is up. Verify that we can speak to it. PID is from fake pidfile 1373 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1374 if(!$pid3) { 1375 logmsg "RUN: $srvrname server failed verification\n"; 1376 # failed to talk to it properly. Kill the server and return failure 1377 stopserver($server, "$httptlspid $pid2"); 1378 displaylogs($testnumcheck); 1379 $doesntrun{$pidfile} = 1; 1380 return (0,0); 1381 } 1382 $pid2 = $pid3; 1383 1384 if($verbose) { 1385 logmsg "RUN: $srvrname server is now running PID $httptlspid\n"; 1386 } 1387 1388 sleep(1); 1389 1390 return ($httptlspid, $pid2); 1391} 1392 1393####################################################################### 1394# start the pingpong server (FTP, POP3, IMAP, SMTP) 1395# 1396sub runpingpongserver { 1397 my ($proto, $id, $verbose, $ipv6) = @_; 1398 my $port; 1399 my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; 1400 my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 1401 my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; 1402 my $server; 1403 my $srvrname; 1404 my $pidfile; 1405 my $logfile; 1406 my $flags = ""; 1407 1408 if($proto eq "ftp") { 1409 $port = ($idnum>1)?$FTP2PORT:$FTPPORT; 1410 1411 if($ipvnum==6) { 1412 # if IPv6, use a different setup 1413 $port = $FTP6PORT; 1414 } 1415 } 1416 elsif($proto eq "pop3") { 1417 $port = ($ipvnum==6) ? $POP36PORT : $POP3PORT; 1418 } 1419 elsif($proto eq "imap") { 1420 $port = ($ipvnum==6) ? $IMAP6PORT : $IMAPPORT; 1421 } 1422 elsif($proto eq "smtp") { 1423 $port = ($ipvnum==6) ? $SMTP6PORT : $SMTPPORT; 1424 } 1425 else { 1426 print STDERR "Unsupported protocol $proto!!\n"; 1427 return 0; 1428 } 1429 1430 $server = servername_id($proto, $ipvnum, $idnum); 1431 1432 $pidfile = $serverpidfile{$server}; 1433 1434 # don't retry if the server doesn't work 1435 if ($doesntrun{$pidfile}) { 1436 return (0,0); 1437 } 1438 1439 my $pid = processexists($pidfile); 1440 if($pid > 0) { 1441 stopserver($server, "$pid"); 1442 } 1443 unlink($pidfile) if(-f $pidfile); 1444 1445 $srvrname = servername_str($proto, $ipvnum, $idnum); 1446 1447 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1448 1449 $flags .= "--verbose " if($debugprotocol); 1450 $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; 1451 $flags .= "--srcdir \"$srcdir\" --proto $proto "; 1452 $flags .= "--id $idnum " if($idnum > 1); 1453 $flags .= "--ipv$ipvnum --port $port --addr \"$ip\""; 1454 1455 my $cmd = "$perl $srcdir/ftpserver.pl $flags"; 1456 my ($ftppid, $pid2) = startnew($cmd, $pidfile, 15, 0); 1457 1458 if($ftppid <= 0 || !kill(0, $ftppid)) { 1459 # it is NOT alive 1460 logmsg "RUN: failed to start the $srvrname server\n"; 1461 stopserver($server, "$pid2"); 1462 displaylogs($testnumcheck); 1463 $doesntrun{$pidfile} = 1; 1464 return (0,0); 1465 } 1466 1467 # Server is up. Verify that we can speak to it. 1468 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1469 if(!$pid3) { 1470 logmsg "RUN: $srvrname server failed verification\n"; 1471 # failed to talk to it properly. Kill the server and return failure 1472 stopserver($server, "$ftppid $pid2"); 1473 displaylogs($testnumcheck); 1474 $doesntrun{$pidfile} = 1; 1475 return (0,0); 1476 } 1477 1478 $pid2 = $pid3; 1479 1480 if($verbose) { 1481 logmsg "RUN: $srvrname server is now running PID $ftppid\n"; 1482 } 1483 1484 sleep(1); 1485 1486 return ($pid2, $ftppid); 1487} 1488 1489####################################################################### 1490# start the ftps server (or rather, tunnel) 1491# 1492sub runftpsserver { 1493 my ($verbose, $ipv6, $certfile) = @_; 1494 my $proto = 'ftps'; 1495 my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; 1496 my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 1497 my $idnum = 1; 1498 my $server; 1499 my $srvrname; 1500 my $pidfile; 1501 my $logfile; 1502 my $flags = ""; 1503 1504 if(!$stunnel) { 1505 return (0,0); 1506 } 1507 1508 $server = servername_id($proto, $ipvnum, $idnum); 1509 1510 $pidfile = $serverpidfile{$server}; 1511 1512 # don't retry if the server doesn't work 1513 if ($doesntrun{$pidfile}) { 1514 return (0,0); 1515 } 1516 1517 my $pid = processexists($pidfile); 1518 if($pid > 0) { 1519 stopserver($server, "$pid"); 1520 } 1521 unlink($pidfile) if(-f $pidfile); 1522 1523 $srvrname = servername_str($proto, $ipvnum, $idnum); 1524 1525 $certfile = 'stunnel.pem' unless($certfile); 1526 1527 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1528 1529 $flags .= "--verbose " if($debugprotocol); 1530 $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; 1531 $flags .= "--id $idnum " if($idnum > 1); 1532 $flags .= "--ipv$ipvnum --proto $proto "; 1533 $flags .= "--certfile \"$certfile\" " if($certfile ne 'stunnel.pem'); 1534 $flags .= "--stunnel \"$stunnel\" --srcdir \"$srcdir\" "; 1535 $flags .= "--connect $FTPPORT --accept $FTPSPORT"; 1536 1537 my $cmd = "$perl $srcdir/secureserver.pl $flags"; 1538 my ($ftpspid, $pid2) = startnew($cmd, $pidfile, 15, 0); 1539 1540 if($ftpspid <= 0 || !kill(0, $ftpspid)) { 1541 # it is NOT alive 1542 logmsg "RUN: failed to start the $srvrname server\n"; 1543 stopserver($server, "$pid2"); 1544 displaylogs($testnumcheck); 1545 $doesntrun{$pidfile} = 1; 1546 return(0,0); 1547 } 1548 1549 # Server is up. Verify that we can speak to it. 1550 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $FTPSPORT); 1551 if(!$pid3) { 1552 logmsg "RUN: $srvrname server failed verification\n"; 1553 # failed to talk to it properly. Kill the server and return failure 1554 stopserver($server, "$ftpspid $pid2"); 1555 displaylogs($testnumcheck); 1556 $doesntrun{$pidfile} = 1; 1557 return (0,0); 1558 } 1559 # Here pid3 is actually the pid returned by the unsecure-ftp server. 1560 1561 $runcert{$server} = $certfile; 1562 1563 if($verbose) { 1564 logmsg "RUN: $srvrname server is now running PID $ftpspid\n"; 1565 } 1566 1567 sleep(1); 1568 1569 return ($ftpspid, $pid2); 1570} 1571 1572####################################################################### 1573# start the tftp server 1574# 1575sub runtftpserver { 1576 my ($id, $verbose, $ipv6) = @_; 1577 my $port = $TFTPPORT; 1578 my $ip = $HOSTIP; 1579 my $proto = 'tftp'; 1580 my $ipvnum = 4; 1581 my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; 1582 my $server; 1583 my $srvrname; 1584 my $pidfile; 1585 my $logfile; 1586 my $flags = ""; 1587 1588 if($ipv6) { 1589 # if IPv6, use a different setup 1590 $ipvnum = 6; 1591 $port = $TFTP6PORT; 1592 $ip = $HOST6IP; 1593 } 1594 1595 $server = servername_id($proto, $ipvnum, $idnum); 1596 1597 $pidfile = $serverpidfile{$server}; 1598 1599 # don't retry if the server doesn't work 1600 if ($doesntrun{$pidfile}) { 1601 return (0,0); 1602 } 1603 1604 my $pid = processexists($pidfile); 1605 if($pid > 0) { 1606 stopserver($server, "$pid"); 1607 } 1608 unlink($pidfile) if(-f $pidfile); 1609 1610 $srvrname = servername_str($proto, $ipvnum, $idnum); 1611 1612 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1613 1614 $flags .= "--verbose " if($debugprotocol); 1615 $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; 1616 $flags .= "--id $idnum " if($idnum > 1); 1617 $flags .= "--ipv$ipvnum --port $port --srcdir \"$srcdir\""; 1618 1619 my $cmd = "$perl $srcdir/tftpserver.pl $flags"; 1620 my ($tftppid, $pid2) = startnew($cmd, $pidfile, 15, 0); 1621 1622 if($tftppid <= 0 || !kill(0, $tftppid)) { 1623 # it is NOT alive 1624 logmsg "RUN: failed to start the $srvrname server\n"; 1625 stopserver($server, "$pid2"); 1626 displaylogs($testnumcheck); 1627 $doesntrun{$pidfile} = 1; 1628 return (0,0); 1629 } 1630 1631 # Server is up. Verify that we can speak to it. 1632 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1633 if(!$pid3) { 1634 logmsg "RUN: $srvrname server failed verification\n"; 1635 # failed to talk to it properly. Kill the server and return failure 1636 stopserver($server, "$tftppid $pid2"); 1637 displaylogs($testnumcheck); 1638 $doesntrun{$pidfile} = 1; 1639 return (0,0); 1640 } 1641 $pid2 = $pid3; 1642 1643 if($verbose) { 1644 logmsg "RUN: $srvrname server is now running PID $tftppid\n"; 1645 } 1646 1647 sleep(1); 1648 1649 return ($pid2, $tftppid); 1650} 1651 1652 1653####################################################################### 1654# start the rtsp server 1655# 1656sub runrtspserver { 1657 my ($verbose, $ipv6) = @_; 1658 my $port = $RTSPPORT; 1659 my $ip = $HOSTIP; 1660 my $proto = 'rtsp'; 1661 my $ipvnum = 4; 1662 my $idnum = 1; 1663 my $server; 1664 my $srvrname; 1665 my $pidfile; 1666 my $logfile; 1667 my $flags = ""; 1668 1669 if($ipv6) { 1670 # if IPv6, use a different setup 1671 $ipvnum = 6; 1672 $port = $RTSP6PORT; 1673 $ip = $HOST6IP; 1674 } 1675 1676 $server = servername_id($proto, $ipvnum, $idnum); 1677 1678 $pidfile = $serverpidfile{$server}; 1679 1680 # don't retry if the server doesn't work 1681 if ($doesntrun{$pidfile}) { 1682 return (0,0); 1683 } 1684 1685 my $pid = processexists($pidfile); 1686 if($pid > 0) { 1687 stopserver($server, "$pid"); 1688 } 1689 unlink($pidfile) if(-f $pidfile); 1690 1691 $srvrname = servername_str($proto, $ipvnum, $idnum); 1692 1693 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1694 1695 $flags .= "--verbose " if($debugprotocol); 1696 $flags .= "--pidfile \"$pidfile\" --logfile \"$logfile\" "; 1697 $flags .= "--id $idnum " if($idnum > 1); 1698 $flags .= "--ipv$ipvnum --port $port --srcdir \"$srcdir\""; 1699 1700 my $cmd = "$perl $srcdir/rtspserver.pl $flags"; 1701 my ($rtsppid, $pid2) = startnew($cmd, $pidfile, 15, 0); 1702 1703 if($rtsppid <= 0 || !kill(0, $rtsppid)) { 1704 # it is NOT alive 1705 logmsg "RUN: failed to start the $srvrname server\n"; 1706 stopserver($server, "$pid2"); 1707 displaylogs($testnumcheck); 1708 $doesntrun{$pidfile} = 1; 1709 return (0,0); 1710 } 1711 1712 # Server is up. Verify that we can speak to it. 1713 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1714 if(!$pid3) { 1715 logmsg "RUN: $srvrname server failed verification\n"; 1716 # failed to talk to it properly. Kill the server and return failure 1717 stopserver($server, "$rtsppid $pid2"); 1718 displaylogs($testnumcheck); 1719 $doesntrun{$pidfile} = 1; 1720 return (0,0); 1721 } 1722 $pid2 = $pid3; 1723 1724 if($verbose) { 1725 logmsg "RUN: $srvrname server is now running PID $rtsppid\n"; 1726 } 1727 1728 sleep(1); 1729 1730 return ($rtsppid, $pid2); 1731} 1732 1733 1734####################################################################### 1735# Start the ssh (scp/sftp) server 1736# 1737sub runsshserver { 1738 my ($id, $verbose, $ipv6) = @_; 1739 my $ip=$HOSTIP; 1740 my $port = $SSHPORT; 1741 my $socksport = $SOCKSPORT; 1742 my $proto = 'ssh'; 1743 my $ipvnum = 4; 1744 my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; 1745 my $server; 1746 my $srvrname; 1747 my $pidfile; 1748 my $logfile; 1749 my $flags = ""; 1750 1751 $server = servername_id($proto, $ipvnum, $idnum); 1752 1753 $pidfile = $serverpidfile{$server}; 1754 1755 # don't retry if the server doesn't work 1756 if ($doesntrun{$pidfile}) { 1757 return (0,0); 1758 } 1759 1760 my $pid = processexists($pidfile); 1761 if($pid > 0) { 1762 stopserver($server, "$pid"); 1763 } 1764 unlink($pidfile) if(-f $pidfile); 1765 1766 $srvrname = servername_str($proto, $ipvnum, $idnum); 1767 1768 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1769 1770 $flags .= "--verbose " if($verbose); 1771 $flags .= "--debugprotocol " if($debugprotocol); 1772 $flags .= "--pidfile \"$pidfile\" "; 1773 $flags .= "--id $idnum " if($idnum > 1); 1774 $flags .= "--ipv$ipvnum --addr \"$ip\" "; 1775 $flags .= "--sshport $port --socksport $socksport "; 1776 $flags .= "--user \"$USER\""; 1777 1778 my $cmd = "$perl $srcdir/sshserver.pl $flags"; 1779 my ($sshpid, $pid2) = startnew($cmd, $pidfile, 60, 0); 1780 1781 # on loaded systems sshserver start up can take longer than the timeout 1782 # passed to startnew, when this happens startnew completes without being 1783 # able to read the pidfile and consequently returns a zero pid2 above. 1784 1785 if($sshpid <= 0 || !kill(0, $sshpid)) { 1786 # it is NOT alive 1787 logmsg "RUN: failed to start the $srvrname server\n"; 1788 stopserver($server, "$pid2"); 1789 $doesntrun{$pidfile} = 1; 1790 return (0,0); 1791 } 1792 1793 # ssh server verification allows some extra time for the server to start up 1794 # and gives us the opportunity of recovering the pid from the pidfile, when 1795 # this verification succeeds the recovered pid is assigned to pid2. 1796 1797 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1798 if(!$pid3) { 1799 logmsg "RUN: $srvrname server failed verification\n"; 1800 # failed to fetch server pid. Kill the server and return failure 1801 stopserver($server, "$sshpid $pid2"); 1802 $doesntrun{$pidfile} = 1; 1803 return (0,0); 1804 } 1805 $pid2 = $pid3; 1806 1807 # once it is known that the ssh server is alive, sftp server verification 1808 # is performed actually connecting to it, authenticating and performing a 1809 # very simple remote command. This verification is tried only one time. 1810 1811 $sshdlog = server_logfilename($LOGDIR, 'ssh', $ipvnum, $idnum); 1812 $sftplog = server_logfilename($LOGDIR, 'sftp', $ipvnum, $idnum); 1813 1814 if(verifysftp('sftp', $ipvnum, $idnum, $ip, $port) < 1) { 1815 logmsg "RUN: SFTP server failed verification\n"; 1816 # failed to talk to it properly. Kill the server and return failure 1817 display_sftplog(); 1818 display_sftpconfig(); 1819 display_sshdlog(); 1820 display_sshdconfig(); 1821 stopserver($server, "$sshpid $pid2"); 1822 $doesntrun{$pidfile} = 1; 1823 return (0,0); 1824 } 1825 1826 if($verbose) { 1827 logmsg "RUN: $srvrname server is now running PID $pid2\n"; 1828 } 1829 1830 return ($pid2, $sshpid); 1831} 1832 1833####################################################################### 1834# Start the socks server 1835# 1836sub runsocksserver { 1837 my ($id, $verbose, $ipv6) = @_; 1838 my $ip=$HOSTIP; 1839 my $port = $SOCKSPORT; 1840 my $proto = 'socks'; 1841 my $ipvnum = 4; 1842 my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; 1843 my $server; 1844 my $srvrname; 1845 my $pidfile; 1846 my $logfile; 1847 my $flags = ""; 1848 1849 $server = servername_id($proto, $ipvnum, $idnum); 1850 1851 $pidfile = $serverpidfile{$server}; 1852 1853 # don't retry if the server doesn't work 1854 if ($doesntrun{$pidfile}) { 1855 return (0,0); 1856 } 1857 1858 my $pid = processexists($pidfile); 1859 if($pid > 0) { 1860 stopserver($server, "$pid"); 1861 } 1862 unlink($pidfile) if(-f $pidfile); 1863 1864 $srvrname = servername_str($proto, $ipvnum, $idnum); 1865 1866 $logfile = server_logfilename($LOGDIR, $proto, $ipvnum, $idnum); 1867 1868 # The ssh server must be already running 1869 if(!$run{'ssh'}) { 1870 logmsg "RUN: SOCKS server cannot find running SSH server\n"; 1871 $doesntrun{$pidfile} = 1; 1872 return (0,0); 1873 } 1874 1875 # Find out ssh daemon canonical file name 1876 my $sshd = find_sshd(); 1877 if(!$sshd) { 1878 logmsg "RUN: SOCKS server cannot find $sshdexe\n"; 1879 $doesntrun{$pidfile} = 1; 1880 return (0,0); 1881 } 1882 1883 # Find out ssh daemon version info 1884 ($sshdid, $sshdvernum, $sshdverstr, $sshderror) = sshversioninfo($sshd); 1885 if(!$sshdid) { 1886 # Not an OpenSSH or SunSSH ssh daemon 1887 logmsg "$sshderror\n" if($verbose); 1888 logmsg "SCP, SFTP and SOCKS tests require OpenSSH 2.9.9 or later\n"; 1889 $doesntrun{$pidfile} = 1; 1890 return (0,0); 1891 } 1892 logmsg "ssh server found $sshd is $sshdverstr\n" if($verbose); 1893 1894 # Find out ssh client canonical file name 1895 my $ssh = find_ssh(); 1896 if(!$ssh) { 1897 logmsg "RUN: SOCKS server cannot find $sshexe\n"; 1898 $doesntrun{$pidfile} = 1; 1899 return (0,0); 1900 } 1901 1902 # Find out ssh client version info 1903 my ($sshid, $sshvernum, $sshverstr, $ssherror) = sshversioninfo($ssh); 1904 if(!$sshid) { 1905 # Not an OpenSSH or SunSSH ssh client 1906 logmsg "$ssherror\n" if($verbose); 1907 logmsg "SCP, SFTP and SOCKS tests require OpenSSH 2.9.9 or later\n"; 1908 $doesntrun{$pidfile} = 1; 1909 return (0,0); 1910 } 1911 1912 # Verify minimum ssh client version 1913 if((($sshid =~ /OpenSSH/) && ($sshvernum < 299)) || 1914 (($sshid =~ /SunSSH/) && ($sshvernum < 100))) { 1915 logmsg "ssh client found $ssh is $sshverstr\n"; 1916 logmsg "SCP, SFTP and SOCKS tests require OpenSSH 2.9.9 or later\n"; 1917 $doesntrun{$pidfile} = 1; 1918 return (0,0); 1919 } 1920 logmsg "ssh client found $ssh is $sshverstr\n" if($verbose); 1921 1922 # Verify if ssh client and ssh daemon versions match 1923 if(($sshdid ne $sshid) || ($sshdvernum != $sshvernum)) { 1924 # Our test harness might work with slightly mismatched versions 1925 logmsg "Warning: version mismatch: sshd $sshdverstr - ssh $sshverstr\n" 1926 if($verbose); 1927 } 1928 1929 # Config file options for ssh client are previously set from sshserver.pl 1930 if(! -e $sshconfig) { 1931 logmsg "RUN: SOCKS server cannot find $sshconfig\n"; 1932 $doesntrun{$pidfile} = 1; 1933 return (0,0); 1934 } 1935 1936 $sshlog = server_logfilename($LOGDIR, 'socks', $ipvnum, $idnum); 1937 1938 # start our socks server 1939 my $cmd="$ssh -N -F $sshconfig $ip > $sshlog 2>&1"; 1940 my ($sshpid, $pid2) = startnew($cmd, $pidfile, 30, 1); # fake pidfile 1941 1942 if($sshpid <= 0 || !kill(0, $sshpid)) { 1943 # it is NOT alive 1944 logmsg "RUN: failed to start the $srvrname server\n"; 1945 display_sshlog(); 1946 display_sshconfig(); 1947 display_sshdlog(); 1948 display_sshdconfig(); 1949 stopserver($server, "$pid2"); 1950 $doesntrun{$pidfile} = 1; 1951 return (0,0); 1952 } 1953 1954 # Ugly hack but ssh doesn't support pid files. PID is from fake pidfile. 1955 my $pid3 = verifyserver($proto, $ipvnum, $idnum, $ip, $port); 1956 if(!$pid3) { 1957 logmsg "RUN: $srvrname server failed verification\n"; 1958 # failed to talk to it properly. Kill the server and return failure 1959 stopserver($server, "$sshpid $pid2"); 1960 $doesntrun{$pidfile} = 1; 1961 return (0,0); 1962 } 1963 $pid2 = $pid3; 1964 1965 if($verbose) { 1966 logmsg "RUN: $srvrname server is now running PID $pid2\n"; 1967 } 1968 1969 return ($pid2, $sshpid); 1970} 1971 1972####################################################################### 1973# Single shot http and gopher server responsiveness test. This should only 1974# be used to verify that a server present in %run hash is still functional 1975# 1976sub responsive_http_server { 1977 my ($proto, $verbose, $ipv6, $port) = @_; 1978 my $ip = $HOSTIP; 1979 my $ipvnum = 4; 1980 my $idnum = 1; 1981 1982 if($ipv6) { 1983 # if IPv6, use a different setup 1984 $ipvnum = 6; 1985 $ip = $HOST6IP; 1986 } 1987 1988 return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); 1989} 1990 1991####################################################################### 1992# Single shot pingpong server responsiveness test. This should only be 1993# used to verify that a server present in %run hash is still functional 1994# 1995sub responsive_pingpong_server { 1996 my ($proto, $id, $verbose, $ipv6) = @_; 1997 my $port; 1998 my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; 1999 my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 2000 my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; 2001 2002 if($proto eq "ftp") { 2003 $port = ($idnum>1)?$FTP2PORT:$FTPPORT; 2004 2005 if($ipvnum==6) { 2006 # if IPv6, use a different setup 2007 $port = $FTP6PORT; 2008 } 2009 } 2010 elsif($proto eq "pop3") { 2011 $port = ($ipvnum==6) ? $POP36PORT : $POP3PORT; 2012 } 2013 elsif($proto eq "imap") { 2014 $port = ($ipvnum==6) ? $IMAP6PORT : $IMAPPORT; 2015 } 2016 elsif($proto eq "smtp") { 2017 $port = ($ipvnum==6) ? $SMTP6PORT : $SMTPPORT; 2018 } 2019 else { 2020 print STDERR "Unsupported protocol $proto!!\n"; 2021 return 0; 2022 } 2023 2024 return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); 2025} 2026 2027####################################################################### 2028# Single shot rtsp server responsiveness test. This should only be 2029# used to verify that a server present in %run hash is still functional 2030# 2031sub responsive_rtsp_server { 2032 my ($verbose, $ipv6) = @_; 2033 my $port = $RTSPPORT; 2034 my $ip = $HOSTIP; 2035 my $proto = 'rtsp'; 2036 my $ipvnum = 4; 2037 my $idnum = 1; 2038 2039 if($ipv6) { 2040 # if IPv6, use a different setup 2041 $ipvnum = 6; 2042 $port = $RTSP6PORT; 2043 $ip = $HOST6IP; 2044 } 2045 2046 return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); 2047} 2048 2049####################################################################### 2050# Single shot tftp server responsiveness test. This should only be 2051# used to verify that a server present in %run hash is still functional 2052# 2053sub responsive_tftp_server { 2054 my ($id, $verbose, $ipv6) = @_; 2055 my $port = $TFTPPORT; 2056 my $ip = $HOSTIP; 2057 my $proto = 'tftp'; 2058 my $ipvnum = 4; 2059 my $idnum = ($id && ($id =~ /^(\d+)$/) && ($id > 1)) ? $id : 1; 2060 2061 if($ipv6) { 2062 # if IPv6, use a different setup 2063 $ipvnum = 6; 2064 $port = $TFTP6PORT; 2065 $ip = $HOST6IP; 2066 } 2067 2068 return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); 2069} 2070 2071####################################################################### 2072# Single shot non-stunnel HTTP TLS extensions capable server 2073# responsiveness test. This should only be used to verify that a 2074# server present in %run hash is still functional 2075# 2076sub responsive_httptls_server { 2077 my ($verbose, $ipv6) = @_; 2078 my $proto = "httptls"; 2079 my $port = ($ipv6 && ($ipv6 =~ /6$/)) ? $HTTPTLS6PORT : $HTTPTLSPORT; 2080 my $ip = ($ipv6 && ($ipv6 =~ /6$/)) ? "$HOST6IP" : "$HOSTIP"; 2081 my $ipvnum = ($ipv6 && ($ipv6 =~ /6$/)) ? 6 : 4; 2082 my $idnum = 1; 2083 2084 return &responsiveserver($proto, $ipvnum, $idnum, $ip, $port); 2085} 2086 2087####################################################################### 2088# Remove all files in the specified directory 2089# 2090sub cleardir { 2091 my $dir = $_[0]; 2092 my $count; 2093 my $file; 2094 2095 # Get all files 2096 opendir(DIR, $dir) || 2097 return 0; # can't open dir 2098 while($file = readdir(DIR)) { 2099 if($file !~ /^\./) { 2100 unlink("$dir/$file"); 2101 $count++; 2102 } 2103 } 2104 closedir DIR; 2105 return $count; 2106} 2107 2108####################################################################### 2109# filter out the specified pattern from the given input file and store the 2110# results in the given output file 2111# 2112sub filteroff { 2113 my $infile=$_[0]; 2114 my $filter=$_[1]; 2115 my $ofile=$_[2]; 2116 2117 open(IN, "<$infile") 2118 || return 1; 2119 2120 open(OUT, ">$ofile") 2121 || return 1; 2122 2123 # logmsg "FILTER: off $filter from $infile to $ofile\n"; 2124 2125 while(<IN>) { 2126 $_ =~ s/$filter//; 2127 print OUT $_; 2128 } 2129 close(IN); 2130 close(OUT); 2131 return 0; 2132} 2133 2134####################################################################### 2135# compare test results with the expected output, we might filter off 2136# some pattern that is allowed to differ, output test results 2137# 2138sub compare { 2139 # filter off patterns _before_ this comparison! 2140 my ($subject, $firstref, $secondref)=@_; 2141 2142 my $result = compareparts($firstref, $secondref); 2143 2144 if($result) { 2145 if(!$short) { 2146 logmsg "\n $subject FAILED:\n"; 2147 logmsg showdiff($LOGDIR, $firstref, $secondref); 2148 } 2149 else { 2150 logmsg "FAILED\n"; 2151 } 2152 } 2153 return $result; 2154} 2155 2156####################################################################### 2157# display information about curl and the host the test suite runs on 2158# 2159sub checksystem { 2160 2161 unlink($memdump); # remove this if there was one left 2162 2163 my $feat; 2164 my $curl; 2165 my $libcurl; 2166 my $versretval; 2167 my $versnoexec; 2168 my @version=(); 2169 2170 my $curlverout="$LOGDIR/curlverout.log"; 2171 my $curlvererr="$LOGDIR/curlvererr.log"; 2172 my $versioncmd="$CURL --version 1>$curlverout 2>$curlvererr"; 2173 2174 unlink($curlverout); 2175 unlink($curlvererr); 2176 2177 $versretval = runclient($versioncmd); 2178 $versnoexec = $!; 2179 2180 open(VERSOUT, "<$curlverout"); 2181 @version = <VERSOUT>; 2182 close(VERSOUT); 2183 2184 for(@version) { 2185 chomp; 2186 2187 if($_ =~ /^curl/) { 2188 $curl = $_; 2189 $curl =~ s/^(.*)(libcurl.*)/$1/g; 2190 2191 $libcurl = $2; 2192 if($curl =~ /mingw32/) { 2193 # This is a windows minw32 build, we need to translate the 2194 # given path to the "actual" windows path. 2195 2196 my @m = `mount`; 2197 my $matchlen; 2198 my $bestmatch; 2199 my $mount; 2200 2201# example mount output: 2202# C:\DOCUME~1\Temp on /tmp type user (binmode,noumount) 2203# c:\ActiveState\perl on /perl type user (binmode) 2204# C:\msys\1.0\bin on /usr/bin type user (binmode,cygexec,noumount) 2205# C:\msys\1.0\bin on /bin type user (binmode,cygexec,noumount) 2206 2207 foreach $mount (@m) { 2208 if( $mount =~ /(.*) on ([^ ]*) type /) { 2209 my ($mingw, $real)=($2, $1); 2210 if($pwd =~ /^$mingw/) { 2211 # the path we got from pwd starts with the path 2212 # we found on this line in the mount output 2213 2214 my $len = length($real); 2215 if($len > $matchlen) { 2216 # we remember the match that is the longest 2217 $matchlen = $len; 2218 $bestmatch = $real; 2219 } 2220 } 2221 } 2222 } 2223 if(!$matchlen) { 2224 logmsg "Serious error, can't find our \"real\" path\n"; 2225 } 2226 else { 2227 # now prepend the prefix from the mount command to build 2228 # our "actual path" 2229 $pwd = "$bestmatch$pwd"; 2230 } 2231 $pwd =~ s#\\#/#g; 2232 } 2233 elsif ($curl =~ /win32/) { 2234 # Native Windows builds don't understand the 2235 # output of cygwin's pwd. It will be 2236 # something like /cygdrive/c/<some path>. 2237 # 2238 # Use the cygpath utility to convert the 2239 # working directory to a Windows friendly 2240 # path. The -m option converts to use drive 2241 # letter:, but it uses / instead \. Forward 2242 # slashes (/) are easier for us. We don't 2243 # have to escape them to get them to curl 2244 # through a shell. 2245 chomp($pwd = `cygpath -m $pwd`); 2246 } 2247 elsif ($libcurl =~ /openssl/i) { 2248 $has_openssl=1; 2249 $ssllib="OpenSSL"; 2250 } 2251 elsif ($libcurl =~ /gnutls/i) { 2252 $has_gnutls=1; 2253 $ssllib="GnuTLS"; 2254 } 2255 elsif ($libcurl =~ /nss/i) { 2256 $has_nss=1; 2257 $ssllib="NSS"; 2258 } 2259 elsif ($libcurl =~ /yassl/i) { 2260 $has_yassl=1; 2261 $has_openssl=1; 2262 $ssllib="yassl"; 2263 } 2264 elsif ($libcurl =~ /polarssl/i) { 2265 $has_polarssl=1; 2266 $has_openssl=1; 2267 $ssllib="polarssl"; 2268 } 2269 elsif ($libcurl =~ /axtls/i) { 2270 $has_axtls=1; 2271 $ssllib="axTLS"; 2272 } 2273 } 2274 elsif($_ =~ /^Protocols: (.*)/i) { 2275 # these are the protocols compiled in to this libcurl 2276 @protocols = split(' ', lc($1)); 2277 2278 # Generate a "proto-ipv6" version of each protocol to match the 2279 # IPv6 <server> name. This works even if IPv6 support isn't 2280 # compiled in because the <features> test will fail. 2281 push @protocols, map($_ . '-ipv6', @protocols); 2282 2283 # 'none' is used in test cases to mean no server 2284 push @protocols, 'none'; 2285 } 2286 elsif($_ =~ /^Features: (.*)/i) { 2287 $feat = $1; 2288 if($feat =~ /TrackMemory/i) { 2289 # curl was built with --enable-curldebug (memory tracking) 2290 $curl_debug = 1; 2291 } 2292 if($feat =~ /debug/i) { 2293 # curl was built with --enable-debug 2294 $debug_build = 1; 2295 } 2296 if($feat =~ /SSL/i) { 2297 # ssl enabled 2298 $ssl_version=1; 2299 } 2300 if($feat =~ /Largefile/i) { 2301 # large file support 2302 $large_file=1; 2303 } 2304 if($feat =~ /IDN/i) { 2305 # IDN support 2306 $has_idn=1; 2307 } 2308 if($feat =~ /IPv6/i) { 2309 $has_ipv6 = 1; 2310 } 2311 if($feat =~ /libz/i) { 2312 $has_libz = 1; 2313 } 2314 if($feat =~ /NTLM/i) { 2315 # NTLM enabled 2316 $has_ntlm=1; 2317 } 2318 if($feat =~ /NTLM_WB/i) { 2319 # NTLM delegation to winbind daemon ntlm_auth helper enabled 2320 $has_ntlm_wb=1; 2321 } 2322 if($feat =~ /CharConv/i) { 2323 # CharConv enabled 2324 $has_charconv=1; 2325 } 2326 if($feat =~ /TLS-SRP/i) { 2327 # TLS-SRP enabled 2328 $has_tls_srp=1; 2329 } 2330 } 2331 # 2332 # Test harness currently uses a non-stunnel server in order to 2333 # run HTTP TLS-SRP tests required when curl is built with https 2334 # protocol support and TLS-SRP feature enabled. For convenience 2335 # 'httptls' may be included in the test harness protocols array 2336 # to differentiate this from classic stunnel based 'https' test 2337 # harness server. 2338 # 2339 if($has_tls_srp) { 2340 my $add_httptls; 2341 for(@protocols) { 2342 if($_ =~ /^https(-ipv6|)$/) { 2343 $add_httptls=1; 2344 last; 2345 } 2346 } 2347 if($add_httptls && (! grep /^httptls$/, @protocols)) { 2348 push @protocols, 'httptls'; 2349 push @protocols, 'httptls-ipv6'; 2350 } 2351 } 2352 } 2353 if(!$curl) { 2354 logmsg "unable to get curl's version, further details are:\n"; 2355 logmsg "issued command: \n"; 2356 logmsg "$versioncmd \n"; 2357 if ($versretval == -1) { 2358 logmsg "command failed with: \n"; 2359 logmsg "$versnoexec \n"; 2360 } 2361 elsif ($versretval & 127) { 2362 logmsg sprintf("command died with signal %d, and %s coredump.\n", 2363 ($versretval & 127), ($versretval & 128)?"a":"no"); 2364 } 2365 else { 2366 logmsg sprintf("command exited with value %d \n", $versretval >> 8); 2367 } 2368 logmsg "contents of $curlverout: \n"; 2369 displaylogcontent("$curlverout"); 2370 logmsg "contents of $curlvererr: \n"; 2371 displaylogcontent("$curlvererr"); 2372 die "couldn't get curl's version"; 2373 } 2374 2375 if(-r "../lib/curl_config.h") { 2376 open(CONF, "<../lib/curl_config.h"); 2377 while(<CONF>) { 2378 if($_ =~ /^\#define HAVE_GETRLIMIT/) { 2379 $has_getrlimit = 1; 2380 } 2381 } 2382 close(CONF); 2383 } 2384 2385 if($has_ipv6) { 2386 # client has ipv6 support 2387 2388 # check if the HTTP server has it! 2389 my @sws = `server/sws --version`; 2390 if($sws[0] =~ /IPv6/) { 2391 # HTTP server has ipv6 support! 2392 $http_ipv6 = 1; 2393 $gopher_ipv6 = 1; 2394 } 2395 2396 # check if the FTP server has it! 2397 @sws = `server/sockfilt --version`; 2398 if($sws[0] =~ /IPv6/) { 2399 # FTP server has ipv6 support! 2400 $ftp_ipv6 = 1; 2401 } 2402 } 2403 2404 if(!$curl_debug && $torture) { 2405 die "can't run torture tests since curl was not built with curldebug"; 2406 } 2407 2408 $has_shared = `sh $CURLCONFIG --built-shared`; 2409 chomp $has_shared; 2410 2411 # curl doesn't list cryptographic support separately, so assume it's 2412 # always available 2413 $has_crypto=1; 2414 2415 my $hostname=join(' ', runclientoutput("hostname")); 2416 my $hosttype=join(' ', runclientoutput("uname -a")); 2417 2418 logmsg ("********* System characteristics ******** \n", 2419 "* $curl\n", 2420 "* $libcurl\n", 2421 "* Features: $feat\n", 2422 "* Host: $hostname", 2423 "* System: $hosttype"); 2424 2425 logmsg sprintf("* Server SSL: %8s", $stunnel?"ON ":"OFF"); 2426 logmsg sprintf(" libcurl SSL: %s\n", $ssl_version?"ON ":"OFF"); 2427 logmsg sprintf("* debug build: %8s", $debug_build?"ON ":"OFF"); 2428 logmsg sprintf(" track memory: %s\n", $curl_debug?"ON ":"OFF"); 2429 logmsg sprintf("* valgrind: %8s", $valgrind?"ON ":"OFF"); 2430 logmsg sprintf(" HTTP IPv6 %s\n", $http_ipv6?"ON ":"OFF"); 2431 logmsg sprintf("* FTP IPv6 %8s", $ftp_ipv6?"ON ":"OFF"); 2432 logmsg sprintf(" Libtool lib: %s\n", $libtool?"ON ":"OFF"); 2433 logmsg sprintf("* Shared build: %s\n", $has_shared); 2434 if($ssl_version) { 2435 logmsg sprintf("* SSL library: %13s\n", $ssllib); 2436 } 2437 2438 logmsg "* Ports:\n"; 2439 2440 logmsg sprintf("* HTTP/%d ", $HTTPPORT); 2441 logmsg sprintf("FTP/%d ", $FTPPORT); 2442 logmsg sprintf("FTP2/%d ", $FTP2PORT); 2443 logmsg sprintf("RTSP/%d ", $RTSPPORT); 2444 if($stunnel) { 2445 logmsg sprintf("FTPS/%d ", $FTPSPORT); 2446 logmsg sprintf("HTTPS/%d ", $HTTPSPORT); 2447 } 2448 logmsg sprintf("\n* TFTP/%d ", $TFTPPORT); 2449 if($http_ipv6) { 2450 logmsg sprintf("HTTP-IPv6/%d ", $HTTP6PORT); 2451 logmsg sprintf("RTSP-IPv6/%d ", $RTSP6PORT); 2452 } 2453 if($ftp_ipv6) { 2454 logmsg sprintf("FTP-IPv6/%d ", $FTP6PORT); 2455 } 2456 if($tftp_ipv6) { 2457 logmsg sprintf("TFTP-IPv6/%d ", $TFTP6PORT); 2458 } 2459 logmsg sprintf("\n* GOPHER/%d ", $GOPHERPORT); 2460 if($gopher_ipv6) { 2461 logmsg sprintf("GOPHER-IPv6/%d", $GOPHERPORT); 2462 } 2463 logmsg sprintf("\n* SSH/%d ", $SSHPORT); 2464 logmsg sprintf("SOCKS/%d ", $SOCKSPORT); 2465 logmsg sprintf("POP3/%d ", $POP3PORT); 2466 logmsg sprintf("IMAP/%d ", $IMAPPORT); 2467 logmsg sprintf("SMTP/%d\n", $SMTPPORT); 2468 if($ftp_ipv6) { 2469 logmsg sprintf("* POP3-IPv6/%d ", $POP36PORT); 2470 logmsg sprintf("IMAP-IPv6/%d ", $IMAP6PORT); 2471 logmsg sprintf("SMTP-IPv6/%d\n", $SMTP6PORT); 2472 } 2473 if($httptlssrv) { 2474 logmsg sprintf("* HTTPTLS/%d ", $HTTPTLSPORT); 2475 if($has_ipv6) { 2476 logmsg sprintf("HTTPTLS-IPv6/%d ", $HTTPTLS6PORT); 2477 } 2478 logmsg "\n"; 2479 } 2480 2481 $has_textaware = ($^O eq 'MSWin32') || ($^O eq 'msys'); 2482 2483 logmsg "***************************************** \n"; 2484} 2485 2486####################################################################### 2487# substitute the variable stuff into either a joined up file or 2488# a command, in either case passed by reference 2489# 2490sub subVariables { 2491 my ($thing) = @_; 2492 2493 # ports 2494 2495 $$thing =~ s/%FTP6PORT/$FTP6PORT/g; 2496 $$thing =~ s/%FTP2PORT/$FTP2PORT/g; 2497 $$thing =~ s/%FTPSPORT/$FTPSPORT/g; 2498 $$thing =~ s/%FTPPORT/$FTPPORT/g; 2499 2500 $$thing =~ s/%GOPHER6PORT/$GOPHER6PORT/g; 2501 $$thing =~ s/%GOPHERPORT/$GOPHERPORT/g; 2502 2503 $$thing =~ s/%HTTPTLS6PORT/$HTTPTLS6PORT/g; 2504 $$thing =~ s/%HTTPTLSPORT/$HTTPTLSPORT/g; 2505 $$thing =~ s/%HTTP6PORT/$HTTP6PORT/g; 2506 $$thing =~ s/%HTTPSPORT/$HTTPSPORT/g; 2507 $$thing =~ s/%HTTPPORT/$HTTPPORT/g; 2508 2509 $$thing =~ s/%IMAP6PORT/$IMAP6PORT/g; 2510 $$thing =~ s/%IMAPPORT/$IMAPPORT/g; 2511 2512 $$thing =~ s/%POP36PORT/$POP36PORT/g; 2513 $$thing =~ s/%POP3PORT/$POP3PORT/g; 2514 2515 $$thing =~ s/%RTSP6PORT/$RTSP6PORT/g; 2516 $$thing =~ s/%RTSPPORT/$RTSPPORT/g; 2517 2518 $$thing =~ s/%SMTP6PORT/$SMTP6PORT/g; 2519 $$thing =~ s/%SMTPPORT/$SMTPPORT/g; 2520 2521 $$thing =~ s/%SOCKSPORT/$SOCKSPORT/g; 2522 $$thing =~ s/%SSHPORT/$SSHPORT/g; 2523 2524 $$thing =~ s/%TFTP6PORT/$TFTP6PORT/g; 2525 $$thing =~ s/%TFTPPORT/$TFTPPORT/g; 2526 2527 # client IP addresses 2528 2529 $$thing =~ s/%CLIENT6IP/$CLIENT6IP/g; 2530 $$thing =~ s/%CLIENTIP/$CLIENTIP/g; 2531 2532 # server IP addresses 2533 2534 $$thing =~ s/%HOST6IP/$HOST6IP/g; 2535 $$thing =~ s/%HOSTIP/$HOSTIP/g; 2536 2537 # misc 2538 2539 $$thing =~ s/%CURL/$CURL/g; 2540 $$thing =~ s/%PWD/$pwd/g; 2541 $$thing =~ s/%SRCDIR/$srcdir/g; 2542 $$thing =~ s/%USER/$USER/g; 2543 2544 # The purpose of FTPTIME2 and FTPTIME3 is to provide times that can be 2545 # used for time-out tests and that whould work on most hosts as these 2546 # adjust for the startup/check time for this particular host. We needed 2547 # to do this to make the test suite run better on very slow hosts. 2548 2549 my $ftp2 = $ftpchecktime * 2; 2550 my $ftp3 = $ftpchecktime * 3; 2551 2552 $$thing =~ s/%FTPTIME2/$ftp2/g; 2553 $$thing =~ s/%FTPTIME3/$ftp3/g; 2554} 2555 2556sub fixarray { 2557 my @in = @_; 2558 2559 for(@in) { 2560 subVariables \$_; 2561 } 2562 return @in; 2563} 2564 2565####################################################################### 2566# Provide time stamps for single test skipped events 2567# 2568sub timestampskippedevents { 2569 my $testnum = $_[0]; 2570 2571 return if((not defined($testnum)) || ($testnum < 1)); 2572 2573 if($timestats) { 2574 2575 if($timevrfyend{$testnum}) { 2576 return; 2577 } 2578 elsif($timesrvrlog{$testnum}) { 2579 $timevrfyend{$testnum} = $timesrvrlog{$testnum}; 2580 return; 2581 } 2582 elsif($timetoolend{$testnum}) { 2583 $timevrfyend{$testnum} = $timetoolend{$testnum}; 2584 $timesrvrlog{$testnum} = $timetoolend{$testnum}; 2585 } 2586 elsif($timetoolini{$testnum}) { 2587 $timevrfyend{$testnum} = $timetoolini{$testnum}; 2588 $timesrvrlog{$testnum} = $timetoolini{$testnum}; 2589 $timetoolend{$testnum} = $timetoolini{$testnum}; 2590 } 2591 elsif($timesrvrend{$testnum}) { 2592 $timevrfyend{$testnum} = $timesrvrend{$testnum}; 2593 $timesrvrlog{$testnum} = $timesrvrend{$testnum}; 2594 $timetoolend{$testnum} = $timesrvrend{$testnum}; 2595 $timetoolini{$testnum} = $timesrvrend{$testnum}; 2596 } 2597 elsif($timesrvrini{$testnum}) { 2598 $timevrfyend{$testnum} = $timesrvrini{$testnum}; 2599 $timesrvrlog{$testnum} = $timesrvrini{$testnum}; 2600 $timetoolend{$testnum} = $timesrvrini{$testnum}; 2601 $timetoolini{$testnum} = $timesrvrini{$testnum}; 2602 $timesrvrend{$testnum} = $timesrvrini{$testnum}; 2603 } 2604 elsif($timeprepini{$testnum}) { 2605 $timevrfyend{$testnum} = $timeprepini{$testnum}; 2606 $timesrvrlog{$testnum} = $timeprepini{$testnum}; 2607 $timetoolend{$testnum} = $timeprepini{$testnum}; 2608 $timetoolini{$testnum} = $timeprepini{$testnum}; 2609 $timesrvrend{$testnum} = $timeprepini{$testnum}; 2610 $timesrvrini{$testnum} = $timeprepini{$testnum}; 2611 } 2612 } 2613} 2614 2615####################################################################### 2616# Run a single specified test case 2617# 2618sub singletest { 2619 my ($testnum, $count, $total)=@_; 2620 2621 my @what; 2622 my $why; 2623 my %feature; 2624 my $cmd; 2625 my $disablevalgrind; 2626 2627 # copy test number to a global scope var, this allows 2628 # testnum checking when starting test harness servers. 2629 $testnumcheck = $testnum; 2630 2631 # timestamp test preparation start 2632 $timeprepini{$testnum} = Time::HiRes::time() if($timestats); 2633 2634 if($disttests !~ /test$testnum\W/ ) { 2635 logmsg "Warning: test$testnum not present in tests/data/Makefile.am\n"; 2636 } 2637 if($disabled{$testnum}) { 2638 logmsg "Warning: test$testnum is explicitly disabled\n"; 2639 } 2640 2641 # load the test case file definition 2642 if(loadtest("${TESTDIR}/test${testnum}")) { 2643 if($verbose) { 2644 # this is not a test 2645 logmsg "RUN: $testnum doesn't look like a test case\n"; 2646 } 2647 $why = "no test"; 2648 } 2649 else { 2650 @what = getpart("client", "features"); 2651 } 2652 2653 for(@what) { 2654 my $f = $_; 2655 $f =~ s/\s//g; 2656 2657 $feature{$f}=$f; # we require this feature 2658 2659 if($f eq "SSL") { 2660 if($ssl_version) { 2661 next; 2662 } 2663 } 2664 elsif($f eq "OpenSSL") { 2665 if($has_openssl) { 2666 next; 2667 } 2668 } 2669 elsif($f eq "GnuTLS") { 2670 if($has_gnutls) { 2671 next; 2672 } 2673 } 2674 elsif($f eq "NSS") { 2675 if($has_nss) { 2676 next; 2677 } 2678 } 2679 elsif($f eq "axTLS") { 2680 if($has_axtls) { 2681 next; 2682 } 2683 } 2684 elsif($f eq "unittest") { 2685 if($debug_build) { 2686 next; 2687 } 2688 } 2689 elsif($f eq "debug") { 2690 if($debug_build) { 2691 next; 2692 } 2693 } 2694 elsif($f eq "large_file") { 2695 if($large_file) { 2696 next; 2697 } 2698 } 2699 elsif($f eq "idn") { 2700 if($has_idn) { 2701 next; 2702 } 2703 } 2704 elsif($f eq "ipv6") { 2705 if($has_ipv6) { 2706 next; 2707 } 2708 } 2709 elsif($f eq "libz") { 2710 if($has_libz) { 2711 next; 2712 } 2713 } 2714 elsif($f eq "NTLM") { 2715 if($has_ntlm) { 2716 next; 2717 } 2718 } 2719 elsif($f eq "NTLM_WB") { 2720 if($has_ntlm_wb) { 2721 next; 2722 } 2723 } 2724 elsif($f eq "getrlimit") { 2725 if($has_getrlimit) { 2726 next; 2727 } 2728 } 2729 elsif($f eq "crypto") { 2730 if($has_crypto) { 2731 next; 2732 } 2733 } 2734 elsif($f eq "TLS-SRP") { 2735 if($has_tls_srp) { 2736 next; 2737 } 2738 } 2739 elsif($f eq "socks") { 2740 next; 2741 } 2742 # See if this "feature" is in the list of supported protocols 2743 elsif (grep /^\Q$f\E$/i, @protocols) { 2744 next; 2745 } 2746 2747 $why = "curl lacks $f support"; 2748 last; 2749 } 2750 2751 if(!$why) { 2752 my @keywords = getpart("info", "keywords"); 2753 my $match; 2754 my $k; 2755 for $k (@keywords) { 2756 chomp $k; 2757 if ($disabled_keywords{$k}) { 2758 $why = "disabled by keyword"; 2759 } elsif ($enabled_keywords{$k}) { 2760 $match = 1; 2761 } 2762 } 2763 2764 if(!$why && !$match && %enabled_keywords) { 2765 $why = "disabled by missing keyword"; 2766 } 2767 } 2768 2769 # test definition may instruct to (un)set environment vars 2770 # this is done this early, so that the precheck can use environment 2771 # variables and still bail out fine on errors 2772 2773 # restore environment variables that were modified in a previous run 2774 foreach my $var (keys %oldenv) { 2775 if($oldenv{$var} eq 'notset') { 2776 delete $ENV{$var} if($ENV{$var}); 2777 } 2778 else { 2779 $ENV{$var} = $oldenv{$var}; 2780 } 2781 delete $oldenv{$var}; 2782 } 2783 2784 # remove test server commands file before servers are started/verified 2785 unlink($FTPDCMD) if(-f $FTPDCMD); 2786 2787 # timestamp required servers verification start 2788 $timesrvrini{$testnum} = Time::HiRes::time() if($timestats); 2789 2790 if(!$why) { 2791 $why = serverfortest($testnum); 2792 } 2793 2794 # timestamp required servers verification end 2795 $timesrvrend{$testnum} = Time::HiRes::time() if($timestats); 2796 2797 my @setenv = getpart("client", "setenv"); 2798 if(@setenv) { 2799 foreach my $s (@setenv) { 2800 chomp $s; 2801 subVariables \$s; 2802 if($s =~ /([^=]*)=(.*)/) { 2803 my ($var, $content) = ($1, $2); 2804 # remember current setting, to restore it once test runs 2805 $oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset'; 2806 # set new value 2807 if(!$content) { 2808 delete $ENV{$var} if($ENV{$var}); 2809 } 2810 else { 2811 if($var =~ /^LD_PRELOAD/) { 2812 if(exe_ext() && (exe_ext() eq '.exe')) { 2813 # print "Skipping LD_PRELOAD due to lack of OS support\n"; 2814 next; 2815 } 2816 if($debug_build || ($has_shared ne "yes")) { 2817 # print "Skipping LD_PRELOAD due to no release shared build\n"; 2818 next; 2819 } 2820 } 2821 $ENV{$var} = "$content"; 2822 } 2823 } 2824 } 2825 } 2826 2827 if(!$why) { 2828 # TODO: 2829 # Add a precheck cache. If a precheck command was already invoked 2830 # exactly like this, then use the previous result to speed up 2831 # successive test invokes! 2832 2833 my @precheck = getpart("client", "precheck"); 2834 if(@precheck) { 2835 $cmd = $precheck[0]; 2836 chomp $cmd; 2837 subVariables \$cmd; 2838 if($cmd) { 2839 my @p = split(/ /, $cmd); 2840 if($p[0] !~ /\//) { 2841 # the first word, the command, does not contain a slash so 2842 # we will scan the "improved" PATH to find the command to 2843 # be able to run it 2844 my $fullp = checktestcmd($p[0]); 2845 2846 if($fullp) { 2847 $p[0] = $fullp; 2848 } 2849 $cmd = join(" ", @p); 2850 } 2851 2852 my @o = `$cmd 2>/dev/null`; 2853 if($o[0]) { 2854 $why = $o[0]; 2855 chomp $why; 2856 } elsif($?) { 2857 $why = "precheck command error"; 2858 } 2859 logmsg "prechecked $cmd\n" if($verbose); 2860 } 2861 } 2862 } 2863 2864 if($why && !$listonly) { 2865 # there's a problem, count it as "skipped" 2866 $skipped++; 2867 $skipped{$why}++; 2868 $teststat[$testnum]=$why; # store reason for this test case 2869 2870 if(!$short) { 2871 printf "test %03d SKIPPED: $why\n", $testnum; 2872 } 2873 2874 timestampskippedevents($testnum); 2875 return -1; 2876 } 2877 logmsg sprintf("test %03d...", $testnum); 2878 2879 # extract the reply data 2880 my @reply = getpart("reply", "data"); 2881 my @replycheck = getpart("reply", "datacheck"); 2882 2883 if (@replycheck) { 2884 # we use this file instead to check the final output against 2885 2886 my %hash = getpartattr("reply", "datacheck"); 2887 if($hash{'nonewline'}) { 2888 # Yes, we must cut off the final newline from the final line 2889 # of the datacheck 2890 chomp($replycheck[$#replycheck]); 2891 } 2892 2893 @reply=@replycheck; 2894 } 2895 2896 # this is the valid protocol blurb curl should generate 2897 my @protocol= fixarray ( getpart("verify", "protocol") ); 2898 2899 # redirected stdout/stderr to these files 2900 $STDOUT="$LOGDIR/stdout$testnum"; 2901 $STDERR="$LOGDIR/stderr$testnum"; 2902 2903 # if this section exists, we verify that the stdout contained this: 2904 my @validstdout = fixarray ( getpart("verify", "stdout") ); 2905 2906 # if this section exists, we verify upload 2907 my @upload = getpart("verify", "upload"); 2908 2909 # if this section exists, it might be FTP server instructions: 2910 my @ftpservercmd = getpart("reply", "servercmd"); 2911 2912 my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout 2913 2914 # name of the test 2915 my @testname= getpart("client", "name"); 2916 2917 if(!$short) { 2918 my $name = $testname[0]; 2919 $name =~ s/\n//g; 2920 logmsg "[$name]\n"; 2921 } 2922 2923 if($listonly) { 2924 timestampskippedevents($testnum); 2925 return 0; # look successful 2926 } 2927 2928 my @codepieces = getpart("client", "tool"); 2929 2930 my $tool=""; 2931 if(@codepieces) { 2932 $tool = $codepieces[0]; 2933 chomp $tool; 2934 } 2935 2936 # remove server output logfiles 2937 unlink($SERVERIN); 2938 unlink($SERVER2IN); 2939 2940 if(@ftpservercmd) { 2941 # write the instructions to file 2942 writearray($FTPDCMD, \@ftpservercmd); 2943 } 2944 2945 # get the command line options to use 2946 my @blaha; 2947 ($cmd, @blaha)= getpart("client", "command"); 2948 2949 if($cmd) { 2950 # make some nice replace operations 2951 $cmd =~ s/\n//g; # no newlines please 2952 # substitute variables in the command line 2953 subVariables \$cmd; 2954 } 2955 else { 2956 # there was no command given, use something silly 2957 $cmd="-"; 2958 } 2959 if($curl_debug) { 2960 unlink($memdump); 2961 } 2962 2963 # create a (possibly-empty) file before starting the test 2964 my @inputfile=getpart("client", "file"); 2965 my %fileattr = getpartattr("client", "file"); 2966 my $filename=$fileattr{'name'}; 2967 if(@inputfile || $filename) { 2968 if(!$filename) { 2969 logmsg "ERROR: section client=>file has no name attribute\n"; 2970 timestampskippedevents($testnum); 2971 return -1; 2972 } 2973 my $fileContent = join('', @inputfile); 2974 subVariables \$fileContent; 2975# logmsg "DEBUG: writing file " . $filename . "\n"; 2976 open(OUTFILE, ">$filename"); 2977 binmode OUTFILE; # for crapage systems, use binary 2978 print OUTFILE $fileContent; 2979 close(OUTFILE); 2980 } 2981 2982 my %cmdhash = getpartattr("client", "command"); 2983 2984 my $out=""; 2985 2986 if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-output/)) { 2987 #We may slap on --output! 2988 if (!@validstdout) { 2989 $out=" --output $CURLOUT "; 2990 } 2991 } 2992 2993 my $serverlogslocktimeout = $defserverlogslocktimeout; 2994 if($cmdhash{'timeout'}) { 2995 # test is allowed to override default server logs lock timeout 2996 if($cmdhash{'timeout'} =~ /(\d+)/) { 2997 $serverlogslocktimeout = $1 if($1 >= 0); 2998 } 2999 } 3000 3001 my $postcommanddelay = $defpostcommanddelay; 3002 if($cmdhash{'delay'}) { 3003 # test is allowed to specify a delay after command is executed 3004 if($cmdhash{'delay'} =~ /(\d+)/) { 3005 $postcommanddelay = $1 if($1 > 0); 3006 } 3007 } 3008 3009 my $CMDLINE; 3010 my $cmdargs; 3011 my $cmdtype = $cmdhash{'type'} || "default"; 3012 if($cmdtype eq "perl") { 3013 # run the command line prepended with "perl" 3014 $cmdargs ="$cmd"; 3015 $CMDLINE = "perl "; 3016 $tool=$CMDLINE; 3017 $disablevalgrind=1; 3018 } 3019 elsif(!$tool) { 3020 # run curl, add --verbose for debug information output 3021 $cmd = "-1 ".$cmd if(exists $feature{"SSL"} && ($has_axtls)); 3022 3023 my $inc=""; 3024 if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-include/)) { 3025 $inc = "--include "; 3026 } 3027 3028 $cmdargs ="$out $inc--verbose --trace-time $cmd"; 3029 } 3030 else { 3031 $cmdargs = " $cmd"; # $cmd is the command line for the test file 3032 $CURLOUT = $STDOUT; # sends received data to stdout 3033 3034 if($tool =~ /^lib/) { 3035 $CMDLINE="$LIBDIR/$tool"; 3036 } 3037 elsif($tool =~ /^unit/) { 3038 $CMDLINE="$UNITDIR/$tool"; 3039 } 3040 3041 if(! -f $CMDLINE) { 3042 print "The tool set in the test case for this: '$tool' does not exist\n"; 3043 timestampskippedevents($testnum); 3044 return -1; 3045 } 3046 $DBGCURL=$CMDLINE; 3047 } 3048 3049 my @stdintest = getpart("client", "stdin"); 3050 3051 if(@stdintest) { 3052 my $stdinfile="$LOGDIR/stdin-for-$testnum"; 3053 writearray($stdinfile, \@stdintest); 3054 3055 $cmdargs .= " <$stdinfile"; 3056 } 3057 3058 if(!$tool) { 3059 $CMDLINE="$CURL"; 3060 } 3061 3062 my $usevalgrind; 3063 if($valgrind && !$disablevalgrind) { 3064 my @valgrindoption = getpart("verify", "valgrind"); 3065 if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) { 3066 $usevalgrind = 1; 3067 my $valgrindcmd = "$valgrind "; 3068 $valgrindcmd .= "$valgrind_tool " if($valgrind_tool); 3069 $valgrindcmd .= "--leak-check=yes "; 3070 $valgrindcmd .= "--num-callers=16 "; 3071 $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; 3072 $CMDLINE = "$valgrindcmd $CMDLINE"; 3073 } 3074 } 3075 3076 $CMDLINE .= "$cmdargs >$STDOUT 2>$STDERR"; 3077 3078 if($verbose) { 3079 logmsg "$CMDLINE\n"; 3080 } 3081 3082 print CMDLOG "$CMDLINE\n"; 3083 3084 unlink("core"); 3085 3086 my $dumped_core; 3087 my $cmdres; 3088 3089 # Apr 2007: precommand isn't being used and could be removed 3090 my @precommand= getpart("client", "precommand"); 3091 if($precommand[0]) { 3092 # this is pure perl to eval! 3093 my $code = join("", @precommand); 3094 eval $code; 3095 if($@) { 3096 logmsg "perl: $code\n"; 3097 logmsg "precommand: $@"; 3098 stopservers($verbose); 3099 timestampskippedevents($testnum); 3100 return -1; 3101 } 3102 } 3103 3104 if($gdbthis) { 3105 my $gdbinit = "$TESTDIR/gdbinit$testnum"; 3106 open(GDBCMD, ">$LOGDIR/gdbcmd"); 3107 print GDBCMD "set args $cmdargs\n"; 3108 print GDBCMD "show args\n"; 3109 print GDBCMD "source $gdbinit\n" if -e $gdbinit; 3110 close(GDBCMD); 3111 } 3112 3113 # timestamp starting of test command 3114 $timetoolini{$testnum} = Time::HiRes::time() if($timestats); 3115 3116 # run the command line we built 3117 if ($torture) { 3118 $cmdres = torture($CMDLINE, 3119 "$gdb --directory libtest $DBGCURL -x $LOGDIR/gdbcmd"); 3120 } 3121 elsif($gdbthis) { 3122 my $GDBW = ($gdbxwin) ? "-w" : ""; 3123 runclient("$gdb --directory libtest $DBGCURL $GDBW -x $LOGDIR/gdbcmd"); 3124 $cmdres=0; # makes it always continue after a debugged run 3125 } 3126 else { 3127 $cmdres = runclient("$CMDLINE"); 3128 my $signal_num = $cmdres & 127; 3129 $dumped_core = $cmdres & 128; 3130 3131 if(!$anyway && ($signal_num || $dumped_core)) { 3132 $cmdres = 1000; 3133 } 3134 else { 3135 $cmdres >>= 8; 3136 $cmdres = (2000 + $signal_num) if($signal_num && !$cmdres); 3137 } 3138 } 3139 3140 # timestamp finishing of test command 3141 $timetoolend{$testnum} = Time::HiRes::time() if($timestats); 3142 3143 if(!$dumped_core) { 3144 if(-r "core") { 3145 # there's core file present now! 3146 $dumped_core = 1; 3147 } 3148 } 3149 3150 if($dumped_core) { 3151 logmsg "core dumped\n"; 3152 if(0 && $gdb) { 3153 logmsg "running gdb for post-mortem analysis:\n"; 3154 open(GDBCMD, ">$LOGDIR/gdbcmd2"); 3155 print GDBCMD "bt\n"; 3156 close(GDBCMD); 3157 runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch $DBGCURL core "); 3158 # unlink("$LOGDIR/gdbcmd2"); 3159 } 3160 } 3161 3162 # If a server logs advisor read lock file exists, it is an indication 3163 # that the server has not yet finished writing out all its log files, 3164 # including server request log files used for protocol verification. 3165 # So, if the lock file exists the script waits here a certain amount 3166 # of time until the server removes it, or the given time expires. 3167 3168 if($serverlogslocktimeout) { 3169 my $lockretry = $serverlogslocktimeout * 20; 3170 while((-f $SERVERLOGS_LOCK) && $lockretry--) { 3171 select(undef, undef, undef, 0.05); 3172 } 3173 if(($lockretry < 0) && 3174 ($serverlogslocktimeout >= $defserverlogslocktimeout)) { 3175 logmsg "Warning: server logs lock timeout ", 3176 "($serverlogslocktimeout seconds) expired\n"; 3177 } 3178 } 3179 3180 # Test harness ssh server does not have this synchronization mechanism, 3181 # this implies that some ssh server based tests might need a small delay 3182 # once that the client command has run to avoid false test failures. 3183 # 3184 # gnutls-serv also lacks this synchronization mechanism, so gnutls-serv 3185 # based tests might need a small delay once that the client command has 3186 # run to avoid false test failures. 3187 3188 sleep($postcommanddelay) if($postcommanddelay); 3189 3190 # timestamp removal of server logs advisor read lock 3191 $timesrvrlog{$testnum} = Time::HiRes::time() if($timestats); 3192 3193 # test definition might instruct to stop some servers 3194 # stop also all servers relative to the given one 3195 3196 my @killtestservers = getpart("client", "killserver"); 3197 if(@killtestservers) { 3198 # 3199 # All servers relative to the given one must be stopped also 3200 # 3201 my @killservers; 3202 foreach my $server (@killtestservers) { 3203 chomp $server; 3204 if($server =~ /^(ftp|http|imap|pop3|smtp)s((\d*)(-ipv6|))$/) { 3205 # given a stunnel ssl server, also kill non-ssl underlying one 3206 push @killservers, "${1}${2}"; 3207 } 3208 elsif($server =~ /^(ftp|http|imap|pop3|smtp)((\d*)(-ipv6|))$/) { 3209 # given a non-ssl server, also kill stunnel piggybacking one 3210 push @killservers, "${1}s${2}"; 3211 } 3212 elsif($server =~ /^(socks)((\d*)(-ipv6|))$/) { 3213 # given a socks server, also kill ssh underlying one 3214 push @killservers, "ssh${2}"; 3215 } 3216 elsif($server =~ /^(ssh)((\d*)(-ipv6|))$/) { 3217 # given a ssh server, also kill socks piggybacking one 3218 push @killservers, "socks${2}"; 3219 } 3220 push @killservers, $server; 3221 } 3222 # 3223 # kill sockfilter processes for pingpong relative servers 3224 # 3225 foreach my $server (@killservers) { 3226 if($server =~ /^(ftp|imap|pop3|smtp)s?(\d*)(-ipv6|)$/) { 3227 my $proto = $1; 3228 my $idnum = ($2 && ($2 > 1)) ? $2 : 1; 3229 my $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4; 3230 killsockfilters($proto, $ipvnum, $idnum, $verbose); 3231 } 3232 } 3233 # 3234 # kill server relative pids clearing them in %run hash 3235 # 3236 my $pidlist; 3237 foreach my $server (@killservers) { 3238 if($run{$server}) { 3239 $pidlist .= "$run{$server} "; 3240 $run{$server} = 0; 3241 } 3242 $runcert{$server} = 0 if($runcert{$server}); 3243 } 3244 killpid($verbose, $pidlist); 3245 # 3246 # cleanup server pid files 3247 # 3248 foreach my $server (@killservers) { 3249 my $pidfile = $serverpidfile{$server}; 3250 my $pid = processexists($pidfile); 3251 if($pid > 0) { 3252 logmsg "Warning: $server server unexpectedly alive\n"; 3253 killpid($verbose, $pid); 3254 } 3255 unlink($pidfile) if(-f $pidfile); 3256 } 3257 } 3258 3259 # remove the test server commands file after each test 3260 unlink($FTPDCMD) if(-f $FTPDCMD); 3261 3262 # run the postcheck command 3263 my @postcheck= getpart("client", "postcheck"); 3264 if(@postcheck) { 3265 $cmd = $postcheck[0]; 3266 chomp $cmd; 3267 subVariables \$cmd; 3268 if($cmd) { 3269 logmsg "postcheck $cmd\n" if($verbose); 3270 my $rc = runclient("$cmd"); 3271 # Must run the postcheck command in torture mode in order 3272 # to clean up, but the result can't be relied upon. 3273 if($rc != 0 && !$torture) { 3274 logmsg " postcheck FAILED\n"; 3275 # timestamp test result verification end 3276 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3277 return 1; 3278 } 3279 } 3280 } 3281 3282 # restore environment variables that were modified 3283 if(%oldenv) { 3284 foreach my $var (keys %oldenv) { 3285 if($oldenv{$var} eq 'notset') { 3286 delete $ENV{$var} if($ENV{$var}); 3287 } 3288 else { 3289 $ENV{$var} = "$oldenv{$var}"; 3290 } 3291 } 3292 } 3293 3294 # Skip all the verification on torture tests 3295 if ($torture) { 3296 if(!$cmdres && !$keepoutfiles) { 3297 cleardir($LOGDIR); 3298 } 3299 # timestamp test result verification end 3300 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3301 return $cmdres; 3302 } 3303 3304 my @err = getpart("verify", "errorcode"); 3305 my $errorcode = $err[0] || "0"; 3306 my $ok=""; 3307 my $res; 3308 chomp $errorcode; 3309 if (@validstdout) { 3310 # verify redirected stdout 3311 my @actual = loadarray($STDOUT); 3312 3313 # variable-replace in the stdout we have from the test case file 3314 @validstdout = fixarray(@validstdout); 3315 3316 # get all attributes 3317 my %hash = getpartattr("verify", "stdout"); 3318 3319 # get the mode attribute 3320 my $filemode=$hash{'mode'}; 3321 if($filemode && ($filemode eq "text") && $has_textaware) { 3322 # text mode when running on windows: fix line endings 3323 map s/\r\n/\n/g, @actual; 3324 } 3325 3326 if($hash{'nonewline'}) { 3327 # Yes, we must cut off the final newline from the final line 3328 # of the protocol data 3329 chomp($validstdout[$#validstdout]); 3330 } 3331 3332 $res = compare("stdout", \@actual, \@validstdout); 3333 if($res) { 3334 # timestamp test result verification end 3335 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3336 return 1; 3337 } 3338 $ok .= "s"; 3339 } 3340 else { 3341 $ok .= "-"; # stdout not checked 3342 } 3343 3344 my %replyattr = getpartattr("reply", "data"); 3345 if(!$replyattr{'nocheck'} && (@reply || $replyattr{'sendzero'})) { 3346 # verify the received data 3347 my @out = loadarray($CURLOUT); 3348 my %hash = getpartattr("reply", "data"); 3349 # get the mode attribute 3350 my $filemode=$hash{'mode'}; 3351 if($filemode && ($filemode eq "text") && $has_textaware) { 3352 # text mode when running on windows: fix line endings 3353 map s/\r\n/\n/g, @out; 3354 } 3355 3356 $res = compare("data", \@out, \@reply); 3357 if ($res) { 3358 # timestamp test result verification end 3359 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3360 return 1; 3361 } 3362 $ok .= "d"; 3363 } 3364 else { 3365 $ok .= "-"; # data not checked 3366 } 3367 3368 if(@upload) { 3369 # verify uploaded data 3370 my @out = loadarray("$LOGDIR/upload.$testnum"); 3371 $res = compare("upload", \@out, \@upload); 3372 if ($res) { 3373 # timestamp test result verification end 3374 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3375 return 1; 3376 } 3377 $ok .= "u"; 3378 } 3379 else { 3380 $ok .= "-"; # upload not checked 3381 } 3382 3383 if(@protocol) { 3384 # Verify the sent request 3385 my @out = loadarray($SERVERIN); 3386 3387 # what to cut off from the live protocol sent by curl 3388 my @strip = getpart("verify", "strip"); 3389 3390 my @protstrip=@protocol; 3391 3392 # check if there's any attributes on the verify/protocol section 3393 my %hash = getpartattr("verify", "protocol"); 3394 3395 if($hash{'nonewline'}) { 3396 # Yes, we must cut off the final newline from the final line 3397 # of the protocol data 3398 chomp($protstrip[$#protstrip]); 3399 } 3400 3401 for(@strip) { 3402 # strip off all lines that match the patterns from both arrays 3403 chomp $_; 3404 @out = striparray( $_, \@out); 3405 @protstrip= striparray( $_, \@protstrip); 3406 } 3407 3408 # what parts to cut off from the protocol 3409 my @strippart = getpart("verify", "strippart"); 3410 my $strip; 3411 for $strip (@strippart) { 3412 chomp $strip; 3413 for(@out) { 3414 eval $strip; 3415 } 3416 } 3417 3418 $res = compare("protocol", \@out, \@protstrip); 3419 if($res) { 3420 # timestamp test result verification end 3421 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3422 return 1; 3423 } 3424 3425 $ok .= "p"; 3426 3427 } 3428 else { 3429 $ok .= "-"; # protocol not checked 3430 } 3431 3432 my @outfile=getpart("verify", "file"); 3433 if(@outfile) { 3434 # we're supposed to verify a dynamically generated file! 3435 my %hash = getpartattr("verify", "file"); 3436 3437 my $filename=$hash{'name'}; 3438 if(!$filename) { 3439 logmsg "ERROR: section verify=>file has no name attribute\n"; 3440 stopservers($verbose); 3441 # timestamp test result verification end 3442 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3443 return -1; 3444 } 3445 my @generated=loadarray($filename); 3446 3447 # what parts to cut off from the file 3448 my @stripfile = getpart("verify", "stripfile"); 3449 3450 my $filemode=$hash{'mode'}; 3451 if($filemode && ($filemode eq "text") && $has_textaware) { 3452 # text mode when running on windows means adding an extra 3453 # strip expression 3454 push @stripfile, "s/\r\n/\n/"; 3455 } 3456 3457 my $strip; 3458 for $strip (@stripfile) { 3459 chomp $strip; 3460 for(@generated) { 3461 eval $strip; 3462 } 3463 } 3464 3465 @outfile = fixarray(@outfile); 3466 3467 $res = compare("output", \@generated, \@outfile); 3468 if($res) { 3469 # timestamp test result verification end 3470 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3471 return 1; 3472 } 3473 3474 $ok .= "o"; 3475 } 3476 else { 3477 $ok .= "-"; # output not checked 3478 } 3479 3480 # accept multiple comma-separated error codes 3481 my @splerr = split(/ *, */, $errorcode); 3482 my $errok; 3483 foreach my $e (@splerr) { 3484 if($e == $cmdres) { 3485 # a fine error code 3486 $errok = 1; 3487 last; 3488 } 3489 } 3490 3491 if($errok) { 3492 $ok .= "e"; 3493 } 3494 else { 3495 if(!$short) { 3496 printf("\n%s returned $cmdres, when expecting %s\n", 3497 (!$tool)?"curl":$tool, $errorcode); 3498 } 3499 logmsg " exit FAILED\n"; 3500 # timestamp test result verification end 3501 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3502 return 1; 3503 } 3504 3505 if($curl_debug) { 3506 if(! -f $memdump) { 3507 logmsg "\n** ALERT! memory debugging with no output file?\n" 3508 if(!$cmdtype eq "perl"); 3509 } 3510 else { 3511 my @memdata=`$memanalyze $memdump`; 3512 my $leak=0; 3513 for(@memdata) { 3514 if($_ ne "") { 3515 # well it could be other memory problems as well, but 3516 # we call it leak for short here 3517 $leak=1; 3518 } 3519 } 3520 if($leak) { 3521 logmsg "\n** MEMORY FAILURE\n"; 3522 logmsg @memdata; 3523 # timestamp test result verification end 3524 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3525 return 1; 3526 } 3527 else { 3528 $ok .= "m"; 3529 } 3530 } 3531 } 3532 else { 3533 $ok .= "-"; # memory not checked 3534 } 3535 3536 if($valgrind) { 3537 if($usevalgrind) { 3538 unless(opendir(DIR, "$LOGDIR")) { 3539 logmsg "ERROR: unable to read $LOGDIR\n"; 3540 # timestamp test result verification end 3541 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3542 return 1; 3543 } 3544 my @files = readdir(DIR); 3545 closedir(DIR); 3546 my $vgfile; 3547 foreach my $file (@files) { 3548 if($file =~ /^valgrind$testnum(\..*|)$/) { 3549 $vgfile = $file; 3550 last; 3551 } 3552 } 3553 if(!$vgfile) { 3554 logmsg "ERROR: valgrind log file missing for test $testnum\n"; 3555 # timestamp test result verification end 3556 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3557 return 1; 3558 } 3559 my @e = valgrindparse($srcdir, $feature{'SSL'}, "$LOGDIR/$vgfile"); 3560 if(@e && $e[0]) { 3561 logmsg " valgrind ERROR "; 3562 logmsg @e; 3563 # timestamp test result verification end 3564 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3565 return 1; 3566 } 3567 $ok .= "v"; 3568 } 3569 else { 3570 if(!$short && !$disablevalgrind) { 3571 logmsg " valgrind SKIPPED\n"; 3572 } 3573 $ok .= "-"; # skipped 3574 } 3575 } 3576 else { 3577 $ok .= "-"; # valgrind not checked 3578 } 3579 3580 logmsg "$ok " if(!$short); 3581 3582 my $sofar= time()-$start; 3583 my $esttotal = $sofar/$count * $total; 3584 my $estleft = $esttotal - $sofar; 3585 my $left=sprintf("remaining: %02d:%02d", 3586 $estleft/60, 3587 $estleft%60); 3588 printf "OK (%-3d out of %-3d, %s)\n", $count, $total, $left; 3589 3590 # the test succeeded, remove all log files 3591 if(!$keepoutfiles) { 3592 cleardir($LOGDIR); 3593 } 3594 3595 # timestamp test result verification end 3596 $timevrfyend{$testnum} = Time::HiRes::time() if($timestats); 3597 3598 return 0; 3599} 3600 3601####################################################################### 3602# Stop all running test servers 3603# 3604sub stopservers { 3605 my $verbose = $_[0]; 3606 # 3607 # kill sockfilter processes for all pingpong servers 3608 # 3609 killallsockfilters($verbose); 3610 # 3611 # kill all server pids from %run hash clearing them 3612 # 3613 my $pidlist; 3614 foreach my $server (keys %run) { 3615 if($run{$server}) { 3616 if($verbose) { 3617 my $prev = 0; 3618 my $pids = $run{$server}; 3619 foreach my $pid (split(' ', $pids)) { 3620 if($pid != $prev) { 3621 logmsg sprintf("* kill pid for %s => %d\n", 3622 $server, $pid); 3623 $prev = $pid; 3624 } 3625 } 3626 } 3627 $pidlist .= "$run{$server} "; 3628 $run{$server} = 0; 3629 } 3630 $runcert{$server} = 0 if($runcert{$server}); 3631 } 3632 killpid($verbose, $pidlist); 3633 # 3634 # cleanup all server pid files 3635 # 3636 foreach my $server (keys %serverpidfile) { 3637 my $pidfile = $serverpidfile{$server}; 3638 my $pid = processexists($pidfile); 3639 if($pid > 0) { 3640 logmsg "Warning: $server server unexpectedly alive\n"; 3641 killpid($verbose, $pid); 3642 } 3643 unlink($pidfile) if(-f $pidfile); 3644 } 3645} 3646 3647####################################################################### 3648# startservers() starts all the named servers 3649# 3650# Returns: string with error reason or blank for success 3651# 3652sub startservers { 3653 my @what = @_; 3654 my ($pid, $pid2); 3655 for(@what) { 3656 my (@whatlist) = split(/\s+/,$_); 3657 my $what = lc($whatlist[0]); 3658 $what =~ s/[^a-z0-9-]//g; 3659 3660 my $certfile; 3661 if($what =~ /^(ftp|http|imap|pop3|smtp)s((\d*)(-ipv6|))$/) { 3662 $certfile = ($whatlist[1]) ? $whatlist[1] : 'stunnel.pem'; 3663 } 3664 3665 if(($what eq "pop3") || 3666 ($what eq "ftp") || 3667 ($what eq "imap") || 3668 ($what eq "smtp")) { 3669 if($torture && $run{$what} && 3670 !responsive_pingpong_server($what, "", $verbose)) { 3671 stopserver($what); 3672 } 3673 if(!$run{$what}) { 3674 ($pid, $pid2) = runpingpongserver($what, "", $verbose); 3675 if($pid <= 0) { 3676 return "failed starting ". uc($what) ." server"; 3677 } 3678 printf ("* pid $what => %d %d\n", $pid, $pid2) if($verbose); 3679 $run{$what}="$pid $pid2"; 3680 } 3681 } 3682 elsif($what eq "ftp2") { 3683 if($torture && $run{'ftp2'} && 3684 !responsive_pingpong_server("ftp", "2", $verbose)) { 3685 stopserver('ftp2'); 3686 } 3687 if(!$run{'ftp2'}) { 3688 ($pid, $pid2) = runpingpongserver("ftp", "2", $verbose); 3689 if($pid <= 0) { 3690 return "failed starting FTP2 server"; 3691 } 3692 printf ("* pid ftp2 => %d %d\n", $pid, $pid2) if($verbose); 3693 $run{'ftp2'}="$pid $pid2"; 3694 } 3695 } 3696 elsif($what eq "ftp-ipv6") { 3697 if($torture && $run{'ftp-ipv6'} && 3698 !responsive_pingpong_server("ftp", "", $verbose, "ipv6")) { 3699 stopserver('ftp-ipv6'); 3700 } 3701 if(!$run{'ftp-ipv6'}) { 3702 ($pid, $pid2) = runpingpongserver("ftp", "", $verbose, "ipv6"); 3703 if($pid <= 0) { 3704 return "failed starting FTP-IPv6 server"; 3705 } 3706 logmsg sprintf("* pid ftp-ipv6 => %d %d\n", $pid, 3707 $pid2) if($verbose); 3708 $run{'ftp-ipv6'}="$pid $pid2"; 3709 } 3710 } 3711 elsif($what eq "gopher") { 3712 if($torture && $run{'gopher'} && 3713 !responsive_http_server("gopher", $verbose, 0, $GOPHERPORT)) { 3714 stopserver('gopher'); 3715 } 3716 if(!$run{'gopher'}) { 3717 ($pid, $pid2) = runhttpserver("gopher", $verbose, 0, 3718 $GOPHERPORT); 3719 if($pid <= 0) { 3720 return "failed starting GOPHER server"; 3721 } 3722 printf ("* pid gopher => %d %d\n", $pid, $pid2) if($verbose); 3723 $run{'gopher'}="$pid $pid2"; 3724 } 3725 } 3726 elsif($what eq "gopher-ipv6") { 3727 if($torture && $run{'gopher-ipv6'} && 3728 !responsive_http_server("gopher", $verbose, "ipv6", 3729 $GOPHER6PORT)) { 3730 stopserver('gopher-ipv6'); 3731 } 3732 if(!$run{'gopher-ipv6'}) { 3733 ($pid, $pid2) = runhttpserver("gopher", $verbose, "ipv6", 3734 $GOPHER6PORT); 3735 if($pid <= 0) { 3736 return "failed starting GOPHER-IPv6 server"; 3737 } 3738 logmsg sprintf("* pid gopher-ipv6 => %d %d\n", $pid, 3739 $pid2) if($verbose); 3740 $run{'gopher-ipv6'}="$pid $pid2"; 3741 } 3742 } 3743 elsif($what eq "http") { 3744 if($torture && $run{'http'} && 3745 !responsive_http_server("http", $verbose, 0, $HTTPPORT)) { 3746 stopserver('http'); 3747 } 3748 if(!$run{'http'}) { 3749 ($pid, $pid2) = runhttpserver("http", $verbose, 0, 3750 $HTTPPORT); 3751 if($pid <= 0) { 3752 return "failed starting HTTP server"; 3753 } 3754 printf ("* pid http => %d %d\n", $pid, $pid2) if($verbose); 3755 $run{'http'}="$pid $pid2"; 3756 } 3757 } 3758 elsif($what eq "http-ipv6") { 3759 if($torture && $run{'http-ipv6'} && 3760 !responsive_http_server("http", $verbose, "IPv6", $HTTP6PORT)) { 3761 stopserver('http-ipv6'); 3762 } 3763 if(!$run{'http-ipv6'}) { 3764 ($pid, $pid2) = runhttpserver("http", $verbose, "IPv6", 3765 $HTTP6PORT); 3766 if($pid <= 0) { 3767 return "failed starting HTTP-IPv6 server"; 3768 } 3769 logmsg sprintf("* pid http-ipv6 => %d %d\n", $pid, $pid2) 3770 if($verbose); 3771 $run{'http-ipv6'}="$pid $pid2"; 3772 } 3773 } 3774 elsif($what eq "rtsp") { 3775 if($torture && $run{'rtsp'} && 3776 !responsive_rtsp_server($verbose)) { 3777 stopserver('rtsp'); 3778 } 3779 if(!$run{'rtsp'}) { 3780 ($pid, $pid2) = runrtspserver($verbose); 3781 if($pid <= 0) { 3782 return "failed starting RTSP server"; 3783 } 3784 printf ("* pid rtsp => %d %d\n", $pid, $pid2) if($verbose); 3785 $run{'rtsp'}="$pid $pid2"; 3786 } 3787 } 3788 elsif($what eq "rtsp-ipv6") { 3789 if($torture && $run{'rtsp-ipv6'} && 3790 !responsive_rtsp_server($verbose, "IPv6")) { 3791 stopserver('rtsp-ipv6'); 3792 } 3793 if(!$run{'rtsp-ipv6'}) { 3794 ($pid, $pid2) = runrtspserver($verbose, "IPv6"); 3795 if($pid <= 0) { 3796 return "failed starting RTSP-IPv6 server"; 3797 } 3798 logmsg sprintf("* pid rtsp-ipv6 => %d %d\n", $pid, $pid2) 3799 if($verbose); 3800 $run{'rtsp-ipv6'}="$pid $pid2"; 3801 } 3802 } 3803 elsif($what eq "ftps") { 3804 if(!$stunnel) { 3805 # we can't run ftps tests without stunnel 3806 return "no stunnel"; 3807 } 3808 if(!$ssl_version) { 3809 # we can't run ftps tests if libcurl is SSL-less 3810 return "curl lacks SSL support"; 3811 } 3812 if($runcert{'ftps'} && ($runcert{'ftps'} ne $certfile)) { 3813 # stop server when running and using a different cert 3814 stopserver('ftps'); 3815 } 3816 if($torture && $run{'ftp'} && 3817 !responsive_pingpong_server("ftp", "", $verbose)) { 3818 stopserver('ftp'); 3819 } 3820 if(!$run{'ftp'}) { 3821 ($pid, $pid2) = runpingpongserver("ftp", "", $verbose); 3822 if($pid <= 0) { 3823 return "failed starting FTP server"; 3824 } 3825 printf ("* pid ftp => %d %d\n", $pid, $pid2) if($verbose); 3826 $run{'ftp'}="$pid $pid2"; 3827 } 3828 if(!$run{'ftps'}) { 3829 ($pid, $pid2) = runftpsserver($verbose, "", $certfile); 3830 if($pid <= 0) { 3831 return "failed starting FTPS server (stunnel)"; 3832 } 3833 logmsg sprintf("* pid ftps => %d %d\n", $pid, $pid2) 3834 if($verbose); 3835 $run{'ftps'}="$pid $pid2"; 3836 } 3837 } 3838 elsif($what eq "file") { 3839 # we support it but have no server! 3840 } 3841 elsif($what eq "https") { 3842 if(!$stunnel) { 3843 # we can't run https tests without stunnel 3844 return "no stunnel"; 3845 } 3846 if(!$ssl_version) { 3847 # we can't run https tests if libcurl is SSL-less 3848 return "curl lacks SSL support"; 3849 } 3850 if($runcert{'https'} && ($runcert{'https'} ne $certfile)) { 3851 # stop server when running and using a different cert 3852 stopserver('https'); 3853 } 3854 if($torture && $run{'http'} && 3855 !responsive_http_server("http", $verbose, 0, $HTTPPORT)) { 3856 stopserver('http'); 3857 } 3858 if(!$run{'http'}) { 3859 ($pid, $pid2) = runhttpserver("http", $verbose, 0, 3860 $HTTPPORT); 3861 if($pid <= 0) { 3862 return "failed starting HTTP server"; 3863 } 3864 printf ("* pid http => %d %d\n", $pid, $pid2) if($verbose); 3865 $run{'http'}="$pid $pid2"; 3866 } 3867 if(!$run{'https'}) { 3868 ($pid, $pid2) = runhttpsserver($verbose, "", $certfile); 3869 if($pid <= 0) { 3870 return "failed starting HTTPS server (stunnel)"; 3871 } 3872 logmsg sprintf("* pid https => %d %d\n", $pid, $pid2) 3873 if($verbose); 3874 $run{'https'}="$pid $pid2"; 3875 } 3876 } 3877 elsif($what eq "httptls") { 3878 if(!$httptlssrv) { 3879 # for now, we can't run http TLS-EXT tests without gnutls-serv 3880 return "no gnutls-serv"; 3881 } 3882 if($torture && $run{'httptls'} && 3883 !responsive_httptls_server($verbose, "IPv4")) { 3884 stopserver('httptls'); 3885 } 3886 if(!$run{'httptls'}) { 3887 ($pid, $pid2) = runhttptlsserver($verbose, "IPv4"); 3888 if($pid <= 0) { 3889 return "failed starting HTTPTLS server (gnutls-serv)"; 3890 } 3891 logmsg sprintf("* pid httptls => %d %d\n", $pid, $pid2) 3892 if($verbose); 3893 $run{'httptls'}="$pid $pid2"; 3894 } 3895 } 3896 elsif($what eq "httptls-ipv6") { 3897 if(!$httptlssrv) { 3898 # for now, we can't run http TLS-EXT tests without gnutls-serv 3899 return "no gnutls-serv"; 3900 } 3901 if($torture && $run{'httptls-ipv6'} && 3902 !responsive_httptls_server($verbose, "IPv6")) { 3903 stopserver('httptls-ipv6'); 3904 } 3905 if(!$run{'httptls-ipv6'}) { 3906 ($pid, $pid2) = runhttptlsserver($verbose, "IPv6"); 3907 if($pid <= 0) { 3908 return "failed starting HTTPTLS-IPv6 server (gnutls-serv)"; 3909 } 3910 logmsg sprintf("* pid httptls-ipv6 => %d %d\n", $pid, $pid2) 3911 if($verbose); 3912 $run{'httptls-ipv6'}="$pid $pid2"; 3913 } 3914 } 3915 elsif($what eq "tftp") { 3916 if($torture && $run{'tftp'} && 3917 !responsive_tftp_server("", $verbose)) { 3918 stopserver('tftp'); 3919 } 3920 if(!$run{'tftp'}) { 3921 ($pid, $pid2) = runtftpserver("", $verbose); 3922 if($pid <= 0) { 3923 return "failed starting TFTP server"; 3924 } 3925 printf ("* pid tftp => %d %d\n", $pid, $pid2) if($verbose); 3926 $run{'tftp'}="$pid $pid2"; 3927 } 3928 } 3929 elsif($what eq "tftp-ipv6") { 3930 if($torture && $run{'tftp-ipv6'} && 3931 !responsive_tftp_server("", $verbose, "IPv6")) { 3932 stopserver('tftp-ipv6'); 3933 } 3934 if(!$run{'tftp-ipv6'}) { 3935 ($pid, $pid2) = runtftpserver("", $verbose, "IPv6"); 3936 if($pid <= 0) { 3937 return "failed starting TFTP-IPv6 server"; 3938 } 3939 printf("* pid tftp-ipv6 => %d %d\n", $pid, $pid2) if($verbose); 3940 $run{'tftp-ipv6'}="$pid $pid2"; 3941 } 3942 } 3943 elsif($what eq "sftp" || $what eq "scp" || $what eq "socks4" || $what eq "socks5" ) { 3944 if(!$run{'ssh'}) { 3945 ($pid, $pid2) = runsshserver("", $verbose); 3946 if($pid <= 0) { 3947 return "failed starting SSH server"; 3948 } 3949 printf ("* pid ssh => %d %d\n", $pid, $pid2) if($verbose); 3950 $run{'ssh'}="$pid $pid2"; 3951 } 3952 if($what eq "socks4" || $what eq "socks5") { 3953 if(!$run{'socks'}) { 3954 ($pid, $pid2) = runsocksserver("", $verbose); 3955 if($pid <= 0) { 3956 return "failed starting socks server"; 3957 } 3958 printf ("* pid socks => %d %d\n", $pid, $pid2) if($verbose); 3959 $run{'socks'}="$pid $pid2"; 3960 } 3961 } 3962 if($what eq "socks5") { 3963 if(!$sshdid) { 3964 # Not an OpenSSH or SunSSH ssh daemon 3965 logmsg "Not OpenSSH or SunSSH; socks5 tests need at least OpenSSH 3.7\n"; 3966 return "failed starting socks5 server"; 3967 } 3968 elsif(($sshdid =~ /OpenSSH/) && ($sshdvernum < 370)) { 3969 # Need OpenSSH 3.7 for socks5 - http://www.openssh.com/txt/release-3.7 3970 logmsg "$sshdverstr insufficient; socks5 tests need at least OpenSSH 3.7\n"; 3971 return "failed starting socks5 server"; 3972 } 3973 elsif(($sshdid =~ /SunSSH/) && ($sshdvernum < 100)) { 3974 # Need SunSSH 1.0 for socks5 3975 logmsg "$sshdverstr insufficient; socks5 tests need at least SunSSH 1.0\n"; 3976 return "failed starting socks5 server"; 3977 } 3978 } 3979 } 3980 elsif($what eq "none") { 3981 logmsg "* starts no server\n" if ($verbose); 3982 } 3983 else { 3984 warn "we don't support a server for $what"; 3985 return "no server for $what"; 3986 } 3987 } 3988 return 0; 3989} 3990 3991############################################################################## 3992# This function makes sure the right set of server is running for the 3993# specified test case. This is a useful design when we run single tests as not 3994# all servers need to run then! 3995# 3996# Returns: a string, blank if everything is fine or a reason why it failed 3997# 3998sub serverfortest { 3999 my ($testnum)=@_; 4000 4001 my @what = getpart("client", "server"); 4002 4003 if(!$what[0]) { 4004 warn "Test case $testnum has no server(s) specified"; 4005 return "no server specified"; 4006 } 4007 4008 for(my $i = scalar(@what) - 1; $i >= 0; $i--) { 4009 my $srvrline = $what[$i]; 4010 chomp $srvrline if($srvrline); 4011 if($srvrline =~ /^(\S+)((\s*)(.*))/) { 4012 my $server = "${1}"; 4013 my $lnrest = "${2}"; 4014 my $tlsext; 4015 if($server =~ /^(httptls)(\+)(ext|srp)(\d*)(-ipv6|)$/) { 4016 $server = "${1}${4}${5}"; 4017 $tlsext = uc("TLS-${3}"); 4018 } 4019 if(! grep /^\Q$server\E$/, @protocols) { 4020 if(substr($server,0,5) ne "socks") { 4021 if($tlsext) { 4022 return "curl lacks $tlsext support"; 4023 } 4024 else { 4025 return "curl lacks $server support"; 4026 } 4027 } 4028 } 4029 $what[$i] = "$server$lnrest" if($tlsext); 4030 } 4031 } 4032 4033 return &startservers(@what); 4034} 4035 4036####################################################################### 4037# runtimestats displays test-suite run time statistics 4038# 4039sub runtimestats { 4040 my $lasttest = $_[0]; 4041 4042 return if(not $timestats); 4043 4044 logmsg "\nTest suite total running time breakdown per task...\n\n"; 4045 4046 my @timesrvr; 4047 my @timeprep; 4048 my @timetool; 4049 my @timelock; 4050 my @timevrfy; 4051 my @timetest; 4052 my $timesrvrtot = 0.0; 4053 my $timepreptot = 0.0; 4054 my $timetooltot = 0.0; 4055 my $timelocktot = 0.0; 4056 my $timevrfytot = 0.0; 4057 my $timetesttot = 0.0; 4058 my $counter; 4059 4060 for my $testnum (1 .. $lasttest) { 4061 if($timesrvrini{$testnum}) { 4062 $timesrvrtot += $timesrvrend{$testnum} - $timesrvrini{$testnum}; 4063 $timepreptot += 4064 (($timetoolini{$testnum} - $timeprepini{$testnum}) - 4065 ($timesrvrend{$testnum} - $timesrvrini{$testnum})); 4066 $timetooltot += $timetoolend{$testnum} - $timetoolini{$testnum}; 4067 $timelocktot += $timesrvrlog{$testnum} - $timetoolend{$testnum}; 4068 $timevrfytot += $timevrfyend{$testnum} - $timesrvrlog{$testnum}; 4069 $timetesttot += $timevrfyend{$testnum} - $timeprepini{$testnum}; 4070 push @timesrvr, sprintf("%06.3f %04d", 4071 $timesrvrend{$testnum} - $timesrvrini{$testnum}, $testnum); 4072 push @timeprep, sprintf("%06.3f %04d", 4073 ($timetoolini{$testnum} - $timeprepini{$testnum}) - 4074 ($timesrvrend{$testnum} - $timesrvrini{$testnum}), $testnum); 4075 push @timetool, sprintf("%06.3f %04d", 4076 $timetoolend{$testnum} - $timetoolini{$testnum}, $testnum); 4077 push @timelock, sprintf("%06.3f %04d", 4078 $timesrvrlog{$testnum} - $timetoolend{$testnum}, $testnum); 4079 push @timevrfy, sprintf("%06.3f %04d", 4080 $timevrfyend{$testnum} - $timesrvrlog{$testnum}, $testnum); 4081 push @timetest, sprintf("%06.3f %04d", 4082 $timevrfyend{$testnum} - $timeprepini{$testnum}, $testnum); 4083 } 4084 } 4085 4086 { 4087 no warnings 'numeric'; 4088 @timesrvr = sort { $b <=> $a } @timesrvr; 4089 @timeprep = sort { $b <=> $a } @timeprep; 4090 @timetool = sort { $b <=> $a } @timetool; 4091 @timelock = sort { $b <=> $a } @timelock; 4092 @timevrfy = sort { $b <=> $a } @timevrfy; 4093 @timetest = sort { $b <=> $a } @timetest; 4094 } 4095 4096 logmsg "Spent ". sprintf("%08.3f ", $timesrvrtot) . 4097 "seconds starting and verifying test harness servers.\n"; 4098 logmsg "Spent ". sprintf("%08.3f ", $timepreptot) . 4099 "seconds reading definitions and doing test preparations.\n"; 4100 logmsg "Spent ". sprintf("%08.3f ", $timetooltot) . 4101 "seconds actually running test tools.\n"; 4102 logmsg "Spent ". sprintf("%08.3f ", $timelocktot) . 4103 "seconds awaiting server logs lock removal.\n"; 4104 logmsg "Spent ". sprintf("%08.3f ", $timevrfytot) . 4105 "seconds verifying test results.\n"; 4106 logmsg "Spent ". sprintf("%08.3f ", $timetesttot) . 4107 "seconds doing all of the above.\n"; 4108 4109 $counter = 25; 4110 logmsg "\nTest server starting and verification time per test ". 4111 sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full"); 4112 logmsg "-time- test\n"; 4113 logmsg "------ ----\n"; 4114 foreach my $txt (@timesrvr) { 4115 last if((not $fullstats) && (not $counter--)); 4116 logmsg "$txt\n"; 4117 } 4118 4119 $counter = 10; 4120 logmsg "\nTest definition reading and preparation time per test ". 4121 sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full"); 4122 logmsg "-time- test\n"; 4123 logmsg "------ ----\n"; 4124 foreach my $txt (@timeprep) { 4125 last if((not $fullstats) && (not $counter--)); 4126 logmsg "$txt\n"; 4127 } 4128 4129 $counter = 25; 4130 logmsg "\nTest tool execution time per test ". 4131 sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full"); 4132 logmsg "-time- test\n"; 4133 logmsg "------ ----\n"; 4134 foreach my $txt (@timetool) { 4135 last if((not $fullstats) && (not $counter--)); 4136 logmsg "$txt\n"; 4137 } 4138 4139 $counter = 15; 4140 logmsg "\nTest server logs lock removal time per test ". 4141 sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full"); 4142 logmsg "-time- test\n"; 4143 logmsg "------ ----\n"; 4144 foreach my $txt (@timelock) { 4145 last if((not $fullstats) && (not $counter--)); 4146 logmsg "$txt\n"; 4147 } 4148 4149 $counter = 10; 4150 logmsg "\nTest results verification time per test ". 4151 sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full"); 4152 logmsg "-time- test\n"; 4153 logmsg "------ ----\n"; 4154 foreach my $txt (@timevrfy) { 4155 last if((not $fullstats) && (not $counter--)); 4156 logmsg "$txt\n"; 4157 } 4158 4159 $counter = 50; 4160 logmsg "\nTotal time per test ". 4161 sprintf("(%s)...\n\n", (not $fullstats)?"top $counter":"full"); 4162 logmsg "-time- test\n"; 4163 logmsg "------ ----\n"; 4164 foreach my $txt (@timetest) { 4165 last if((not $fullstats) && (not $counter--)); 4166 logmsg "$txt\n"; 4167 } 4168 4169 logmsg "\n"; 4170} 4171 4172####################################################################### 4173# Check options to this test program 4174# 4175 4176my $number=0; 4177my $fromnum=-1; 4178my @testthis; 4179while(@ARGV) { 4180 if ($ARGV[0] eq "-v") { 4181 # verbose output 4182 $verbose=1; 4183 } 4184 elsif($ARGV[0] =~ /^-b(.*)/) { 4185 my $portno=$1; 4186 if($portno =~ s/(\d+)$//) { 4187 $base = int $1; 4188 } 4189 } 4190 elsif ($ARGV[0] eq "-c") { 4191 # use this path to curl instead of default 4192 $DBGCURL=$CURL=$ARGV[1]; 4193 shift @ARGV; 4194 } 4195 elsif ($ARGV[0] eq "-d") { 4196 # have the servers display protocol output 4197 $debugprotocol=1; 4198 } 4199 elsif ($ARGV[0] eq "-f") { 4200 # run fork-servers, which makes the server fork for all new 4201 # connections This is NOT what you wanna do without knowing exactly 4202 # why and for what 4203 $forkserver=1; 4204 } 4205 elsif ($ARGV[0] eq "-g") { 4206 # run this test with gdb 4207 $gdbthis=1; 4208 } 4209 elsif ($ARGV[0] eq "-gw") { 4210 # run this test with windowed gdb 4211 $gdbthis=1; 4212 $gdbxwin=1; 4213 } 4214 elsif($ARGV[0] eq "-s") { 4215 # short output 4216 $short=1; 4217 } 4218 elsif($ARGV[0] eq "-n") { 4219 # no valgrind 4220 undef $valgrind; 4221 } 4222 elsif($ARGV[0] =~ /^-t(.*)/) { 4223 # torture 4224 $torture=1; 4225 my $xtra = $1; 4226 4227 if($xtra =~ s/(\d+)$//) { 4228 $tortalloc = $1; 4229 } 4230 # we undef valgrind to make this fly in comparison 4231 undef $valgrind; 4232 } 4233 elsif($ARGV[0] eq "-a") { 4234 # continue anyway, even if a test fail 4235 $anyway=1; 4236 } 4237 elsif($ARGV[0] eq "-p") { 4238 $postmortem=1; 4239 } 4240 elsif($ARGV[0] eq "-l") { 4241 # lists the test case names only 4242 $listonly=1; 4243 } 4244 elsif($ARGV[0] eq "-k") { 4245 # keep stdout and stderr files after tests 4246 $keepoutfiles=1; 4247 } 4248 elsif($ARGV[0] eq "-r") { 4249 # run time statistics needs Time::HiRes 4250 if($Time::HiRes::VERSION) { 4251 keys(%timeprepini) = 1000; 4252 keys(%timesrvrini) = 1000; 4253 keys(%timesrvrend) = 1000; 4254 keys(%timetoolini) = 1000; 4255 keys(%timetoolend) = 1000; 4256 keys(%timesrvrlog) = 1000; 4257 keys(%timevrfyend) = 1000; 4258 $timestats=1; 4259 $fullstats=0; 4260 } 4261 } 4262 elsif($ARGV[0] eq "-rf") { 4263 # run time statistics needs Time::HiRes 4264 if($Time::HiRes::VERSION) { 4265 keys(%timeprepini) = 1000; 4266 keys(%timesrvrini) = 1000; 4267 keys(%timesrvrend) = 1000; 4268 keys(%timetoolini) = 1000; 4269 keys(%timetoolend) = 1000; 4270 keys(%timesrvrlog) = 1000; 4271 keys(%timevrfyend) = 1000; 4272 $timestats=1; 4273 $fullstats=1; 4274 } 4275 } 4276 elsif(($ARGV[0] eq "-h") || ($ARGV[0] eq "--help")) { 4277 # show help text 4278 print <<EOHELP 4279Usage: runtests.pl [options] [test selection(s)] 4280 -a continue even if a test fails 4281 -bN use base port number N for test servers (default $base) 4282 -c path use this curl executable 4283 -d display server debug info 4284 -g run the test case with gdb 4285 -gw run the test case with gdb as a windowed application 4286 -h this help text 4287 -k keep stdout and stderr files present after tests 4288 -l list all test case names/descriptions 4289 -n no valgrind 4290 -p print log file contents when a test fails 4291 -r run time statistics 4292 -rf full run time statistics 4293 -s short output 4294 -t[N] torture (simulate memory alloc failures); N means fail Nth alloc 4295 -v verbose output 4296 [num] like "5 6 9" or " 5 to 22 " to run those tests only 4297 [!num] like "!5 !6 !9" to disable those tests 4298 [keyword] like "IPv6" to select only tests containing the key word 4299 [!keyword] like "!cookies" to disable any tests containing the key word 4300EOHELP 4301 ; 4302 exit; 4303 } 4304 elsif($ARGV[0] =~ /^(\d+)/) { 4305 $number = $1; 4306 if($fromnum >= 0) { 4307 for($fromnum .. $number) { 4308 push @testthis, $_; 4309 } 4310 $fromnum = -1; 4311 } 4312 else { 4313 push @testthis, $1; 4314 } 4315 } 4316 elsif($ARGV[0] =~ /^to$/i) { 4317 $fromnum = $number+1; 4318 } 4319 elsif($ARGV[0] =~ /^!(\d+)/) { 4320 $fromnum = -1; 4321 $disabled{$1}=$1; 4322 } 4323 elsif($ARGV[0] =~ /^!(.+)/) { 4324 $disabled_keywords{$1}=$1; 4325 } 4326 elsif($ARGV[0] =~ /^([-[{a-zA-Z].*)/) { 4327 $enabled_keywords{$1}=$1; 4328 } 4329 else { 4330 print "Unknown option: $ARGV[0]\n"; 4331 exit; 4332 } 4333 shift @ARGV; 4334} 4335 4336if(@testthis && ($testthis[0] ne "")) { 4337 $TESTCASES=join(" ", @testthis); 4338} 4339 4340if($valgrind) { 4341 # we have found valgrind on the host, use it 4342 4343 # verify that we can invoke it fine 4344 my $code = runclient("valgrind >/dev/null 2>&1"); 4345 4346 if(($code>>8) != 1) { 4347 #logmsg "Valgrind failure, disable it\n"; 4348 undef $valgrind; 4349 } else { 4350 4351 # since valgrind 2.1.x, '--tool' option is mandatory 4352 # use it, if it is supported by the version installed on the system 4353 runclient("valgrind --help 2>&1 | grep -- --tool > /dev/null 2>&1"); 4354 if (($? >> 8)==0) { 4355 $valgrind_tool="--tool=memcheck"; 4356 } 4357 open(C, "<$CURL"); 4358 my $l = <C>; 4359 if($l =~ /^\#\!/) { 4360 # A shell script. This is typically when built with libtool, 4361 $valgrind="../libtool --mode=execute $valgrind"; 4362 } 4363 close(C); 4364 4365 # valgrind 3 renamed the --logfile option to --log-file!!! 4366 my $ver=join(' ', runclientoutput("valgrind --version")); 4367 # cut off all but digits and dots 4368 $ver =~ s/[^0-9.]//g; 4369 4370 if($ver =~ /^(\d+)/) { 4371 $ver = $1; 4372 if($ver >= 3) { 4373 $valgrind_logfile="--log-file"; 4374 } 4375 } 4376 } 4377} 4378 4379if ($gdbthis) { 4380 # open the executable curl and read the first 4 bytes of it 4381 open(CHECK, "<$CURL"); 4382 my $c; 4383 sysread CHECK, $c, 4; 4384 close(CHECK); 4385 if($c eq "#! /") { 4386 # A shell script. This is typically when built with libtool, 4387 $libtool = 1; 4388 $gdb = "libtool --mode=execute gdb"; 4389 } 4390} 4391 4392$HTTPPORT = $base++; # HTTP server port 4393$HTTPSPORT = $base++; # HTTPS (stunnel) server port 4394$FTPPORT = $base++; # FTP server port 4395$FTPSPORT = $base++; # FTPS (stunnel) server port 4396$HTTP6PORT = $base++; # HTTP IPv6 server port 4397$FTP2PORT = $base++; # FTP server 2 port 4398$FTP6PORT = $base++; # FTP IPv6 port 4399$TFTPPORT = $base++; # TFTP (UDP) port 4400$TFTP6PORT = $base++; # TFTP IPv6 (UDP) port 4401$SSHPORT = $base++; # SSH (SCP/SFTP) port 4402$SOCKSPORT = $base++; # SOCKS port 4403$POP3PORT = $base++; # POP3 server port 4404$POP36PORT = $base++; # POP3 IPv6 server port 4405$IMAPPORT = $base++; # IMAP server port 4406$IMAP6PORT = $base++; # IMAP IPv6 server port 4407$SMTPPORT = $base++; # SMTP server port 4408$SMTP6PORT = $base++; # SMTP IPv6 server port 4409$RTSPPORT = $base++; # RTSP server port 4410$RTSP6PORT = $base++; # RTSP IPv6 server port 4411$GOPHERPORT = $base++; # Gopher IPv4 server port 4412$GOPHER6PORT = $base++; # Gopher IPv6 server port 4413$HTTPTLSPORT = $base++; # HTTP TLS (non-stunnel) server port 4414$HTTPTLS6PORT = $base++; # HTTP TLS (non-stunnel) IPv6 server port 4415 4416####################################################################### 4417# clear and create logging directory: 4418# 4419 4420cleardir($LOGDIR); 4421mkdir($LOGDIR, 0777); 4422 4423####################################################################### 4424# initialize some variables 4425# 4426 4427get_disttests(); 4428init_serverpidfile_hash(); 4429 4430####################################################################### 4431# Output curl version and host info being tested 4432# 4433 4434if(!$listonly) { 4435 checksystem(); 4436} 4437 4438####################################################################### 4439# Fetch all disabled tests 4440# 4441 4442open(D, "<$TESTDIR/DISABLED"); 4443while(<D>) { 4444 if(/^ *\#/) { 4445 # allow comments 4446 next; 4447 } 4448 if($_ =~ /(\d+)/) { 4449 $disabled{$1}=$1; # disable this test number 4450 } 4451} 4452close(D); 4453 4454####################################################################### 4455# If 'all' tests are requested, find out all test numbers 4456# 4457 4458if ( $TESTCASES eq "all") { 4459 # Get all commands and find out their test numbers 4460 opendir(DIR, $TESTDIR) || die "can't opendir $TESTDIR: $!"; 4461 my @cmds = grep { /^test([0-9]+)$/ && -f "$TESTDIR/$_" } readdir(DIR); 4462 closedir(DIR); 4463 4464 $TESTCASES=""; # start with no test cases 4465 4466 # cut off everything but the digits 4467 for(@cmds) { 4468 $_ =~ s/[a-z\/\.]*//g; 4469 } 4470 # sort the numbers from low to high 4471 foreach my $n (sort { $a <=> $b } @cmds) { 4472 if($disabled{$n}) { 4473 # skip disabled test cases 4474 my $why = "configured as DISABLED"; 4475 $skipped++; 4476 $skipped{$why}++; 4477 $teststat[$n]=$why; # store reason for this test case 4478 next; 4479 } 4480 $TESTCASES .= " $n"; 4481 } 4482} 4483 4484####################################################################### 4485# Start the command line log 4486# 4487open(CMDLOG, ">$CURLLOG") || 4488 logmsg "can't log command lines to $CURLLOG\n"; 4489 4490####################################################################### 4491 4492# Display the contents of the given file. Line endings are canonicalized 4493# and excessively long files are elided 4494sub displaylogcontent { 4495 my ($file)=@_; 4496 if(open(SINGLE, "<$file")) { 4497 my $linecount = 0; 4498 my $truncate; 4499 my @tail; 4500 while(my $string = <SINGLE>) { 4501 $string =~ s/\r\n/\n/g; 4502 $string =~ s/[\r\f\032]/\n/g; 4503 $string .= "\n" unless ($string =~ /\n$/); 4504 $string =~ tr/\n//; 4505 for my $line (split("\n", $string)) { 4506 $line =~ s/\s*\!$//; 4507 if ($truncate) { 4508 push @tail, " $line\n"; 4509 } else { 4510 logmsg " $line\n"; 4511 } 4512 $linecount++; 4513 $truncate = $linecount > 1000; 4514 } 4515 } 4516 if(@tail) { 4517 my $tailshow = 200; 4518 my $tailskip = 0; 4519 my $tailtotal = scalar @tail; 4520 if($tailtotal > $tailshow) { 4521 $tailskip = $tailtotal - $tailshow; 4522 logmsg "=== File too long: $tailskip lines omitted here\n"; 4523 } 4524 for($tailskip .. $tailtotal-1) { 4525 logmsg "$tail[$_]"; 4526 } 4527 } 4528 close(SINGLE); 4529 } 4530} 4531 4532sub displaylogs { 4533 my ($testnum)=@_; 4534 opendir(DIR, "$LOGDIR") || 4535 die "can't open dir: $!"; 4536 my @logs = readdir(DIR); 4537 closedir(DIR); 4538 4539 logmsg "== Contents of files in the $LOGDIR/ dir after test $testnum\n"; 4540 foreach my $log (sort @logs) { 4541 if($log =~ /\.(\.|)$/) { 4542 next; # skip "." and ".." 4543 } 4544 if($log =~ /^\.nfs/) { 4545 next; # skip ".nfs" 4546 } 4547 if(($log eq "memdump") || ($log eq "core")) { 4548 next; # skip "memdump" and "core" 4549 } 4550 if((-d "$LOGDIR/$log") || (! -s "$LOGDIR/$log")) { 4551 next; # skip directory and empty files 4552 } 4553 if(($log =~ /^stdout\d+/) && ($log !~ /^stdout$testnum/)) { 4554 next; # skip stdoutNnn of other tests 4555 } 4556 if(($log =~ /^stderr\d+/) && ($log !~ /^stderr$testnum/)) { 4557 next; # skip stderrNnn of other tests 4558 } 4559 if(($log =~ /^upload\d+/) && ($log !~ /^upload$testnum/)) { 4560 next; # skip uploadNnn of other tests 4561 } 4562 if(($log =~ /^curl\d+\.out/) && ($log !~ /^curl$testnum\.out/)) { 4563 next; # skip curlNnn.out of other tests 4564 } 4565 if(($log =~ /^test\d+\.txt/) && ($log !~ /^test$testnum\.txt/)) { 4566 next; # skip testNnn.txt of other tests 4567 } 4568 if(($log =~ /^file\d+\.txt/) && ($log !~ /^file$testnum\.txt/)) { 4569 next; # skip fileNnn.txt of other tests 4570 } 4571 if(($log =~ /^netrc\d+/) && ($log !~ /^netrc$testnum/)) { 4572 next; # skip netrcNnn of other tests 4573 } 4574 if(($log =~ /^valgrind\d+/) && ($log !~ /^valgrind$testnum(\..*|)$/)) { 4575 next; # skip valgrindNnn of other tests 4576 } 4577 logmsg "=== Start of file $log\n"; 4578 displaylogcontent("$LOGDIR/$log"); 4579 logmsg "=== End of file $log\n"; 4580 } 4581} 4582 4583####################################################################### 4584# The main test-loop 4585# 4586 4587my $failed; 4588my $testnum; 4589my $ok=0; 4590my $total=0; 4591my $lasttest=0; 4592my @at = split(" ", $TESTCASES); 4593my $count=0; 4594 4595$start = time(); 4596 4597foreach $testnum (@at) { 4598 4599 $lasttest = $testnum if($testnum > $lasttest); 4600 $count++; 4601 4602 my $error = singletest($testnum, $count, scalar(@at)); 4603 if($error < 0) { 4604 # not a test we can run 4605 next; 4606 } 4607 4608 $total++; # number of tests we've run 4609 4610 if($error>0) { 4611 $failed.= "$testnum "; 4612 if($postmortem) { 4613 # display all files in log/ in a nice way 4614 displaylogs($testnum); 4615 } 4616 if(!$anyway) { 4617 # a test failed, abort 4618 logmsg "\n - abort tests\n"; 4619 last; 4620 } 4621 } 4622 elsif(!$error) { 4623 $ok++; # successful test counter 4624 } 4625 4626 # loop for next test 4627} 4628 4629my $sofar = time() - $start; 4630 4631####################################################################### 4632# Close command log 4633# 4634close(CMDLOG); 4635 4636# Tests done, stop the servers 4637stopservers($verbose); 4638 4639my $all = $total + $skipped; 4640 4641runtimestats($lasttest); 4642 4643if($total) { 4644 logmsg sprintf("TESTDONE: $ok tests out of $total reported OK: %d%%\n", 4645 $ok/$total*100); 4646 4647 if($ok != $total) { 4648 logmsg "TESTFAIL: These test cases failed: $failed\n"; 4649 } 4650} 4651else { 4652 logmsg "TESTFAIL: No tests were performed\n"; 4653} 4654 4655if($all) { 4656 logmsg "TESTDONE: $all tests were considered during ". 4657 sprintf("%.0f", $sofar) ." seconds.\n"; 4658} 4659 4660if($skipped && !$short) { 4661 my $s=0; 4662 logmsg "TESTINFO: $skipped tests were skipped due to these restraints:\n"; 4663 4664 for(keys %skipped) { 4665 my $r = $_; 4666 printf "TESTINFO: \"%s\" %d times (", $r, $skipped{$_}; 4667 4668 # now show all test case numbers that had this reason for being 4669 # skipped 4670 my $c=0; 4671 for(0 .. scalar @teststat) { 4672 my $t = $_; 4673 if($teststat[$_] && ($teststat[$_] eq $r)) { 4674 logmsg ", " if($c); 4675 logmsg $_; 4676 $c++; 4677 } 4678 } 4679 logmsg ")\n"; 4680 } 4681} 4682 4683if($total && ($ok != $total)) { 4684 exit 1; 4685} 4686