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