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 ($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 if($run_duphandle) { 898 $cmdargs .= "--test-duphandle "; 899 my @dis = getpart("client", "disable"); 900 if(@dis) { 901 chomp $dis[0] if($dis[0]); 902 if($dis[0] eq "test-duphandle") { 903 # marked to not run with duphandle 904 logmsg " $testnum: IGNORED: Can't run test-duphandle\n"; 905 return (-1, 0, 0, "", "", 0); 906 } 907 } 908 } 909 $cmdargs .= $cmd; 910 if ($proxy_address) { 911 $cmdargs .= " --proxy $proxy_address "; 912 } 913 } 914 else { 915 $cmdargs = " $cmd"; # $cmd is the command line for the test file 916 $CURLOUT = stdoutfilename($LOGDIR, $testnum); # sends received data to stdout 917 918 # Default the tool to a unit test with the same name as the test spec 919 if($keywords{"unittest"} && !$tool) { 920 $tool_name="unit$testnum"; 921 $tool = $tool_name; 922 } 923 924 if($tool =~ /^lib/) { 925 if($bundle) { 926 $CMDLINE="$LIBDIR/libtests"; 927 } 928 else { 929 $CMDLINE="$LIBDIR/$tool"; 930 } 931 } 932 elsif($tool =~ /^unit/) { 933 if($bundle) { 934 $CMDLINE="$UNITDIR/units"; 935 } 936 else { 937 $CMDLINE="$UNITDIR/$tool"; 938 } 939 } 940 941 if(! -f $CMDLINE) { 942 logmsg " $testnum: IGNORED: The tool set in the test case for this: '$tool' does not exist\n"; 943 return (-1, 0, 0, "", "", 0); 944 } 945 946 if($bundle) { 947 $CMDLINE.=" $tool_name"; 948 } 949 950 $DBGCURL=$CMDLINE; 951 } 952 953 if($fail_due_event_based) { 954 logmsg " $testnum: IGNORED: This test cannot run event based\n"; 955 return (-1, 0, 0, "", "", 0); 956 } 957 958 if($gdbthis) { 959 # gdb is incompatible with valgrind, so disable it when debugging 960 # Perhaps a better approach would be to run it under valgrind anyway 961 # with --db-attach=yes or --vgdb=yes. 962 $disablevalgrind=1; 963 } 964 965 my @stdintest = getpart("client", "stdin"); 966 967 if(@stdintest) { 968 my $stdinfile="$LOGDIR/stdin-for-$testnum"; 969 970 my %hash = getpartattr("client", "stdin"); 971 if($hash{'nonewline'}) { 972 # cut off the final newline from the final line of the stdin data 973 chomp($stdintest[-1]); 974 } 975 976 writearray($stdinfile, \@stdintest); 977 978 $cmdargs .= " <$stdinfile"; 979 } 980 981 if(!$tool) { 982 $CMDLINE=shell_quote($CURL); 983 if((!$cmdhash{'option'}) || ($cmdhash{'option'} !~ /no-q/)) { 984 $CMDLINE .= " -q"; 985 } 986 } 987 988 if(use_valgrind() && !$disablevalgrind) { 989 my $valgrindcmd = "$valgrind "; 990 $valgrindcmd .= "$valgrind_tool " if($valgrind_tool); 991 $valgrindcmd .= "--quiet --leak-check=yes "; 992 $valgrindcmd .= "--suppressions=$srcdir/valgrind.supp "; 993 # $valgrindcmd .= "--gen-suppressions=all "; 994 $valgrindcmd .= "--num-callers=16 "; 995 $valgrindcmd .= "${valgrind_logfile}=$LOGDIR/valgrind$testnum"; 996 $CMDLINE = "$valgrindcmd $CMDLINE"; 997 } 998 999 $CMDLINE .= "$cmdargs > " . stdoutfilename($LOGDIR, $testnum) . 1000 " 2> " . stderrfilename($LOGDIR, $testnum); 1001 1002 if($verbose) { 1003 logmsg "$CMDLINE\n"; 1004 } 1005 1006 open(my $cmdlog, ">", $CURLLOG) || die "Failure writing log file"; 1007 print $cmdlog "$CMDLINE\n"; 1008 close($cmdlog) || die "Failure writing log file"; 1009 1010 my $dumped_core; 1011 my $cmdres; 1012 1013 if($gdbthis) { 1014 my $gdbinit = "$TESTDIR/gdbinit$testnum"; 1015 open(my $gdbcmd, ">", "$LOGDIR/gdbcmd") || die "Failure writing gdb file"; 1016 if($gdbthis == 1) { 1017 # gdb mode 1018 print $gdbcmd "set args $cmdargs\n"; 1019 print $gdbcmd "show args\n"; 1020 print $gdbcmd "source $gdbinit\n" if -e $gdbinit; 1021 } 1022 else { 1023 # lldb mode 1024 print $gdbcmd "set args $cmdargs\n"; 1025 } 1026 close($gdbcmd) || die "Failure writing gdb file"; 1027 } 1028 1029 # Flush output. 1030 $| = 1; 1031 1032 # timestamp starting of test command 1033 $$testtimings{"timetoolini"} = Time::HiRes::time(); 1034 1035 # run the command line we built 1036 if ($torture) { 1037 $cmdres = torture($CMDLINE, 1038 $testnum, 1039 "$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " -x $LOGDIR/gdbcmd"); 1040 } 1041 elsif($gdbthis == 1) { 1042 # gdb 1043 my $GDBW = ($gdbxwin) ? "-w" : ""; 1044 runclient("$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " $GDBW -x $LOGDIR/gdbcmd"); 1045 $cmdres=0; # makes it always continue after a debugged run 1046 } 1047 elsif($gdbthis == 2) { 1048 # $gdb is "lldb" 1049 print "runs lldb -- $CURL $cmdargs\n"; 1050 runclient("lldb -- $CURL $cmdargs"); 1051 $cmdres=0; # makes it always continue after a debugged run 1052 } 1053 else { 1054 # Convert the raw result code into a more useful one 1055 ($cmdres, $dumped_core) = normalize_cmdres(runclient("$CMDLINE")); 1056 } 1057 1058 # timestamp finishing of test command 1059 $$testtimings{"timetoolend"} = Time::HiRes::time(); 1060 1061 return (0, $cmdres, $dumped_core, $CURLOUT, $tool, use_valgrind() && !$disablevalgrind); 1062} 1063 1064 1065####################################################################### 1066# Clean up after test command 1067sub singletest_clean { 1068 my ($testnum, $dumped_core, $testtimings)=@_; 1069 1070 if(!$dumped_core) { 1071 if(-r "core") { 1072 # there's core file present now! 1073 $dumped_core = 1; 1074 } 1075 } 1076 1077 if($dumped_core) { 1078 logmsg "core dumped\n"; 1079 if(0 && $gdb) { 1080 logmsg "running gdb for post-mortem analysis:\n"; 1081 open(my $gdbcmd, ">", "$LOGDIR/gdbcmd2") || die "Failure writing gdb file"; 1082 print $gdbcmd "bt\n"; 1083 close($gdbcmd) || die "Failure writing gdb file"; 1084 runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch " . shell_quote($DBGCURL) . " core "); 1085 # unlink("$LOGDIR/gdbcmd2"); 1086 } 1087 } 1088 1089 my $serverlogslocktimeout = $defserverlogslocktimeout; 1090 my %cmdhash = getpartattr("client", "command"); 1091 if($cmdhash{'timeout'}) { 1092 # test is allowed to override default server logs lock timeout 1093 if($cmdhash{'timeout'} =~ /(\d+)/) { 1094 $serverlogslocktimeout = $1 if($1 >= 0); 1095 } 1096 } 1097 1098 # Test harness ssh server does not have this synchronization mechanism, 1099 # this implies that some ssh server based tests might need a small delay 1100 # once that the client command has run to avoid false test failures. 1101 # 1102 # gnutls-serv also lacks this synchronization mechanism, so gnutls-serv 1103 # based tests might need a small delay once that the client command has 1104 # run to avoid false test failures. 1105 my $postcommanddelay = $defpostcommanddelay; 1106 if($cmdhash{'delay'}) { 1107 # test is allowed to specify a delay after command is executed 1108 if($cmdhash{'delay'} =~ /(\d+)/) { 1109 $postcommanddelay = $1 if($1 > 0); 1110 } 1111 } 1112 1113 portable_sleep($postcommanddelay) if($postcommanddelay); 1114 1115 my @killtestservers = getpart("client", "killserver"); 1116 if(@killtestservers) { 1117 foreach my $server (@killtestservers) { 1118 chomp $server; 1119 if(stopserver($server)) { 1120 logmsg " $testnum: killserver FAILED\n"; 1121 return 1; # normal error if asked to fail on unexpected alive 1122 } 1123 } 1124 } 1125 1126 # wait for any servers left running to release their locks 1127 waitlockunlock($serverlogslocktimeout); 1128 1129 # timestamp removal of server logs advisor read lock 1130 $$testtimings{"timesrvrlog"} = Time::HiRes::time(); 1131 1132 # test definition might instruct to stop some servers 1133 # stop also all servers relative to the given one 1134 1135 return 0; 1136} 1137 1138####################################################################### 1139# Verify that the postcheck succeeded 1140sub singletest_postcheck { 1141 my ($testnum)=@_; 1142 1143 # run the postcheck command 1144 my @postcheck= getpart("client", "postcheck"); 1145 if(@postcheck) { 1146 die "test$testnum uses client/postcheck"; 1147 } 1148 1149 @postcheck= getpart("verify", "postcheck"); 1150 if(@postcheck) { 1151 my $cmd = join("", @postcheck); 1152 chomp $cmd; 1153 if($cmd) { 1154 logmsg "postcheck $cmd\n" if($verbose); 1155 my $rc = runclient("$cmd"); 1156 # Must run the postcheck command in torture mode in order 1157 # to clean up, but the result can't be relied upon. 1158 if($rc != 0 && !$torture) { 1159 logmsg " $testnum: postcheck FAILED\n"; 1160 return -1; 1161 } 1162 } 1163 } 1164 return 0; 1165} 1166 1167 1168 1169################################################################### 1170# Get ready to run a single test case 1171sub runner_test_preprocess { 1172 my ($testnum)=@_; 1173 my %testtimings; 1174 1175 if(clearlogs()) { 1176 logmsg "Warning: log messages were lost\n"; 1177 } 1178 1179 # timestamp test preparation start 1180 # TODO: this metric now shows only a portion of the prep time; better would 1181 # be to time singletest_preprocess below instead 1182 $testtimings{"timeprepini"} = Time::HiRes::time(); 1183 1184 ################################################################### 1185 # Load test metadata 1186 # ignore any error here--if there were one, it would have been 1187 # caught during the selection phase and this test would not be 1188 # running now 1189 loadtest("${TESTDIR}/test${testnum}"); 1190 readtestkeywords(); 1191 1192 ################################################################### 1193 # Restore environment variables that were modified in a previous run. 1194 # Test definition may instruct to (un)set environment vars. 1195 restore_test_env(1); 1196 1197 ################################################################### 1198 # Start the servers needed to run this test case 1199 my ($why, $error) = singletest_startservers($testnum, \%testtimings); 1200 1201 # make sure no locks left for responsive test 1202 waitlockunlock($defserverlogslocktimeout); 1203 1204 if(!$why) { 1205 1206 ############################################################### 1207 # Generate preprocessed test file 1208 # This must be done after the servers are started so server 1209 # variables are available for substitution. 1210 singletest_preprocess($testnum); 1211 1212 ############################################################### 1213 # Set up the test environment to run this test case 1214 singletest_setenv(); 1215 1216 ############################################################### 1217 # Check that the test environment is fine to run this test case 1218 if (!$listonly) { 1219 $why = singletest_precheck($testnum); 1220 $error = -1; 1221 } 1222 } 1223 return ($why, $error, clearlogs(), \%testtimings); 1224} 1225 1226 1227################################################################### 1228# Run a single test case with an environment that already been prepared 1229# Returns 0=success, -1=skippable failure, -2=permanent error, 1230# 1=unskippable test failure, as first integer, plus any log messages, 1231# plus more return values when error is 0 1232sub runner_test_run { 1233 my ($testnum)=@_; 1234 1235 if(clearlogs()) { 1236 logmsg "Warning: log messages were lost\n"; 1237 } 1238 1239 ####################################################################### 1240 # Prepare the test environment to run this test case 1241 my $error = singletest_prepare($testnum); 1242 if($error) { 1243 return (-2, clearlogs()); 1244 } 1245 1246 ####################################################################### 1247 # Run the test command 1248 my %testtimings; 1249 my $cmdres; 1250 my $dumped_core; 1251 my $CURLOUT; 1252 my $tool; 1253 my $usedvalgrind; 1254 ($error, $cmdres, $dumped_core, $CURLOUT, $tool, $usedvalgrind) = singletest_run($testnum, \%testtimings); 1255 if($error) { 1256 return (-2, clearlogs(), \%testtimings); 1257 } 1258 1259 ####################################################################### 1260 # Clean up after test command 1261 $error = singletest_clean($testnum, $dumped_core, \%testtimings); 1262 if($error) { 1263 return ($error, clearlogs(), \%testtimings); 1264 } 1265 1266 ####################################################################### 1267 # Verify that the postcheck succeeded 1268 $error = singletest_postcheck($testnum); 1269 if($error) { 1270 return ($error, clearlogs(), \%testtimings); 1271 } 1272 1273 ####################################################################### 1274 # restore environment variables that were modified 1275 restore_test_env(0); 1276 1277 return (0, clearlogs(), \%testtimings, $cmdres, $CURLOUT, $tool, $usedvalgrind); 1278} 1279 1280# Async call runner_clearlocks 1281# Called by controller 1282sub runnerac_clearlocks { 1283 return controlleripccall(\&runner_clearlocks, @_); 1284} 1285 1286# Async call runner_shutdown 1287# This call does NOT generate an IPC response and must be the last IPC call 1288# received. 1289# Called by controller 1290sub runnerac_shutdown { 1291 my ($runnerid)=$_[0]; 1292 my $err = controlleripccall(\&runner_shutdown, @_); 1293 1294 # These have no more use 1295 close($controllerw{$runnerid}); 1296 undef $controllerw{$runnerid}; 1297 close($controllerr{$runnerid}); 1298 undef $controllerr{$runnerid}; 1299 return $err; 1300} 1301 1302# Async call of runner_stopservers 1303# Called by controller 1304sub runnerac_stopservers { 1305 return controlleripccall(\&runner_stopservers, @_); 1306} 1307 1308# Async call of runner_test_preprocess 1309# Called by controller 1310sub runnerac_test_preprocess { 1311 return controlleripccall(\&runner_test_preprocess, @_); 1312} 1313 1314# Async call of runner_test_run 1315# Called by controller 1316sub runnerac_test_run { 1317 return controlleripccall(\&runner_test_run, @_); 1318} 1319 1320################################################################### 1321# Call an arbitrary function via IPC 1322# The first argument is the function reference, the second is the runner ID 1323# Returns 0 on success, -1 on error writing to runner 1324# Called by controller (indirectly, via a more specific function) 1325sub controlleripccall { 1326 my $funcref = shift @_; 1327 my $runnerid = shift @_; 1328 # Get the name of the function from the reference 1329 my $cv = svref_2object($funcref); 1330 my $gv = $cv->GV; 1331 # Prepend the name to the function arguments so it's marshalled along with them 1332 unshift @_, $gv->NAME; 1333 # Marshall the arguments into a flat string 1334 my $margs = freeze \@_; 1335 1336 # Send IPC call via pipe 1337 my $err; 1338 while(! defined ($err = syswrite($controllerw{$runnerid}, (pack "L", length($margs)) . $margs)) || $err <= 0) { 1339 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1340 # Runner has likely died 1341 return -1; 1342 } 1343 # system call was interrupted, probably by ^C; restart it so we stay in sync 1344 } 1345 1346 if(!$multiprocess) { 1347 # Call the remote function here in single process mode 1348 ipcrecv(); 1349 } 1350 return 0; 1351} 1352 1353################################################################### 1354# Receive async response of a previous call via IPC 1355# The first return value is the runner ID or undef on error 1356# Called by controller 1357sub runnerar { 1358 my ($runnerid) = @_; 1359 my $err; 1360 my $datalen; 1361 while(! defined ($err = sysread($controllerr{$runnerid}, $datalen, 4)) || $err <= 0) { 1362 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1363 # Runner is likely dead and closed the pipe 1364 return undef; 1365 } 1366 # system call was interrupted, probably by ^C; restart it so we stay in sync 1367 } 1368 my $len=unpack("L", $datalen); 1369 my $buf; 1370 while(! defined ($err = sysread($controllerr{$runnerid}, $buf, $len)) || $err <= 0) { 1371 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1372 # Runner is likely dead and closed the pipe 1373 return undef; 1374 } 1375 # system call was interrupted, probably by ^C; restart it so we stay in sync 1376 } 1377 1378 # Decode response values 1379 my $resarrayref = thaw $buf; 1380 1381 # First argument is runner ID 1382 # TODO: remove this; it's unneeded since it's passed in 1383 unshift @$resarrayref, $runnerid; 1384 return @$resarrayref; 1385} 1386 1387################################################################### 1388# Returns runner ID if a response from an async call is ready or error 1389# First value is ready, second is error, however an error case shows up 1390# as ready in Linux, so you can't trust it. 1391# argument is 0 for nonblocking, undef for blocking, anything else for timeout 1392# Called by controller 1393sub runnerar_ready { 1394 my ($blocking) = @_; 1395 my $rin = ""; 1396 my %idbyfileno; 1397 my $maxfileno=0; 1398 my @ready_runners = (); 1399 foreach my $p (keys(%controllerr)) { 1400 my $fd = fileno($controllerr{$p}); 1401 vec($rin, $fd, 1) = 1; 1402 $idbyfileno{$fd} = $p; # save the runner ID for each pipe fd 1403 if($fd > $maxfileno) { 1404 $maxfileno = $fd; 1405 } 1406 } 1407 $maxfileno || die "Internal error: no runners are available to wait on\n"; 1408 1409 # Wait for any pipe from any runner to be ready 1410 # This may be interrupted and return EINTR, but this is ignored and the 1411 # caller will need to later call this function again. 1412 # TODO: this is relatively slow with hundreds of fds 1413 my $ein = $rin; 1414 if(select(my $rout=$rin, undef, my $eout=$ein, $blocking) >= 1) { 1415 for my $fd (0..$maxfileno) { 1416 # Return an error condition first in case it's both 1417 if(vec($eout, $fd, 1)) { 1418 return (undef, $idbyfileno{$fd}); 1419 } 1420 if(vec($rout, $fd, 1)) { 1421 push(@ready_runners, $idbyfileno{$fd}); 1422 } 1423 } 1424 die "Internal pipe readiness inconsistency\n" if(!@ready_runners); 1425 return (@ready_runners, undef); 1426 } 1427 return (undef, undef); 1428} 1429 1430 1431################################################################### 1432# Cleanly abort and exit the runner 1433# This uses print since there is no longer any controller to write logs. 1434sub runnerabort{ 1435 print "Controller is gone: runner $$ for $LOGDIR exiting\n"; 1436 my ($error, $logs) = runner_stopservers(); 1437 print $logs; 1438 runner_shutdown(); 1439} 1440 1441################################################################### 1442# Receive an IPC call in the runner and execute it 1443# The IPC is read from the $runnerr pipe and the response is 1444# written to the $runnerw pipe 1445# Returns 0 if more IPC calls are expected or 1 if the runner should exit 1446sub ipcrecv { 1447 my $err; 1448 my $datalen; 1449 while(! defined ($err = sysread($runnerr, $datalen, 4)) || $err <= 0) { 1450 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1451 # pipe has closed; controller is gone and we must exit 1452 runnerabort(); 1453 # Special case: no response will be forthcoming 1454 return 1; 1455 } 1456 # system call was interrupted, probably by ^C; restart it so we stay in sync 1457 } 1458 my $len=unpack("L", $datalen); 1459 my $buf; 1460 while(! defined ($err = sysread($runnerr, $buf, $len)) || $err <= 0) { 1461 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1462 # pipe has closed; controller is gone and we must exit 1463 runnerabort(); 1464 # Special case: no response will be forthcoming 1465 return 1; 1466 } 1467 # system call was interrupted, probably by ^C; restart it so we stay in sync 1468 } 1469 1470 # Decode the function name and arguments 1471 my $argsarrayref = thaw $buf; 1472 1473 # The name of the function to call is the first argument 1474 my $funcname = shift @$argsarrayref; 1475 1476 # print "ipcrecv $funcname\n"; 1477 # Synchronously call the desired function 1478 my @res; 1479 if($funcname eq "runner_clearlocks") { 1480 @res = runner_clearlocks(@$argsarrayref); 1481 } 1482 elsif($funcname eq "runner_shutdown") { 1483 runner_shutdown(@$argsarrayref); 1484 # Special case: no response will be forthcoming 1485 return 1; 1486 } 1487 elsif($funcname eq "runner_stopservers") { 1488 @res = runner_stopservers(@$argsarrayref); 1489 } 1490 elsif($funcname eq "runner_test_preprocess") { 1491 @res = runner_test_preprocess(@$argsarrayref); 1492 } 1493 elsif($funcname eq "runner_test_run") { 1494 @res = runner_test_run(@$argsarrayref); 1495 } else { 1496 die "Unknown IPC function $funcname\n"; 1497 } 1498 # print "ipcrecv results\n"; 1499 1500 # Marshall the results to return 1501 $buf = freeze \@res; 1502 1503 while(! defined ($err = syswrite($runnerw, (pack "L", length($buf)) . $buf)) || $err <= 0) { 1504 if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) { 1505 # pipe has closed; controller is gone and we must exit 1506 runnerabort(); 1507 # Special case: no response will be forthcoming 1508 return 1; 1509 } 1510 # system call was interrupted, probably by ^C; restart it so we stay in sync 1511 } 1512 1513 return 0; 1514} 1515 1516################################################################### 1517# Kill the server processes that still have lock files in a directory 1518sub runner_clearlocks { 1519 my ($lockdir)=@_; 1520 if(clearlogs()) { 1521 logmsg "Warning: log messages were lost\n"; 1522 } 1523 clearlocks($lockdir); 1524 return clearlogs(); 1525} 1526 1527 1528################################################################### 1529# Kill all server processes 1530sub runner_stopservers { 1531 my $error = stopservers($verbose); 1532 my $logs = clearlogs(); 1533 return ($error, $logs); 1534} 1535 1536################################################################### 1537# Shut down this runner 1538sub runner_shutdown { 1539 close($runnerr); 1540 undef $runnerr; 1541 close($runnerw); 1542 undef $runnerw; 1543} 1544 1545 15461; 1547
