1#***************************************************************************
2#                                  _   _ ____  _
3#  Project                     ___| | | |  _ \| |
4#                             / __| | | | |_) | |
5#                            | (__| |_| |  _ <| |___
6#                             \___|\___/|_| \_\_____|
7#
8# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
9#
10# This software is licensed as described in the file COPYING, which
11# you should have received as part of this distribution. The terms
12# are also available at https://curl.se/docs/copyright.html.
13#
14# You may opt to use, copy, modify, merge, publish, distribute and/or sell
15# copies of the Software, and permit persons to whom the Software is
16# furnished to do so, under the terms of the COPYING file.
17#
18# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
19# KIND, either express or implied.
20#
21# SPDX-License-Identifier: curl
22#
23###########################################################################
24
25# This module contains entry points to run a single test. runner_init
26# determines whether they will run in a separate process or in the process of
27# the caller. The relevant interface is asynchronous so it will work in either
28# case. Program arguments are marshalled and then written to the end of a pipe
29# (in controlleripccall) which is later read from and the arguments
30# unmarshalled (in ipcrecv) before the desired function is called normally.
31# The function return values are then marshalled and written into another pipe
32# (again in ipcrecv) when is later read from and unmarshalled (in runnerar)
33# before being returned to the caller.
34
35package runner;
36
37use strict;
38use warnings;
39use 5.006;
40
41BEGIN {
42    use base qw(Exporter);
43
44    our @EXPORT = qw(
45        checktestcmd
46        prepro
47        readtestkeywords
48        restore_test_env
49        runner_init
50        runnerac_clearlocks
51        runnerac_shutdown
52        runnerac_stopservers
53        runnerac_test_preprocess
54        runnerac_test_run
55        runnerar
56        runnerar_ready
57        stderrfilename
58        stdoutfilename
59        $DBGCURL
60        $gdb
61        $gdbthis
62        $gdbxwin
63        $shallow
64        $tortalloc
65        $valgrind_logfile
66        $valgrind_tool
67    );
68
69    # these are for debugging only
70    our @EXPORT_OK = qw(
71        singletest_preprocess
72    );
73}
74
75use B qw(
76    svref_2object
77    );
78use Storable qw(
79    freeze
80    thaw
81    );
82
83use pathhelp qw(
84    exe_ext
85    );
86use processhelp qw(
87    portable_sleep
88    );
89use servers qw(
90    checkcmd
91    clearlocks
92    initserverconfig
93    serverfortest
94    stopserver
95    stopservers
96    subvariables
97    );
98use getpart;
99use globalconfig;
100use testutil qw(
101    clearlogs
102    logmsg
103    runclient
104    shell_quote
105    subbase64
106    subnewlines
107    );
108use 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
114our $DBGCURL=$CURL; #"../src/.libs/curl";  # alternative for debugging
115our $valgrind_logfile="--log-file";  # the option name for valgrind >=3
116our $valgrind_tool="--tool=memcheck";
117our $gdb = checktestcmd("gdb");
118our $gdbthis = 0;  # run test case with debugger (gdb or lldb)
119our $gdbxwin;      # use windowed gdb when using gdb
120
121# torture test variables
122our $shallow;
123our $tortalloc;
124
125# local variables
126my %oldenv;       # environment variables before test is started
127my $UNITDIR="./unit";
128my $CURLLOG="$LOGDIR/commands.log"; # all command lines run
129my $defserverlogslocktimeout = 5; # timeout to await server logs lock removal
130my $defpostcommanddelay = 0; # delay between command and postcheck sections
131my $multiprocess;   # nonzero with a separate test runner process
132
133# pipes
134my $runnerr;        # pipe that runner reads from
135my $runnerw;        # pipe that runner writes to
136
137# per-runner variables, indexed by runner ID; these are used by controller only
138my %controllerr;    # pipe that controller reads from
139my %controllerw;    # pipe that controller writes to
140
141# redirected stdout/stderr to these files
142sub stdoutfilename {
143    my ($logdir, $testnum)=@_;
144    return "$logdir/stdout$testnum";
145}
146
147sub 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
157sub 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
251sub 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#
262sub 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
269sub 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
280sub 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
297sub 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#
378sub 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#
393sub 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#
407sub 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
565sub 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
583sub 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
623sub 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
647sub 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
684sub 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
722sub 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
786sub 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        if($gdbthis == 1) {
949            # gdb mode
950            print $gdbcmd "set args $cmdargs\n";
951            print $gdbcmd "show args\n";
952            print $gdbcmd "source $gdbinit\n" if -e $gdbinit;
953        }
954        else {
955            # lldb mode
956            print $gdbcmd "set args $cmdargs\n";
957        }
958        close($gdbcmd) || die "Failure writing gdb file";
959    }
960
961    # Flush output.
962    $| = 1;
963
964    # timestamp starting of test command
965    $$testtimings{"timetoolini"} = Time::HiRes::time();
966
967    # run the command line we built
968    if ($torture) {
969        $cmdres = torture($CMDLINE,
970                          $testnum,
971                          "$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " -x $LOGDIR/gdbcmd");
972    }
973    elsif($gdbthis == 1) {
974        # gdb
975        my $GDBW = ($gdbxwin) ? "-w" : "";
976        runclient("$gdb --directory $LIBDIR " . shell_quote($DBGCURL) . " $GDBW -x $LOGDIR/gdbcmd");
977        $cmdres=0; # makes it always continue after a debugged run
978    }
979    elsif($gdbthis == 2) {
980        # $gdb is "lldb"
981        print "runs lldb -- $CURL $cmdargs\n";
982        runclient("lldb -- $CURL $cmdargs");
983        $cmdres=0; # makes it always continue after a debugged run
984    }
985    else {
986        # Convert the raw result code into a more useful one
987        ($cmdres, $dumped_core) = normalize_cmdres(runclient("$CMDLINE"));
988    }
989
990    # timestamp finishing of test command
991    $$testtimings{"timetoolend"} = Time::HiRes::time();
992
993    return (0, $cmdres, $dumped_core, $CURLOUT, $tool, use_valgrind() && !$disablevalgrind);
994}
995
996
997#######################################################################
998# Clean up after test command
999sub singletest_clean {
1000    my ($testnum, $dumped_core, $testtimings)=@_;
1001
1002    if(!$dumped_core) {
1003        if(-r "core") {
1004            # there's core file present now!
1005            $dumped_core = 1;
1006        }
1007    }
1008
1009    if($dumped_core) {
1010        logmsg "core dumped\n";
1011        if(0 && $gdb) {
1012            logmsg "running gdb for post-mortem analysis:\n";
1013            open(my $gdbcmd, ">", "$LOGDIR/gdbcmd2") || die "Failure writing gdb file";
1014            print $gdbcmd "bt\n";
1015            close($gdbcmd) || die "Failure writing gdb file";
1016            runclient("$gdb --directory libtest -x $LOGDIR/gdbcmd2 -batch " . shell_quote($DBGCURL) . " core ");
1017     #       unlink("$LOGDIR/gdbcmd2");
1018        }
1019    }
1020
1021    # If a server logs advisor read lock file exists, it is an indication
1022    # that the server has not yet finished writing out all its log files,
1023    # including server request log files used for protocol verification.
1024    # So, if the lock file exists the script waits here a certain amount
1025    # of time until the server removes it, or the given time expires.
1026    my $serverlogslocktimeout = $defserverlogslocktimeout;
1027    my %cmdhash = getpartattr("client", "command");
1028    if($cmdhash{'timeout'}) {
1029        # test is allowed to override default server logs lock timeout
1030        if($cmdhash{'timeout'} =~ /(\d+)/) {
1031            $serverlogslocktimeout = $1 if($1 >= 0);
1032        }
1033    }
1034    if($serverlogslocktimeout) {
1035        my $lockretry = $serverlogslocktimeout * 20;
1036        my @locks;
1037        while((@locks = logslocked()) && $lockretry--) {
1038            portable_sleep(0.05);
1039        }
1040        if(($lockretry < 0) &&
1041           ($serverlogslocktimeout >= $defserverlogslocktimeout)) {
1042            logmsg "Warning: server logs lock timeout ",
1043                   "($serverlogslocktimeout seconds) expired (locks: " .
1044                   join(", ", @locks) . ")\n";
1045        }
1046    }
1047
1048    # Test harness ssh server does not have this synchronization mechanism,
1049    # this implies that some ssh server based tests might need a small delay
1050    # once that the client command has run to avoid false test failures.
1051    #
1052    # gnutls-serv also lacks this synchronization mechanism, so gnutls-serv
1053    # based tests might need a small delay once that the client command has
1054    # run to avoid false test failures.
1055    my $postcommanddelay = $defpostcommanddelay;
1056    if($cmdhash{'delay'}) {
1057        # test is allowed to specify a delay after command is executed
1058        if($cmdhash{'delay'} =~ /(\d+)/) {
1059            $postcommanddelay = $1 if($1 > 0);
1060        }
1061    }
1062
1063    portable_sleep($postcommanddelay) if($postcommanddelay);
1064
1065    # timestamp removal of server logs advisor read lock
1066    $$testtimings{"timesrvrlog"} = Time::HiRes::time();
1067
1068    # test definition might instruct to stop some servers
1069    # stop also all servers relative to the given one
1070
1071    my @killtestservers = getpart("client", "killserver");
1072    if(@killtestservers) {
1073        foreach my $server (@killtestservers) {
1074            chomp $server;
1075            if(stopserver($server)) {
1076                logmsg " $testnum: killserver FAILED\n";
1077                return 1; # normal error if asked to fail on unexpected alive
1078            }
1079        }
1080    }
1081    return 0;
1082}
1083
1084#######################################################################
1085# Verify that the postcheck succeeded
1086sub singletest_postcheck {
1087    my ($testnum)=@_;
1088
1089    # run the postcheck command
1090    my @postcheck= getpart("client", "postcheck");
1091    if(@postcheck) {
1092        my $cmd = join("", @postcheck);
1093        chomp $cmd;
1094        if($cmd) {
1095            logmsg "postcheck $cmd\n" if($verbose);
1096            my $rc = runclient("$cmd");
1097            # Must run the postcheck command in torture mode in order
1098            # to clean up, but the result can't be relied upon.
1099            if($rc != 0 && !$torture) {
1100                logmsg " $testnum: postcheck FAILED\n";
1101                return -1;
1102            }
1103        }
1104    }
1105    return 0;
1106}
1107
1108
1109
1110###################################################################
1111# Get ready to run a single test case
1112sub runner_test_preprocess {
1113    my ($testnum)=@_;
1114    my %testtimings;
1115
1116    if(clearlogs()) {
1117        logmsg "Warning: log messages were lost\n";
1118    }
1119
1120    # timestamp test preparation start
1121    # TODO: this metric now shows only a portion of the prep time; better would
1122    # be to time singletest_preprocess below instead
1123    $testtimings{"timeprepini"} = Time::HiRes::time();
1124
1125    ###################################################################
1126    # Load test metadata
1127    # ignore any error here--if there were one, it would have been
1128    # caught during the selection phase and this test would not be
1129    # running now
1130    loadtest("${TESTDIR}/test${testnum}");
1131    readtestkeywords();
1132
1133    ###################################################################
1134    # Restore environment variables that were modified in a previous run.
1135    # Test definition may instruct to (un)set environment vars.
1136    restore_test_env(1);
1137
1138    ###################################################################
1139    # Start the servers needed to run this test case
1140    my ($why, $error) = singletest_startservers($testnum, \%testtimings);
1141
1142    if(!$why) {
1143
1144        ###############################################################
1145        # Generate preprocessed test file
1146        # This must be done after the servers are started so server
1147        # variables are available for substitution.
1148        singletest_preprocess($testnum);
1149
1150        ###############################################################
1151        # Set up the test environment to run this test case
1152        singletest_setenv();
1153
1154        ###############################################################
1155        # Check that the test environment is fine to run this test case
1156        if (!$listonly) {
1157            $why = singletest_precheck($testnum);
1158            $error = -1;
1159        }
1160    }
1161    return ($why, $error, clearlogs(), \%testtimings);
1162}
1163
1164
1165###################################################################
1166# Run a single test case with an environment that already been prepared
1167# Returns 0=success, -1=skippable failure, -2=permanent error,
1168#   1=unskippable test failure, as first integer, plus any log messages,
1169#   plus more return values when error is 0
1170sub runner_test_run {
1171    my ($testnum)=@_;
1172
1173    if(clearlogs()) {
1174        logmsg "Warning: log messages were lost\n";
1175    }
1176
1177    #######################################################################
1178    # Prepare the test environment to run this test case
1179    my $error = singletest_prepare($testnum);
1180    if($error) {
1181        return (-2, clearlogs());
1182    }
1183
1184    #######################################################################
1185    # Run the test command
1186    my %testtimings;
1187    my $cmdres;
1188    my $dumped_core;
1189    my $CURLOUT;
1190    my $tool;
1191    my $usedvalgrind;
1192    ($error, $cmdres, $dumped_core, $CURLOUT, $tool, $usedvalgrind) = singletest_run($testnum, \%testtimings);
1193    if($error) {
1194        return (-2, clearlogs(), \%testtimings);
1195    }
1196
1197    #######################################################################
1198    # Clean up after test command
1199    $error = singletest_clean($testnum, $dumped_core, \%testtimings);
1200    if($error) {
1201        return ($error, clearlogs(), \%testtimings);
1202    }
1203
1204    #######################################################################
1205    # Verify that the postcheck succeeded
1206    $error = singletest_postcheck($testnum);
1207    if($error) {
1208        return ($error, clearlogs(), \%testtimings);
1209    }
1210
1211    #######################################################################
1212    # restore environment variables that were modified
1213    restore_test_env(0);
1214
1215    return (0, clearlogs(), \%testtimings, $cmdres, $CURLOUT, $tool, $usedvalgrind);
1216}
1217
1218# Async call runner_clearlocks
1219# Called by controller
1220sub runnerac_clearlocks {
1221    return controlleripccall(\&runner_clearlocks, @_);
1222}
1223
1224# Async call runner_shutdown
1225# This call does NOT generate an IPC response and must be the last IPC call
1226# received.
1227# Called by controller
1228sub runnerac_shutdown {
1229    my ($runnerid)=$_[0];
1230    my $err = controlleripccall(\&runner_shutdown, @_);
1231
1232    # These have no more use
1233    close($controllerw{$runnerid});
1234    undef $controllerw{$runnerid};
1235    close($controllerr{$runnerid});
1236    undef $controllerr{$runnerid};
1237    return $err;
1238}
1239
1240# Async call of runner_stopservers
1241# Called by controller
1242sub runnerac_stopservers {
1243    return controlleripccall(\&runner_stopservers, @_);
1244}
1245
1246# Async call of runner_test_preprocess
1247# Called by controller
1248sub runnerac_test_preprocess {
1249    return controlleripccall(\&runner_test_preprocess, @_);
1250}
1251
1252# Async call of runner_test_run
1253# Called by controller
1254sub runnerac_test_run {
1255    return controlleripccall(\&runner_test_run, @_);
1256}
1257
1258###################################################################
1259# Call an arbitrary function via IPC
1260# The first argument is the function reference, the second is the runner ID
1261# Returns 0 on success, -1 on error writing to runner
1262# Called by controller (indirectly, via a more specific function)
1263sub controlleripccall {
1264    my $funcref = shift @_;
1265    my $runnerid = shift @_;
1266    # Get the name of the function from the reference
1267    my $cv = svref_2object($funcref);
1268    my $gv = $cv->GV;
1269    # Prepend the name to the function arguments so it's marshalled along with them
1270    unshift @_, $gv->NAME;
1271    # Marshall the arguments into a flat string
1272    my $margs = freeze \@_;
1273
1274    # Send IPC call via pipe
1275    my $err;
1276    while(! defined ($err = syswrite($controllerw{$runnerid}, (pack "L", length($margs)) . $margs)) || $err <= 0) {
1277        if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
1278            # Runner has likely died
1279            return -1;
1280        }
1281        # system call was interrupted, probably by ^C; restart it so we stay in sync
1282    }
1283
1284    if(!$multiprocess) {
1285        # Call the remote function here in single process mode
1286        ipcrecv();
1287     }
1288     return 0;
1289}
1290
1291###################################################################
1292# Receive async response of a previous call via IPC
1293# The first return value is the runner ID or undef on error
1294# Called by controller
1295sub runnerar {
1296    my ($runnerid) = @_;
1297    my $err;
1298    my $datalen;
1299    while(! defined ($err = sysread($controllerr{$runnerid}, $datalen, 4)) || $err <= 0) {
1300        if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
1301            # Runner is likely dead and closed the pipe
1302            return undef;
1303        }
1304        # system call was interrupted, probably by ^C; restart it so we stay in sync
1305    }
1306    my $len=unpack("L", $datalen);
1307    my $buf;
1308    while(! defined ($err = sysread($controllerr{$runnerid}, $buf, $len)) || $err <= 0) {
1309        if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
1310            # Runner is likely dead and closed the pipe
1311            return undef;
1312        }
1313        # system call was interrupted, probably by ^C; restart it so we stay in sync
1314    }
1315
1316    # Decode response values
1317    my $resarrayref = thaw $buf;
1318
1319    # First argument is runner ID
1320    # TODO: remove this; it's unneeded since it's passed in
1321    unshift @$resarrayref, $runnerid;
1322    return @$resarrayref;
1323}
1324
1325###################################################################
1326# Returns runner ID if a response from an async call is ready or error
1327# First value is ready, second is error, however an error case shows up
1328# as ready in Linux, so you can't trust it.
1329# argument is 0 for nonblocking, undef for blocking, anything else for timeout
1330# Called by controller
1331sub runnerar_ready {
1332    my ($blocking) = @_;
1333    my $rin = "";
1334    my %idbyfileno;
1335    my $maxfileno=0;
1336    foreach my $p (keys(%controllerr)) {
1337        my $fd = fileno($controllerr{$p});
1338        vec($rin, $fd, 1) = 1;
1339        $idbyfileno{$fd} = $p;  # save the runner ID for each pipe fd
1340        if($fd > $maxfileno) {
1341            $maxfileno = $fd;
1342        }
1343    }
1344    $maxfileno || die "Internal error: no runners are available to wait on\n";
1345
1346    # Wait for any pipe from any runner to be ready
1347    # This may be interrupted and return EINTR, but this is ignored and the
1348    # caller will need to later call this function again.
1349    # TODO: this is relatively slow with hundreds of fds
1350    my $ein = $rin;
1351    if(select(my $rout=$rin, undef, my $eout=$ein, $blocking) >= 1) {
1352        for my $fd (0..$maxfileno) {
1353            # Return an error condition first in case it's both
1354            if(vec($eout, $fd, 1)) {
1355                return (undef, $idbyfileno{$fd});
1356            }
1357            if(vec($rout, $fd, 1)) {
1358                return ($idbyfileno{$fd}, undef);
1359            }
1360        }
1361        die "Internal pipe readiness inconsistency\n";
1362    }
1363    return (undef, undef);
1364}
1365
1366
1367###################################################################
1368# Cleanly abort and exit the runner
1369# This uses print since there is no longer any controller to write logs.
1370sub runnerabort{
1371    print "Controller is gone: runner $$ for $LOGDIR exiting\n";
1372    my ($error, $logs) = runner_stopservers();
1373    print $logs;
1374    runner_shutdown();
1375}
1376
1377###################################################################
1378# Receive an IPC call in the runner and execute it
1379# The IPC is read from the $runnerr pipe and the response is
1380# written to the $runnerw pipe
1381# Returns 0 if more IPC calls are expected or 1 if the runner should exit
1382sub ipcrecv {
1383    my $err;
1384    my $datalen;
1385    while(! defined ($err = sysread($runnerr, $datalen, 4)) || $err <= 0) {
1386        if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
1387            # pipe has closed; controller is gone and we must exit
1388            runnerabort();
1389            # Special case: no response will be forthcoming
1390            return 1;
1391        }
1392        # system call was interrupted, probably by ^C; restart it so we stay in sync
1393    }
1394    my $len=unpack("L", $datalen);
1395    my $buf;
1396    while(! defined ($err = sysread($runnerr, $buf, $len)) || $err <= 0) {
1397        if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
1398            # pipe has closed; controller is gone and we must exit
1399            runnerabort();
1400            # Special case: no response will be forthcoming
1401            return 1;
1402        }
1403        # system call was interrupted, probably by ^C; restart it so we stay in sync
1404    }
1405
1406    # Decode the function name and arguments
1407    my $argsarrayref = thaw $buf;
1408
1409    # The name of the function to call is the first argument
1410    my $funcname = shift @$argsarrayref;
1411
1412    # print "ipcrecv $funcname\n";
1413    # Synchronously call the desired function
1414    my @res;
1415    if($funcname eq "runner_clearlocks") {
1416        @res = runner_clearlocks(@$argsarrayref);
1417    }
1418    elsif($funcname eq "runner_shutdown") {
1419        runner_shutdown(@$argsarrayref);
1420        # Special case: no response will be forthcoming
1421        return 1;
1422    }
1423    elsif($funcname eq "runner_stopservers") {
1424        @res = runner_stopservers(@$argsarrayref);
1425    }
1426    elsif($funcname eq "runner_test_preprocess") {
1427        @res = runner_test_preprocess(@$argsarrayref);
1428    }
1429    elsif($funcname eq "runner_test_run") {
1430        @res = runner_test_run(@$argsarrayref);
1431    } else {
1432        die "Unknown IPC function $funcname\n";
1433    }
1434    # print "ipcrecv results\n";
1435
1436    # Marshall the results to return
1437    $buf = freeze \@res;
1438
1439    while(! defined ($err = syswrite($runnerw, (pack "L", length($buf)) . $buf)) || $err <= 0) {
1440        if((!defined $err && ! $!{EINTR}) || (defined $err && $err == 0)) {
1441            # pipe has closed; controller is gone and we must exit
1442            runnerabort();
1443            # Special case: no response will be forthcoming
1444            return 1;
1445        }
1446        # system call was interrupted, probably by ^C; restart it so we stay in sync
1447    }
1448
1449    return 0;
1450}
1451
1452###################################################################
1453# Kill the server processes that still have lock files in a directory
1454sub runner_clearlocks {
1455    my ($lockdir)=@_;
1456    if(clearlogs()) {
1457        logmsg "Warning: log messages were lost\n";
1458    }
1459    clearlocks($lockdir);
1460    return clearlogs();
1461}
1462
1463
1464###################################################################
1465# Kill all server processes
1466sub runner_stopservers {
1467    my $error = stopservers($verbose);
1468    my $logs = clearlogs();
1469    return ($error, $logs);
1470}
1471
1472###################################################################
1473# Shut down this runner
1474sub runner_shutdown {
1475    close($runnerr);
1476    undef $runnerr;
1477    close($runnerw);
1478    undef $runnerw;
1479}
1480
1481
14821;
1483