runner.pm 46 KB

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