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