1#*************************************************************************** 2# _ _ ____ _ 3# Project ___| | | | _ \| | 4# / __| | | | |_) | | 5# | (__| |_| | _ <| |___ 6# \___|\___/|_| \_\_____| 7# 8# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al. 9# 10# This software is licensed as described in the file COPYING, which 11# you should have received as part of this distribution. The terms 12# are also available at https://curl.se/docs/copyright.html. 13# 14# You may opt to use, copy, modify, merge, publish, distribute and/or sell 15# copies of the Software, and permit persons to whom the Software is 16# furnished to do so, under the terms of the COPYING file. 17# 18# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY 19# KIND, either express or implied. 20# 21# SPDX-License-Identifier: curl 22# 23########################################################################### 24 25# This module contains entry points to run a single test. runner_init 26# determines whether they will run in a separate process or in the process of 27# the caller. The relevant interface is asynchronous so it will work in either 28# case. Program arguments are marshalled and then written to the end of a pipe 29# (in controlleripccall) which is later read from and the arguments 30# unmarshalled (in ipcrecv) before the desired function is called normally. 31# The function return values are then marshalled and written into another pipe 32# (again in ipcrecv) when is later read from and unmarshalled (in runnerar) 33# before being returned to the caller. 34 35package runner; 36 37use strict; 38use warnings; 39use 5.006; 40 41BEGIN { 42 use base qw(Exporter); 43 44 our @EXPORT = qw( 45 checktestcmd 46 prepro 47 readtestkeywords 48 restore_test_env 49 runner_init 50 runnerac_clearlocks 51 runnerac_shutdown 52 runnerac_stopservers 53 runnerac_test_preprocess 54 runnerac_test_run 55 runnerar 56 runnerar_ready 57 stderrfilename 58 stdoutfilename 59 $DBGCURL 60 $gdb 61 $gdbthis 62 $gdbxwin 63 $shallow 64 $tortalloc 65 $valgrind_logfile 66 $valgrind_tool 67 ); 68 69 # these are for debugging only 70 our @EXPORT_OK = qw( 71 singletest_preprocess 72 ); 73} 74 75use B qw( 76 svref_2object 77 ); 78use Storable qw( 79 freeze 80 thaw 81 ); 82 83use pathhelp qw( 84 exe_ext 85 ); 86use processhelp qw( 87 portable_sleep 88 ); 89use servers qw( 90 checkcmd 91 clearlocks 92 initserverconfig 93 serverfortest 94 stopserver 95 stopservers 96 subvariables 97 ); 98use getpart; 99use globalconfig; 100use testutil qw( 101 clearlogs 102 logmsg 103 runclient 104 shell_quote 105 subbase64 106 subnewlines 107 ); 108use valgrind; 109 110 111####################################################################### 112# Global variables set elsewhere but used only by this package 113# These may only be set *before* runner_init is called 114our $DBGCURL=$CURL; #"../src/.libs/curl"; # alternative for debugging 115our $valgrind_logfile="--log-file"; # the option name for valgrind >=3 116our $valgrind_tool="--tool=memcheck"; 117our $gdb = checktestcmd("gdb"); 118our $gdbthis; # run test case with gdb debugger 119our $gdbxwin; # use windowed gdb when using gdb 120 121# torture test variables 122our $shallow; 123our $tortalloc; 124 125# local variables 126my %oldenv; # environment variables before test is started 127my $UNITDIR="./unit"; 128my $CURLLOG="$LOGDIR/commands.log"; # all command lines run 129my $defserverlogslocktimeout = 5; # timeout to await server logs lock removal 130my $defpostcommanddelay = 0; # delay between command and postcheck sections 131my $multiprocess; # nonzero with a separate test runner process 132 133# pipes 134my $runnerr; # pipe that runner reads from 135my $runnerw; # pipe that runner writes to 136 137# per-runner variables, indexed by runner ID; these are used by controller only 138my %controllerr; # pipe that controller reads from 139my %controllerw; # pipe that controller writes to 140 141# redirected stdout/stderr to these files 142sub stdoutfilename { 143 my ($logdir, $testnum)=@_; 144 return "$logdir/stdout$testnum"; 145} 146 147sub stderrfilename { 148 my ($logdir, $testnum)=@_; 149 return "$logdir/stderr$testnum"; 150} 151 152####################################################################### 153# Initialize the runner and prepare it to run tests 154# The runner ID returned by this function must be passed into the other 155# runnerac_* functions 156# Called by controller 157sub runner_init { 158 my ($logdir, $jobs)=@_; 159 160 $multiprocess = !!$jobs; 161 162 # enable memory debugging if curl is compiled with it 163 $ENV{'CURL_MEMDEBUG'} = "$logdir/$MEMDUMP"; 164 $ENV{'CURL_ENTROPY'}="12345678"; 165 $ENV{'CURL_FORCETIME'}=1; # for debug NTLM magic 166 $ENV{'CURL_GLOBAL_INIT'}=1; # debug curl_global_init/cleanup use 167 $ENV{'HOME'}=$pwd; 168 $ENV{'CURL_HOME'}=$ENV{'HOME'}; 169 $ENV{'XDG_CONFIG_HOME'}=$ENV{'HOME'}; 170 $ENV{'COLUMNS'}=79; # screen width! 171 172 # Incorporate the $logdir into the random seed and re-seed the PRNG. 173 # This gives each runner a unique yet consistent seed which provides 174 # more unique port number selection in each runner, yet is deterministic 175 # across runs. 176 $randseed += unpack('%16C*', $logdir); 177 srand $randseed; 178 179 # create pipes for communication with runner 180 my ($thisrunnerr, $thiscontrollerw, $thiscontrollerr, $thisrunnerw); 181 pipe $thisrunnerr, $thiscontrollerw; 182 pipe $thiscontrollerr, $thisrunnerw; 183 184 my $thisrunnerid; 185 if($multiprocess) { 186 # Create a separate process in multiprocess mode 187 my $child = fork(); 188 if(0 == $child) { 189 # TODO: set up better signal handlers 190 $SIG{INT} = 'IGNORE'; 191 $SIG{TERM} = 'IGNORE'; 192 eval { 193 # some msys2 perl versions don't define SIGUSR1 194 $SIG{USR1} = 'IGNORE'; 195 }; 196 197 $thisrunnerid = $$; 198 print "Runner $thisrunnerid starting\n" if($verbose); 199 200 # Here we are the child (runner). 201 close($thiscontrollerw); 202 close($thiscontrollerr); 203 $runnerr = $thisrunnerr; 204 $runnerw = $thisrunnerw; 205 206 # Set this directory as ours 207 $LOGDIR = $logdir; 208 mkdir("$LOGDIR/$PIDDIR", 0777); 209 mkdir("$LOGDIR/$LOCKDIR", 0777); 210 211 # Initialize various server variables 212 initserverconfig(); 213 214 # handle IPC calls 215 event_loop(); 216 217 # Can't rely on logmsg here in case it's buffered 218 print "Runner $thisrunnerid exiting\n" if($verbose); 219 220 # To reach this point, either the controller has sent 221 # runnerac_stopservers() and runnerac_shutdown() or we have called 222 # runnerabort(). In both cases, there are no more of our servers 223 # running and we can safely exit. 224 exit 0; 225 } 226 227 # Here we are the parent (controller). 228 close($thisrunnerw); 229 close($thisrunnerr); 230 231 $thisrunnerid = $child; 232 233 } else { 234 # Create our pid directory 235 mkdir("$LOGDIR/$PIDDIR", 0777); 236 237 # Don't create a separate process 238 $thisrunnerid = "integrated"; 239 } 240 241 $controllerw{$thisrunnerid} = $thiscontrollerw; 242 $runnerr = $thisrunnerr; 243 $runnerw = $thisrunnerw; 244 $controllerr{$thisrunnerid} = $thiscontrollerr; 245 246 return $thisrunnerid; 247} 248 249####################################################################### 250# Loop to execute incoming IPC calls until the shutdown call 251sub event_loop { 252 while () { 253 if(ipcrecv()) { 254 last; 255 } 256 } 257} 258 259####################################################################### 260# Check for a command in the PATH of the machine running curl. 261# 262sub checktestcmd { 263 my ($cmd)=@_; 264 my @testpaths=("$LIBDIR/.libs", "$LIBDIR"); 265 return checkcmd($cmd, @testpaths); 266} 267 268# See if Valgrind should actually be used 269sub use_valgrind { 270 if($valgrind) { 271 my @valgrindoption = getpart("verify", "valgrind"); 272 if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) { 273 return 1; 274 } 275 } 276 return 0; 277} 278 279# Massage the command result code into a useful form 280sub normalize_cmdres { 281 my $cmdres = $_[0]; 282 my $signal_num = $cmdres & 127; 283 my $dumped_core = $cmdres & 128; 284 285 if(!$anyway && ($signal_num || $dumped_core)) { 286 $cmdres = 1000; 287 } 288 else { 289 $cmdres >>= 8; 290 $cmdres = (2000 + $signal_num) if($signal_num && !$cmdres); 291 } 292 return ($cmdres, $dumped_core); 293} 294 295# 'prepro' processes the input array and replaces %-variables in the array 296# etc. Returns the processed version of the array 297sub prepro { 298 my $testnum = shift; 299 my (@entiretest) = @_; 300 my $show = 1; 301 my @out; 302 my $data_crlf; 303 my @pshow; 304 my @altshow; 305 my $plvl; 306 my $line; 307 for my $s (@entiretest) { 308 my $f = $s; 309 $line++; 310 if($s =~ /^ *%if (.*)/) { 311 my $cond = $1; 312 my $rev = 0; 313 314 if($cond =~ /^!(.*)/) { 315 $cond = $1; 316 $rev = 1; 317 } 318 $rev ^= $feature{$cond} ? 1 : 0; 319 push @pshow, $show; # push the previous state 320 $plvl++; 321 if($show) { 322 # only if this was showing before we can allow the alternative 323 # to go showing as well 324 push @altshow, $rev ^ 1; # push the reversed show state 325 } 326 else { 327 push @altshow, 0; # the alt should still hide 328 } 329 if($show) { 330 # we only allow show if already showing 331 $show = $rev; 332 } 333 next; 334 } 335 elsif($s =~ /^ *%else/) { 336 if(!$plvl) { 337 print STDERR "error: test$testnum:$line: %else no %if\n"; 338 last; 339 } 340 $show = pop @altshow; 341 push @altshow, $show; # put it back for consistency 342 next; 343 } 344 elsif($s =~ /^ *%endif/) { 345 if(!$plvl--) { 346 print STDERR "error: test$testnum:$line: %endif had no %if\n"; 347 last; 348 } 349 $show = pop @pshow; 350 pop @altshow; # not used here but we must pop it 351 next; 352 } 353 if($show) { 354 # The processor does CRLF replacements in the <data*> sections if 355 # necessary since those parts might be read by separate servers. 356 if($s =~ /^ *<data(.*)\>/) { 357 if($1 =~ /crlf="yes"/ || 358 ($feature{"hyper"} && ($keywords{"HTTP"} || $keywords{"HTTPS"}))) { 359 $data_crlf = 1; 360 } 361 } 362 elsif(($s =~ /^ *<\/data/) && $data_crlf) { 363 $data_crlf = 0; 364 } 365 subvariables(\$s, $testnum, "%"); 366 subbase64(\$s); 367 subnewlines(0, \$s) if($data_crlf); 368 push @out, $s; 369 } 370 } 371 return @out; 372} 373 374 375####################################################################### 376# Load test keywords into %keywords hash 377# 378sub readtestkeywords { 379 my @info_keywords = getpart("info", "keywords"); 380 381 # Clear the list of keywords from the last test 382 %keywords = (); 383 for my $k (@info_keywords) { 384 chomp $k; 385 $keywords{$k} = 1; 386 } 387} 388 389 390####################################################################### 391# Return a list of log locks that still exist 392# 393sub logslocked { 394 opendir(my $lockdir, "$LOGDIR/$LOCKDIR"); 395 my @locks; 396 foreach (readdir $lockdir) { 397 if(/^(.*)\.lock$/) { 398 push @locks, $1; 399 } 400 } 401 return @locks; 402} 403 404####################################################################### 405# Memory allocation test and failure torture testing. 406# 407sub torture { 408 my ($testcmd, $testnum, $gdbline) = @_; 409 410 # remove memdump first to be sure we get a new nice and clean one 411 unlink("$LOGDIR/$MEMDUMP"); 412 413 # First get URL from test server, ignore the output/result 414 runclient($testcmd); 415 416 logmsg " CMD: $testcmd\n" if($verbose); 417 418 # memanalyze -v is our friend, get the number of allocations made 419 my $count=0; 420 my @out = `$memanalyze -v "$LOGDIR/$MEMDUMP"`; 421 for(@out) { 422 if(/^Operations: (\d+)/) { 423 $count = $1; 424 last; 425 } 426 } 427 if(!$count) { 428 logmsg " found no functions to make fail\n"; 429 return 0; 430 } 431 432 my @ttests = (1 .. $count); 433 if($shallow && ($shallow < $count)) { 434 my $discard = scalar(@ttests) - $shallow; 435 my $percent = sprintf("%.2f%%", $shallow * 100 / scalar(@ttests)); 436 logmsg " $count functions found, but only fail $shallow ($percent)\n"; 437 while($discard) { 438 my $rm; 439 do { 440 # find a test to discard 441 $rm = rand(scalar(@ttests)); 442 } while(!$ttests[$rm]); 443 $ttests[$rm] = undef; 444 $discard--; 445 } 446 } 447 else { 448 logmsg " $count functions to make fail\n"; 449 } 450 451 for (@ttests) { 452 my $limit = $_; 453 my $fail; 454 my $dumped_core; 455 456 if(!defined($limit)) { 457 # --shallow can undefine them 458 next; 459 } 460 if($tortalloc && ($tortalloc != $limit)) { 461 next; 462 } 463 464 if($verbose) { 465 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = 466 localtime(time()); 467 my $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec); 468 logmsg "Fail function no: $limit at $now\r"; 469 } 470 471 # make the memory allocation function number $limit return failure 472 $ENV{'CURL_MEMLIMIT'} = $limit; 473 474 # remove memdump first to be sure we get a new nice and clean one 475 unlink("$LOGDIR/$MEMDUMP"); 476 477 my $cmd = $testcmd; 478 if($valgrind && !$gdbthis) { 479 my @valgrindoption = getpart("verify", "valgrind"); 480 if((!@valgrindoption) || ($valgrindoption[0] !~ /disable/)) { 481 my $valgrindcmd = "$valgrind "; 482 $valgrindcmd .= "$valgrind_tool " if($valgrind_tool); 483 $valgrindcmd .= "--quiet --leak-check=yes "; 484 $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp "; 485 # $valgrindcmd .= "--gen-suppressions=all "; 486 $valgrindcmd .= "--num-callers=16 "; 487 $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; 488 $cmd = "$valgrindcmd $testcmd"; 489 } 490 } 491 logmsg "*** Function number $limit is now set to fail ***\n" if($gdbthis); 492 493 my $ret = 0; 494 if($gdbthis) { 495 runclient($gdbline); 496 } 497 else { 498 $ret = runclient($cmd); 499 } 500 #logmsg "$_ Returned " . ($ret >> 8) . "\n"; 501 502 # Now clear the variable again 503 delete $ENV{'CURL_MEMLIMIT'} if($ENV{'CURL_MEMLIMIT'}); 504 505 if(-r "core") { 506 # there's core file present now! 507 logmsg " core dumped\n"; 508 $dumped_core = 1; 509 $fail = 2; 510 } 511 512 if($valgrind) { 513 my @e = valgrindparse("$LOGDIR/valgrind$testnum"); 514 if(@e && $e[0]) { 515 if($automakestyle) { 516 logmsg "FAIL: torture $testnum - valgrind\n"; 517 } 518 else { 519 logmsg " valgrind ERROR "; 520 logmsg @e; 521 } 522 $fail = 1; 523 } 524 } 525 526 # verify that it returns a proper error code, doesn't leak memory 527 # and doesn't core dump 528 if(($ret & 255) || ($ret >> 8) >= 128) { 529 logmsg " system() returned $ret\n"; 530 $fail=1; 531 } 532 else { 533 my @memdata=`$memanalyze "$LOGDIR/$MEMDUMP"`; 534 my $leak=0; 535 for(@memdata) { 536 if($_ ne "") { 537 # well it could be other memory problems as well, but 538 # we call it leak for short here 539 $leak=1; 540 } 541 } 542 if($leak) { 543 logmsg "** MEMORY FAILURE\n"; 544 logmsg @memdata; 545 logmsg `$memanalyze -l "$LOGDIR/$MEMDUMP"`; 546 $fail = 1; 547 } 548 } 549 if($fail) { 550 logmsg " $testnum: torture FAILED: function number $limit in test.\n", 551 " invoke with \"-t$limit\" to repeat this single case.\n"; 552 stopservers($verbose); 553 return 1; 554 } 555 } 556 557 logmsg "\n" if($verbose); 558 logmsg "torture OK\n"; 559 return 0; 560} 561 562 563####################################################################### 564# restore environment variables that were modified in test 565sub restore_test_env { 566 my $deleteoldenv = $_[0]; # 1 to delete the saved contents after restore 567 foreach my $var (keys %oldenv) { 568 if($oldenv{$var} eq 'notset') { 569 delete $ENV{$var} if($ENV{$var}); 570 } 571 else { 572 $ENV{$var} = $oldenv{$var}; 573 } 574 if($deleteoldenv) { 575 delete $oldenv{$var}; 576 } 577 } 578} 579 580 581####################################################################### 582# Start the servers needed to run this test case 583sub singletest_startservers { 584 my ($testnum, $testtimings) = @_; 585 586 # remove old test server files before servers are started/verified 587 unlink("$LOGDIR/$SERVERCMD"); 588 unlink("$LOGDIR/$SERVERIN"); 589 unlink("$LOGDIR/$PROXYIN"); 590 591 # timestamp required servers verification start 592 $$testtimings{"timesrvrini"} = Time::HiRes::time(); 593 594 my $why; 595 my $error; 596 if (!$listonly) { 597 my @what = getpart("client", "server"); 598 if(!$what[0]) { 599 warn "Test case $testnum has no server(s) specified"; 600 $why = "no server specified"; 601 $error = -1; 602 } else { 603 my $err; 604 ($why, $err) = serverfortest(@what); 605 if($err == 1) { 606 # Error indicates an actual problem starting the server 607 $error = -2; 608 } else { 609 $error = -1; 610 } 611 } 612 } 613 614 # timestamp required servers verification end 615 $$testtimings{"timesrvrend"} = Time::HiRes::time(); 616 617 return ($why, $error); 618} 619 620 621####################################################################### 622# Generate preprocessed test file 623sub singletest_preprocess { 624 my $testnum = $_[0]; 625 626 # Save a preprocessed version of the entire test file. This allows more 627 # "basic" test case readers to enjoy variable replacements. 628 my @entiretest = fulltest(); 629 my $otest = "$LOGDIR/test$testnum"; 630 631 @entiretest = prepro($testnum, @entiretest); 632 633 # save the new version 634 open(my $fulltesth, ">", "$otest") || die "Failure writing test file"; 635 foreach my $bytes (@entiretest) { 636 print $fulltesth pack('a*', $bytes) or die "Failed to print '$bytes': $!"; 637 } 638 close($fulltesth) || die "Failure writing test file"; 639 640 # in case the process changed the file, reload it 641 loadtest("$LOGDIR/test${testnum}"); 642} 643 644 645####################################################################### 646# Set up the test environment to run this test case 647sub singletest_setenv { 648 my @setenv = getpart("client", "setenv"); 649 foreach my $s (@setenv) { 650 chomp $s; 651 if($s =~ /([^=]*)=(.*)/) { 652 my ($var, $content) = ($1, $2); 653 # remember current setting, to restore it once test runs 654 $oldenv{$var} = ($ENV{$var})?"$ENV{$var}":'notset'; 655 # set new value 656 if(!$content) { 657 delete $ENV{$var} if($ENV{$var}); 658 } 659 else { 660 if($var =~ /^LD_PRELOAD/) { 661 if(exe_ext('TOOL') && (exe_ext('TOOL') eq '.exe')) { 662 logmsg "Skipping LD_PRELOAD due to lack of OS support\n" if($verbose); 663 next; 664 } 665 if($feature{"debug"} || !$has_shared) { 666 logmsg "Skipping LD_PRELOAD due to no release shared build\n" if($verbose); 667 next; 668 } 669 } 670 $ENV{$var} = "$content"; 671 logmsg "setenv $var = $content\n" if($verbose); 672 } 673 } 674 } 675 if($proxy_address) { 676 $ENV{http_proxy} = $proxy_address; 677 $ENV{HTTPS_PROXY} = $proxy_address; 678 } 679} 680 681 682####################################################################### 683# Check that test environment is fine to run this test case 684sub singletest_precheck { 685 my $testnum = $_[0]; 686 my $why; 687 my @precheck = getpart("client", "precheck"); 688 if(@precheck) { 689 my $cmd = $precheck[0]; 690 chomp $cmd; 691 if($cmd) { 692 my @p = split(/ /, $cmd); 693 if($p[0] !~ /\//) { 694 # the first word, the command, does not contain a slash so 695 # we will scan the "improved" PATH to find the command to 696 # be able to run it 697 my $fullp = checktestcmd($p[0]); 698 699 if($fullp) { 700 $p[0] = $fullp; 701 } 702 $cmd = join(" ", @p); 703 } 704 705 my @o = `$cmd 2> $LOGDIR/precheck-$testnum`; 706 if($o[0]) { 707 $why = $o[0]; 708 $why =~ s/[\r\n]//g; 709 } 710 elsif($?) { 711 $why = "precheck command error"; 712 } 713 logmsg "prechecked $cmd\n" if($verbose); 714 } 715 } 716 return $why; 717} 718 719 720####################################################################### 721# Prepare the test environment to run this test case 722sub singletest_prepare { 723 my ($testnum) = @_; 724 725 if($feature{"TrackMemory"}) { 726 unlink("$LOGDIR/$MEMDUMP"); 727 } 728 unlink("core"); 729 730 # remove server output logfiles after servers are started/verified 731 unlink("$LOGDIR/$SERVERIN"); 732 unlink("$LOGDIR/$PROXYIN"); 733 734 # if this section exists, it might be FTP server instructions: 735 my @ftpservercmd = getpart("reply", "servercmd"); 736 push @ftpservercmd, "Testnum $testnum\n"; 737 # write the instructions to file 738 writearray("$LOGDIR/$SERVERCMD", \@ftpservercmd); 739 740 # create (possibly-empty) files before starting the test 741 for my $partsuffix (('', '1', '2', '3', '4')) { 742 my @inputfile=getpart("client", "file".$partsuffix); 743 my %fileattr = getpartattr("client", "file".$partsuffix); 744 my $filename=$fileattr{'name'}; 745 if(@inputfile || $filename) { 746 if(!$filename) { 747 logmsg " $testnum: IGNORED: section client=>file has no name attribute\n"; 748 return -1; 749 } 750 my $fileContent = join('', @inputfile); 751 752 # make directories if needed 753 my $path = $filename; 754 # cut off the file name part 755 $path =~ s/^(.*)\/[^\/]*/$1/; 756 my @ldparts = split(/\//, $LOGDIR); 757 my $nparts = @ldparts; 758 my @parts = split(/\//, $path); 759 if(join("/", @parts[0..$nparts-1]) eq $LOGDIR) { 760 # the file is in $LOGDIR/ 761 my $d = shift @parts; 762 for(@parts) { 763 $d .= "/$_"; 764 mkdir $d; # 0777 765 } 766 } 767 if (open(my $outfile, ">", "$filename")) { 768 binmode $outfile; # for crapage systems, use binary 769 if($fileattr{'nonewline'}) { 770 # cut off the final newline 771 chomp($fileContent); 772 } 773 print $outfile $fileContent; 774 close($outfile); 775 } else { 776 logmsg "ERROR: cannot write $filename\n"; 777 } 778 } 779 } 780 return 0; 781} 782 783 784####################################################################### 785# Run the test command 786sub singletest_run { 787 my ($testnum, $testtimings) = @_; 788 789 # get the command line options to use 790 my ($cmd, @blaha)= getpart("client", "command"); 791 if($cmd) { 792 # make some nice replace operations 793 $cmd =~ s/\n//g; # no newlines please 794 # substitute variables in the command line 795 } 796 else { 797 # there was no command given, use something silly 798 $cmd="-"; 799 } 800 801 my $CURLOUT="$LOGDIR/curl$testnum.out"; # curl output if not stdout 802 803 # if stdout section exists, we verify that the stdout contained this: 804 my $out=""; 805 my %cmdhash = getpartattr("client", "command"); 806 if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-output/)) { 807 #We may slap on --output! 808 if (!partexists("verify", "stdout") || 809 ($cmdhash{'option'} && $cmdhash{'option'} =~ /force-output/)) { 810 $out=" --output $CURLOUT "; 811 } 812 } 813 814 my @codepieces = getpart("client", "tool"); 815 my $tool=""; 816 if(@codepieces) { 817 $tool = $codepieces[0]; 818 chomp $tool; 819 $tool .= exe_ext('TOOL'); 820 } 821 822 my $disablevalgrind; 823 my $CMDLINE=""; 824 my $cmdargs; 825 my $cmdtype = $cmdhash{'type'} || "default"; 826 my $fail_due_event_based = $run_event_based; 827 if($cmdtype eq "perl") { 828 # run the command line prepended with "perl" 829 $cmdargs ="$cmd"; 830 $CMDLINE = "$perl "; 831 $tool=$CMDLINE; 832 $disablevalgrind=1; 833 } 834 elsif($cmdtype eq "shell") { 835 # run the command line prepended with "/bin/sh" 836 $cmdargs ="$cmd"; 837 $CMDLINE = "/bin/sh "; 838 $tool=$CMDLINE; 839 $disablevalgrind=1; 840 } 841 elsif(!$tool && !$keywords{"unittest"}) { 842 # run curl, add suitable command line options 843 my $inc=""; 844 if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-include/)) { 845 $inc = " --include"; 846 } 847 $cmdargs = "$out$inc "; 848 849 if($cmdhash{'option'} && ($cmdhash{'option'} =~ /binary-trace/)) { 850 $cmdargs .= "--trace $LOGDIR/trace$testnum "; 851 } 852 else { 853 $cmdargs .= "--trace-ascii $LOGDIR/trace$testnum "; 854 } 855 $cmdargs .= "--trace-time "; 856 if($run_event_based) { 857 $cmdargs .= "--test-event "; 858 $fail_due_event_based--; 859 } 860 $cmdargs .= $cmd; 861 if ($proxy_address) { 862 $cmdargs .= " --proxy $proxy_address "; 863 } 864 } 865 else { 866 $cmdargs = " $cmd"; # $cmd is the command line for the test file 867 $CURLOUT = stdoutfilename($LOGDIR, $testnum); # sends received data to stdout 868 869 # Default the tool to a unit test with the same name as the test spec 870 if($keywords{"unittest"} && !$tool) { 871 $tool="unit$testnum"; 872 } 873 874 if($tool =~ /^lib/) { 875 $CMDLINE="$LIBDIR/$tool"; 876 } 877 elsif($tool =~ /^unit/) { 878 $CMDLINE="$UNITDIR/$tool"; 879 } 880 881 if(! -f $CMDLINE) { 882 logmsg " $testnum: IGNORED: The tool set in the test case for this: '$tool' does not exist\n"; 883 return (-1, 0, 0, "", "", 0); 884 } 885 $DBGCURL=$CMDLINE; 886 } 887 888 if($fail_due_event_based) { 889 logmsg " $testnum: IGNORED: This test cannot run event based\n"; 890 return (-1, 0, 0, "", "", 0); 891 } 892 893 if($gdbthis) { 894 # gdb is incompatible with valgrind, so disable it when debugging 895 # Perhaps a better approach would be to run it under valgrind anyway 896 # with --db-attach=yes or --vgdb=yes. 897 $disablevalgrind=1; 898 } 899 900 my @stdintest = getpart("client", "stdin"); 901 902 if(@stdintest) { 903 my $stdinfile="$LOGDIR/stdin-for-$testnum"; 904 905 my %hash = getpartattr("client", "stdin"); 906 if($hash{'nonewline'}) { 907 # cut off the final newline from the final line of the stdin data 908 chomp($stdintest[-1]); 909 } 910 911 writearray($stdinfile, \@stdintest); 912 913 $cmdargs .= " <$stdinfile"; 914 } 915 916 if(!$tool) { 917 $CMDLINE=shell_quote($CURL); 918 } 919 920 if(use_valgrind() && !$disablevalgrind) { 921 my $valgrindcmd = "$valgrind "; 922 $valgrindcmd .= "$valgrind_tool " if($valgrind_tool); 923 $valgrindcmd .= "--quiet --leak-check=yes "; 924 $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp "; 925 # $valgrindcmd .= "--gen-suppressions=all "; 926 $valgrindcmd .= "--num-callers=16 "; 927 $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; 928 $CMDLINE = "$valgrindcmd $CMDLINE"; 929 } 930 931 $CMDLINE .= "$cmdargs > " . stdoutfilename($LOGDIR, $testnum) . 932 " 2> " . stderrfilename($LOGDIR, $testnum); 933 934 if($verbose) { 935 logmsg "$CMDLINE\n"; 936 } 937 938 open(my $cmdlog, ">", $CURLLOG) || die "Failure writing log file"; 939 print $cmdlog "$CMDLINE\n"; 940 close($cmdlog) || die "Failure writing log file"; 941 942 my $dumped_core; 943 my $cmdres; 944 945 if($gdbthis) { 946 my $gdbinit = "$TESTDIR/gdbinit$testnum"; 947 open(my $gdbcmd, ">", "$LOGDIR/gdbcmd") || die "Failure writing gdb file"; 948 print $gdbcmd "set args $cmdargs\n"; 949 print $gdbcmd "show args\n"; 950 print $gdbcmd "source $gdbinit\n" if -e $gdbinit; 951 close($gdbcmd) || die "Failure writing gdb file"; 952 } 953 954 # Flush output. 955 $| = 1; 956 957 # timestamp starting of test command 958 $$testtimings{"timetoolini"} = Time::HiRes::time(); 959 960 # run the command line we built 961 if ($torture) { 962 $cmdres = torture($CMDLINE, 963 $testnum, 964 "$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " -x $LOGDIR/gdbcmd"); 965 } 966 elsif($gdbthis) { 967 my $GDBW = ($gdbxwin) ? "-w" : ""; 968 runclient("$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " $GDBW -x $LOGDIR/gdbcmd"); 969 $cmdres=0; # makes it always continue after a debugged run 970 } 971 else { 972 # Convert the raw result code into a more useful one 973 ($cmdres, $dumped_core) = normalize_cmdres(runclient("$CMDLINE")); 974 } 975 976 # timestamp finishing of test command 977 $$testtimings{"timetoolend"} = Time::HiRes::time(); 978 979 return (0, $cmdres, $dumped_core, $CURLOUT, $tool, use_valgrind() && !$disablevalgrind); 980} 981 982 983####################################################################### 984# Clean up after test command 985sub singletest_clean { 986 my ($testnum, $dumped_core, $testtimings)=@_; 987 988 if(!$dumped_core) { 989 if(-r "core") { 990 # there's core file present now! 991 $dumped_core = 1; 992 } 993 } 994 995 if($dumped_core) { 996 logmsg "core dumped\n"; 997 if(0 && $gdb) { 998 logmsg "running gdb for post-mortem analysis:\n"; 999 open(my $gdbcmd, ">", "$LOGDIR/gdbcmd2") || die "Failure writing gdb file"; 1000 print $gdbcmd "bt\n"; 1001 close($gdbcmd) || die "Failure writing gdb file"; 1002 runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch " . shell_quote($DBGCURL) . " core "); 1003 # unlink("$LOGDIR/gdbcmd2"); 1004 } 1005 } 1006 1007 # If a server logs advisor read lock file exists, it is an indication 1008 # that the server has not yet finished writing out all its log files, 1009 # including server request log files used for protocol verification. 1010 # So, if the lock file exists the script waits here a certain amount 1011 # of time until the server removes it, or the given time expires. 1012 my $serverlogslocktimeout = $defserverlogslocktimeout; 1013 my %cmdhash = getpartattr("client", "command"); 1014 if($cmdhash{'timeout'}) { 1015 # test is allowed to override default server logs lock timeout 1016 if($cmdhash{'timeout'} =~ /(\d+)/) { 1017 $serverlogslocktimeout = $1 if($1 >= 0); 1018 } 1019 } 1020 if($serverlogslocktimeout) { 1021 my $lockretry = $serverlogslocktimeout * 20; 1022 my @locks; 1023 while((@locks = logslocked()) && $lockretry--) { 1024 portable_sleep(0.05); 1025 } 1026 if(($lockretry < 0) && 1027 ($serverlogslocktimeout >= $defserverlogslocktimeout)) { 1028 logmsg "Warning: server logs lock timeout ", 1029 "($serverlogslocktimeout seconds) expired (locks: " . 1030 join(", ", @locks) . ")\n"; 1031 } 1032 } 1033 1034 # Test harness ssh server does not have this synchronization mechanism, 1035 # this implies that some ssh server based tests might need a small delay 1036 # once that the client command has run to avoid false test failures. 1037 # 1038 # gnutls-serv also lacks this synchronization mechanism, so gnutls-serv 1039 # based tests might need a small delay once that the client command has 1040 # run to avoid false test failures. 1041 my $postcommanddelay = $defpostcommanddelay; 1042 if($cmdhash{'delay'}) { 1043 # test is allowed to specify a delay after command is executed 1044 if($cmdhash{'delay'} =~ /(\d+)/) { 1045 $postcommanddelay = $1 if($1 > 0); 1046 } 1047 } 1048 1049 portable_sleep($postcommanddelay) if($postcommanddelay); 1050 1051 # timestamp removal of server logs advisor read lock 1052 $$testtimings{"timesrvrlog"} = Time::HiRes::time(); 1053 1054 # test definition might instruct to stop some servers 1055 # stop also all servers relative to the given one 1056 1057 my @killtestservers = getpart("client", "killserver"); 1058 if(@killtestservers) { 1059 foreach my $server (@killtestservers) { 1060 chomp $server; 1061 if(stopserver($server)) { 1062 logmsg " $testnum: killserver FAILED\n"; 1063 return 1; # normal error if asked to fail on unexpected alive 1064 } 1065 } 1066 } 1067 return 0; 1068} 1069 1070####################################################################### 1071# Verify that the postcheck succeeded 1072sub singletest_postcheck { 1073 my ($testnum)=@_; 1074 1075 # run the postcheck command 1076 my @postcheck= getpart("client", "postcheck"); 1077 if(@postcheck) { 1078 my $cmd = join("", @postcheck); 1079 chomp $cmd; 1080 if($cmd) { 1081 logmsg "postcheck $cmd\n" if($verbose); 1082 my $rc = runclient("$cmd"); 1083 # Must run the postcheck command in torture mode in order 1084 # to clean up, but the result can't be relied upon. 1085 if($rc != 0 && !$torture) { 1086 logmsg " $testnum: postcheck FAILED\n"; 1087 return -1; 1088 } 1089 } 1090 } 1091 return 0; 1092} 1093 1094 1095 1096################################################################### 1097# Get ready to run a single test case 1098sub runner_test_preprocess { 1099 my ($testnum)=@_; 1100 my %testtimings; 1101 1102 if(clearlogs()) { 1103 logmsg "Warning: log messages were lost\n"; 1104 } 1105 1106 # timestamp test preparation start 1107 # TODO: this metric now shows only a portion of the prep time; better would 1108 # be to time singletest_preprocess below instead 1109 $testtimings{"timeprepini"} = Time::HiRes::time(); 1110 1111 ################################################################### 1112 # Load test metadata 1113 # ignore any error here--if there were one, it would have been 1114 # caught during the selection phase and this test would not be 1115 # running now 1116 loadtest("${TESTDIR}/test${testnum}"); 1117 readtestkeywords(); 1118 1119 ################################################################### 1120 # Restore environment variables that were modified in a previous run. 1121 # Test definition may instruct to (un)set environment vars. 1122 restore_test_env(1); 1123 1124 ################################################################### 1125 # Start the servers needed to run this test case 1126 my ($why, $error) = singletest_startservers($testnum, \%testtimings); 1127 1128 if(!$why) { 1129 1130 ############################################################### 1131 # Generate preprocessed test file 1132 # This must be done after the servers are started so server 1133 # variables are available for substitution. 1134 singletest_preprocess($testnum); 1135 1136 ############################################################### 1137 # Set up the test environment to run this test case 1138 singletest_setenv(); 1139 1140 ############################################################### 1141 # Check that the test environment is fine to run this test case 1142 if (!$listonly) { 1143 $why = singletest_precheck($testnum); 1144 $error = -1; 1145 } 1146 } 1147 return ($why, $error, clearlogs(), \%testtimings); 1148} 1149 1150 1151################################################################### 1152# Run a single test case with an environment that already been prepared 1153# Returns 0=success, -1=skippable failure, -2=permanent error, 1154# 1=unskippable test failure, as first integer, plus any log messages, 1155# plus more return values when error is 0 1156sub runner_test_run { 1157 my ($testnum)=@_; 1158 1159 if(clearlogs()) { 1160 logmsg "Warning: log messages were lost\n"; 1161 } 1162 1163 ####################################################################### 1164 # Prepare the test environment to run this test case 1165 my $error = singletest_prepare($testnum); 1166 if($error) { 1167 return (-2, clearlogs()); 1168 } 1169 1170 ####################################################################### 1171 # Run the test command 1172 my %testtimings; 1173 my $cmdres; 1174 my $dumped_core; 1175 my $CURLOUT; 1176 my $tool; 1177 my $usedvalgrind; 1178 ($error, $cmdres, $dumped_core, $CURLOUT, $tool, $usedvalgrind) = singletest_run($testnum, \%testtimings); 1179 if($error) { 1180 return (-2, clearlogs(), \%testtimings); 1181 } 1182 1183 ####################################################################### 1184 # Clean up after test command 1185 $error = singletest_clean($testnum, $dumped_core, \%testtimings); 1186 if($error) { 1187 return ($error, clearlogs(), \%testtimings); 1188 } 1189 1190 ####################################################################### 1191 # Verify that the postcheck succeeded 1192 $error = singletest_postcheck($testnum); 1193 if($error) { 1194 return ($error, clearlogs(), \%testtimings); 1195 } 1196 1197 ####################################################################### 1198 # restore environment variables that were modified 1199 restore_test_env(0); 1200 1201 return (0, clearlogs(), \%testtimings, $cmdres, $CURLOUT, $tool, $usedvalgrind); 1202} 1203 1204# Async call runner_clearlocks 1205# Called by controller 1206sub runnerac_clearlocks { 1207 return controlleripccall(\&runner_clearlocks, @_); 1208} 1209 1210# Async call runner_shutdown 1211# This call does NOT generate an IPC response and must be the last IPC call 1212# received. 1213# Called by controller 1214sub runnerac_shutdown { 1215 my ($runnerid)=$_[0]; 1216 my $err = controlleripccall(\&runner_shutdown, @_); 1217 1218 # These have no more use 1219 close($controllerw{$runnerid}); 1220 undef $controllerw{$runnerid}; 1221 close($controllerr{$runnerid}); 1222 undef $controllerr{$runnerid}; 1223 return $err; 1224} 1225 1226# Async call of runner_stopservers 1227# Called by controller 1228sub runnerac_stopservers { 1229 return controlleripccall(\&runner_stopservers, @_); 1230} 1231 1232# Async call of runner_test_preprocess 1233# Called by controller 1234sub runnerac_test_preprocess { 1235 return controlleripccall(\&runner_test_preprocess, @_); 1236} 1237 1238# Async call of runner_test_run 1239# Called by controller 1240sub runnerac_test_run { 1241 return controlleripccall(\&runner_test_run, @_); 1242} 1243 1244################################################################### 1245# Call an arbitrary function via IPC 1246# The first argument is the function reference, the second is the runner ID 1247# Returns 0 on success, -1 on error writing to runner 1248# Called by controller (indirectly, via a more specific function) 1249sub controlleripccall { 1250 my $funcref = shift @_; 1251 my $runnerid = shift @_; 1252 # Get the name of the function from the reference 1253 my $cv = svref_2object($funcref); 1254 my $gv = $cv->GV; 1255 # Prepend the name to the function arguments so it's marshalled along with them 1256 unshift @_, $gv->NAME; 1257 # Marshall the arguments into a flat string 1258 my $margs = freeze \@_; 1259 1260 # Send IPC call via pipe 1261 my $err; 1262 while(! defined ($err = syswrite($controllerw{$runnerid}, (pack "L", length($margs)) . $margs)) || $err <= 0) { 1263 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1264 # Runner has likely died 1265 return -1; 1266 } 1267 # system call was interrupted, probably by ^C; restart it so we stay in sync 1268 } 1269 1270 if(!$multiprocess) { 1271 # Call the remote function here in single process mode 1272 ipcrecv(); 1273 } 1274 return 0; 1275} 1276 1277################################################################### 1278# Receive async response of a previous call via IPC 1279# The first return value is the runner ID or undef on error 1280# Called by controller 1281sub runnerar { 1282 my ($runnerid) = @_; 1283 my $err; 1284 my $datalen; 1285 while(! defined ($err = sysread($controllerr{$runnerid}, $datalen, 4)) || $err <= 0) { 1286 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1287 # Runner is likely dead and closed the pipe 1288 return undef; 1289 } 1290 # system call was interrupted, probably by ^C; restart it so we stay in sync 1291 } 1292 my $len=unpack("L", $datalen); 1293 my $buf; 1294 while(! defined ($err = sysread($controllerr{$runnerid}, $buf, $len)) || $err <= 0) { 1295 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1296 # Runner is likely dead and closed the pipe 1297 return undef; 1298 } 1299 # system call was interrupted, probably by ^C; restart it so we stay in sync 1300 } 1301 1302 # Decode response values 1303 my $resarrayref = thaw $buf; 1304 1305 # First argument is runner ID 1306 # TODO: remove this; it's unneeded since it's passed in 1307 unshift @$resarrayref, $runnerid; 1308 return @$resarrayref; 1309} 1310 1311################################################################### 1312# Returns runner ID if a response from an async call is ready or error 1313# First value is ready, second is error, however an error case shows up 1314# as ready in Linux, so you can't trust it. 1315# argument is 0 for nonblocking, undef for blocking, anything else for timeout 1316# Called by controller 1317sub runnerar_ready { 1318 my ($blocking) = @_; 1319 my $rin = ""; 1320 my %idbyfileno; 1321 my $maxfileno=0; 1322 foreach my $p (keys(%controllerr)) { 1323 my $fd = fileno($controllerr{$p}); 1324 vec($rin, $fd, 1) = 1; 1325 $idbyfileno{$fd} = $p; # save the runner ID for each pipe fd 1326 if($fd > $maxfileno) { 1327 $maxfileno = $fd; 1328 } 1329 } 1330 $maxfileno || die "Internal error: no runners are available to wait on\n"; 1331 1332 # Wait for any pipe from any runner to be ready 1333 # This may be interrupted and return EINTR, but this is ignored and the 1334 # caller will need to later call this function again. 1335 # TODO: this is relatively slow with hundreds of fds 1336 my $ein = $rin; 1337 if(select(my $rout=$rin, undef, my $eout=$ein, $blocking) >= 1) { 1338 for my $fd (0..$maxfileno) { 1339 # Return an error condition first in case it's both 1340 if(vec($eout, $fd, 1)) { 1341 return (undef, $idbyfileno{$fd}); 1342 } 1343 if(vec($rout, $fd, 1)) { 1344 return ($idbyfileno{$fd}, undef); 1345 } 1346 } 1347 die "Internal pipe readiness inconsistency\n"; 1348 } 1349 return (undef, undef); 1350} 1351 1352 1353################################################################### 1354# Cleanly abort and exit the runner 1355# This uses print since there is no longer any controller to write logs. 1356sub runnerabort{ 1357 print "Controller is gone: runner $$ for $LOGDIR exiting\n"; 1358 my ($error, $logs) = runner_stopservers(); 1359 print $logs; 1360 runner_shutdown(); 1361} 1362 1363################################################################### 1364# Receive an IPC call in the runner and execute it 1365# The IPC is read from the $runnerr pipe and the response is 1366# written to the $runnerw pipe 1367# Returns 0 if more IPC calls are expected or 1 if the runner should exit 1368sub ipcrecv { 1369 my $err; 1370 my $datalen; 1371 while(! defined ($err = sysread($runnerr, $datalen, 4)) || $err <= 0) { 1372 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1373 # pipe has closed; controller is gone and we must exit 1374 runnerabort(); 1375 # Special case: no response will be forthcoming 1376 return 1; 1377 } 1378 # system call was interrupted, probably by ^C; restart it so we stay in sync 1379 } 1380 my $len=unpack("L", $datalen); 1381 my $buf; 1382 while(! defined ($err = sysread($runnerr, $buf, $len)) || $err <= 0) { 1383 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1384 # pipe has closed; controller is gone and we must exit 1385 runnerabort(); 1386 # Special case: no response will be forthcoming 1387 return 1; 1388 } 1389 # system call was interrupted, probably by ^C; restart it so we stay in sync 1390 } 1391 1392 # Decode the function name and arguments 1393 my $argsarrayref = thaw $buf; 1394 1395 # The name of the function to call is the first argument 1396 my $funcname = shift @$argsarrayref; 1397 1398 # print "ipcrecv $funcname\n"; 1399 # Synchronously call the desired function 1400 my @res; 1401 if($funcname eq "runner_clearlocks") { 1402 @res = runner_clearlocks(@$argsarrayref); 1403 } 1404 elsif($funcname eq "runner_shutdown") { 1405 runner_shutdown(@$argsarrayref); 1406 # Special case: no response will be forthcoming 1407 return 1; 1408 } 1409 elsif($funcname eq "runner_stopservers") { 1410 @res = runner_stopservers(@$argsarrayref); 1411 } 1412 elsif($funcname eq "runner_test_preprocess") { 1413 @res = runner_test_preprocess(@$argsarrayref); 1414 } 1415 elsif($funcname eq "runner_test_run") { 1416 @res = runner_test_run(@$argsarrayref); 1417 } else { 1418 die "Unknown IPC function $funcname\n"; 1419 } 1420 # print "ipcrecv results\n"; 1421 1422 # Marshall the results to return 1423 $buf = freeze \@res; 1424 1425 while(! defined ($err = syswrite($runnerw, (pack "L", length($buf)) . $buf)) || $err <= 0) { 1426 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1427 # pipe has closed; controller is gone and we must exit 1428 runnerabort(); 1429 # Special case: no response will be forthcoming 1430 return 1; 1431 } 1432 # system call was interrupted, probably by ^C; restart it so we stay in sync 1433 } 1434 1435 return 0; 1436} 1437 1438################################################################### 1439# Kill the server processes that still have lock files in a directory 1440sub runner_clearlocks { 1441 my ($lockdir)=@_; 1442 if(clearlogs()) { 1443 logmsg "Warning: log messages were lost\n"; 1444 } 1445 clearlocks($lockdir); 1446 return clearlogs(); 1447} 1448 1449 1450################################################################### 1451# Kill all server processes 1452sub runner_stopservers { 1453 my $error = stopservers($verbose); 1454 my $logs = clearlogs(); 1455 return ($error, $logs); 1456} 1457 1458################################################################### 1459# Shut down this runner 1460sub runner_shutdown { 1461 close($runnerr); 1462 undef $runnerr; 1463 close($runnerw); 1464 undef $runnerw; 1465} 1466 1467 14681; 1469