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