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