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