tests/runner.pm

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