test_helper.tcl 21 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685
  1. # Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com
  2. # This software is released under the BSD License. See the COPYING file for
  3. # more information.
  4. package require Tcl 8.5
  5. set tcl_precision 17
  6. source tests/support/redis.tcl
  7. source tests/support/server.tcl
  8. source tests/support/tmpfile.tcl
  9. source tests/support/test.tcl
  10. source tests/support/util.tcl
  11. set ::all_tests {
  12. unit/printver
  13. unit/dump
  14. unit/auth
  15. unit/protocol
  16. unit/keyspace
  17. unit/scan
  18. unit/type/string
  19. unit/type/incr
  20. unit/type/list
  21. unit/type/list-2
  22. unit/type/list-3
  23. unit/type/set
  24. unit/type/zset
  25. unit/type/hash
  26. unit/type/stream
  27. unit/type/stream-cgroups
  28. unit/sort
  29. unit/expire
  30. unit/other
  31. unit/multi
  32. unit/quit
  33. unit/aofrw
  34. unit/acl
  35. integration/block-repl
  36. integration/replication
  37. integration/replication-2
  38. integration/replication-3
  39. integration/replication-4
  40. integration/replication-psync
  41. integration/aof
  42. integration/rdb
  43. integration/convert-zipmap-hash-on-load
  44. integration/logging
  45. integration/psync2
  46. integration/psync2-reg
  47. integration/psync2-pingoff
  48. unit/pubsub
  49. unit/slowlog
  50. unit/scripting
  51. unit/maxmemory
  52. unit/introspection
  53. unit/introspection-2
  54. unit/limits
  55. unit/obuf-limits
  56. unit/bitops
  57. unit/bitfield
  58. unit/geo
  59. unit/memefficiency
  60. unit/hyperloglog
  61. unit/lazyfree
  62. unit/wait
  63. unit/pendingquerybuf
  64. unit/tls
  65. }
  66. # Index to the next test to run in the ::all_tests list.
  67. set ::next_test 0
  68. set ::host 127.0.0.1
  69. set ::port 21111
  70. set ::traceleaks 0
  71. set ::valgrind 0
  72. set ::tls 0
  73. set ::stack_logging 0
  74. set ::verbose 0
  75. set ::quiet 0
  76. set ::denytags {}
  77. set ::skiptests {}
  78. set ::allowtags {}
  79. set ::only_tests {}
  80. set ::single_tests {}
  81. set ::skip_till ""
  82. set ::external 0; # If "1" this means, we are running against external instance
  83. set ::file ""; # If set, runs only the tests in this comma separated list
  84. set ::curfile ""; # Hold the filename of the current suite
  85. set ::accurate 0; # If true runs fuzz tests with more iterations
  86. set ::force_failure 0
  87. set ::timeout 1200; # 20 minutes without progresses will quit the test.
  88. set ::last_progress [clock seconds]
  89. set ::active_servers {} ; # Pids of active Redis instances.
  90. set ::dont_clean 0
  91. set ::wait_server 0
  92. set ::stop_on_failure 0
  93. set ::loop 0
  94. set ::tlsdir "tests/tls"
  95. # Set to 1 when we are running in client mode. The Redis test uses a
  96. # server-client model to run tests simultaneously. The server instance
  97. # runs the specified number of client instances that will actually run tests.
  98. # The server is responsible of showing the result to the user, and exit with
  99. # the appropriate exit code depending on the test outcome.
  100. set ::client 0
  101. set ::numclients 16
  102. proc execute_tests name {
  103. set path "tests/$name.tcl"
  104. set ::curfile $path
  105. source $path
  106. send_data_packet $::test_server_fd done "$name"
  107. }
  108. # Setup a list to hold a stack of server configs. When calls to start_server
  109. # are nested, use "srv 0 pid" to get the pid of the inner server. To access
  110. # outer servers, use "srv -1 pid" etcetera.
  111. set ::servers {}
  112. proc srv {args} {
  113. set level 0
  114. if {[string is integer [lindex $args 0]]} {
  115. set level [lindex $args 0]
  116. set property [lindex $args 1]
  117. } else {
  118. set property [lindex $args 0]
  119. }
  120. set srv [lindex $::servers end+$level]
  121. dict get $srv $property
  122. }
  123. # Provide easy access to the client for the inner server. It's possible to
  124. # prepend the argument list with a negative level to access clients for
  125. # servers running in outer blocks.
  126. proc r {args} {
  127. set level 0
  128. if {[string is integer [lindex $args 0]]} {
  129. set level [lindex $args 0]
  130. set args [lrange $args 1 end]
  131. }
  132. [srv $level "client"] {*}$args
  133. }
  134. proc reconnect {args} {
  135. set level [lindex $args 0]
  136. if {[string length $level] == 0 || ![string is integer $level]} {
  137. set level 0
  138. }
  139. set srv [lindex $::servers end+$level]
  140. set host [dict get $srv "host"]
  141. set port [dict get $srv "port"]
  142. set config [dict get $srv "config"]
  143. set client [redis $host $port 0 $::tls]
  144. dict set srv "client" $client
  145. # select the right db when we don't have to authenticate
  146. if {![dict exists $config "requirepass"]} {
  147. $client select 9
  148. }
  149. # re-set $srv in the servers list
  150. lset ::servers end+$level $srv
  151. }
  152. proc redis_deferring_client {args} {
  153. set level 0
  154. if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
  155. set level [lindex $args 0]
  156. set args [lrange $args 1 end]
  157. }
  158. # create client that defers reading reply
  159. set client [redis [srv $level "host"] [srv $level "port"] 1 $::tls]
  160. # select the right db and read the response (OK)
  161. $client select 9
  162. $client read
  163. return $client
  164. }
  165. # Provide easy access to INFO properties. Same semantic as "proc r".
  166. proc s {args} {
  167. set level 0
  168. if {[string is integer [lindex $args 0]]} {
  169. set level [lindex $args 0]
  170. set args [lrange $args 1 end]
  171. }
  172. status [srv $level "client"] [lindex $args 0]
  173. }
  174. proc cleanup {} {
  175. if {$::dont_clean} {
  176. return
  177. }
  178. if {!$::quiet} {puts -nonewline "Cleanup: may take some time... "}
  179. flush stdout
  180. catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
  181. catch {exec rm -rf {*}[glob tests/tmp/server.*]}
  182. if {!$::quiet} {puts "OK"}
  183. }
  184. proc test_server_main {} {
  185. cleanup
  186. set tclsh [info nameofexecutable]
  187. # Open a listening socket, trying different ports in order to find a
  188. # non busy one.
  189. set port [find_available_port 11111]
  190. if {!$::quiet} {
  191. puts "Starting test server at port $port"
  192. }
  193. socket -server accept_test_clients -myaddr 127.0.0.1 $port
  194. # Start the client instances
  195. set ::clients_pids {}
  196. if {$::external} {
  197. set p [exec $tclsh [info script] {*}$::argv \
  198. --client $port --port $::port &]
  199. lappend ::clients_pids $p
  200. } else {
  201. set start_port [expr {$::port+100}]
  202. for {set j 0} {$j < $::numclients} {incr j} {
  203. set start_port [find_available_port $start_port]
  204. set p [exec $tclsh [info script] {*}$::argv \
  205. --client $port --port $start_port &]
  206. lappend ::clients_pids $p
  207. incr start_port 10
  208. }
  209. }
  210. # Setup global state for the test server
  211. set ::idle_clients {}
  212. set ::active_clients {}
  213. array set ::active_clients_task {}
  214. array set ::clients_start_time {}
  215. set ::clients_time_history {}
  216. set ::failed_tests {}
  217. # Enter the event loop to handle clients I/O
  218. after 100 test_server_cron
  219. vwait forever
  220. }
  221. # This function gets called 10 times per second.
  222. proc test_server_cron {} {
  223. set elapsed [expr {[clock seconds]-$::last_progress}]
  224. if {$elapsed > $::timeout} {
  225. set err "\[[colorstr red TIMEOUT]\]: clients state report follows."
  226. puts $err
  227. lappend ::failed_tests $err
  228. show_clients_state
  229. kill_clients
  230. force_kill_all_servers
  231. the_end
  232. }
  233. after 100 test_server_cron
  234. }
  235. proc accept_test_clients {fd addr port} {
  236. fconfigure $fd -encoding binary
  237. fileevent $fd readable [list read_from_test_client $fd]
  238. }
  239. # This is the readable handler of our test server. Clients send us messages
  240. # in the form of a status code such and additional data. Supported
  241. # status types are:
  242. #
  243. # ready: the client is ready to execute the command. Only sent at client
  244. # startup. The server will queue the client FD in the list of idle
  245. # clients.
  246. # testing: just used to signal that a given test started.
  247. # ok: a test was executed with success.
  248. # err: a test was executed with an error.
  249. # skip: a test was skipped by skipfile or individual test options.
  250. # ignore: a test was skipped by a group tag.
  251. # exception: there was a runtime exception while executing the test.
  252. # done: all the specified test file was processed, this test client is
  253. # ready to accept a new task.
  254. proc read_from_test_client fd {
  255. set bytes [gets $fd]
  256. set payload [read $fd $bytes]
  257. foreach {status data} $payload break
  258. set ::last_progress [clock seconds]
  259. if {$status eq {ready}} {
  260. if {!$::quiet} {
  261. puts "\[$status\]: $data"
  262. }
  263. signal_idle_client $fd
  264. } elseif {$status eq {done}} {
  265. set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}]
  266. set all_tests_count [llength $::all_tests]
  267. set running_tests_count [expr {[llength $::active_clients]-1}]
  268. set completed_tests_count [expr {$::next_test-$running_tests_count}]
  269. puts "\[$completed_tests_count/$all_tests_count [colorstr yellow $status]\]: $data ($elapsed seconds)"
  270. lappend ::clients_time_history $elapsed $data
  271. signal_idle_client $fd
  272. set ::active_clients_task($fd) "(DONE) $data"
  273. } elseif {$status eq {ok}} {
  274. if {!$::quiet} {
  275. puts "\[[colorstr green $status]\]: $data"
  276. }
  277. set ::active_clients_task($fd) "(OK) $data"
  278. } elseif {$status eq {skip}} {
  279. if {!$::quiet} {
  280. puts "\[[colorstr yellow $status]\]: $data"
  281. }
  282. } elseif {$status eq {ignore}} {
  283. if {!$::quiet} {
  284. puts "\[[colorstr cyan $status]\]: $data"
  285. }
  286. } elseif {$status eq {err}} {
  287. set err "\[[colorstr red $status]\]: $data"
  288. puts $err
  289. lappend ::failed_tests $err
  290. set ::active_clients_task($fd) "(ERR) $data"
  291. if {$::stop_on_failure} {
  292. puts -nonewline "(Test stopped, press enter to continue)"
  293. flush stdout
  294. gets stdin
  295. }
  296. } elseif {$status eq {exception}} {
  297. puts "\[[colorstr red $status]\]: $data"
  298. kill_clients
  299. force_kill_all_servers
  300. exit 1
  301. } elseif {$status eq {testing}} {
  302. set ::active_clients_task($fd) "(IN PROGRESS) $data"
  303. } elseif {$status eq {server-spawning}} {
  304. set ::active_clients_task($fd) "(SPAWNING SERVER) $data"
  305. } elseif {$status eq {server-spawned}} {
  306. lappend ::active_servers $data
  307. set ::active_clients_task($fd) "(SPAWNED SERVER) pid:$data"
  308. } elseif {$status eq {server-killing}} {
  309. set ::active_clients_task($fd) "(KILLING SERVER) pid:$data"
  310. } elseif {$status eq {server-killed}} {
  311. set ::active_servers [lsearch -all -inline -not -exact $::active_servers $data]
  312. set ::active_clients_task($fd) "(KILLED SERVER) pid:$data"
  313. } else {
  314. if {!$::quiet} {
  315. puts "\[$status\]: $data"
  316. }
  317. }
  318. }
  319. proc show_clients_state {} {
  320. # The following loop is only useful for debugging tests that may
  321. # enter an infinite loop.
  322. foreach x $::active_clients {
  323. if {[info exist ::active_clients_task($x)]} {
  324. puts "$x => $::active_clients_task($x)"
  325. } else {
  326. puts "$x => ???"
  327. }
  328. }
  329. }
  330. proc kill_clients {} {
  331. foreach p $::clients_pids {
  332. catch {exec kill $p}
  333. }
  334. }
  335. proc force_kill_all_servers {} {
  336. foreach p $::active_servers {
  337. puts "Killing still running Redis server $p"
  338. catch {exec kill -9 $p}
  339. }
  340. }
  341. # A new client is idle. Remove it from the list of active clients and
  342. # if there are still test units to run, launch them.
  343. proc signal_idle_client fd {
  344. # Remove this fd from the list of active clients.
  345. set ::active_clients \
  346. [lsearch -all -inline -not -exact $::active_clients $fd]
  347. # New unit to process?
  348. if {$::next_test != [llength $::all_tests]} {
  349. if {!$::quiet} {
  350. puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"]
  351. set ::active_clients_task($fd) "ASSIGNED: $fd ([lindex $::all_tests $::next_test])"
  352. }
  353. set ::clients_start_time($fd) [clock seconds]
  354. send_data_packet $fd run [lindex $::all_tests $::next_test]
  355. lappend ::active_clients $fd
  356. incr ::next_test
  357. if {$::loop && $::next_test == [llength $::all_tests]} {
  358. set ::next_test 0
  359. }
  360. } else {
  361. lappend ::idle_clients $fd
  362. set ::active_clients_task($fd) "SLEEPING, no more units to assign"
  363. if {[llength $::active_clients] == 0} {
  364. the_end
  365. }
  366. }
  367. }
  368. # The the_end function gets called when all the test units were already
  369. # executed, so the test finished.
  370. proc the_end {} {
  371. # TODO: print the status, exit with the rigth exit code.
  372. puts "\n The End\n"
  373. puts "Execution time of different units:"
  374. foreach {time name} $::clients_time_history {
  375. puts " $time seconds - $name"
  376. }
  377. if {[llength $::failed_tests]} {
  378. puts "\n[colorstr bold-red {!!! WARNING}] The following tests failed:\n"
  379. foreach failed $::failed_tests {
  380. puts "*** $failed"
  381. }
  382. cleanup
  383. exit 1
  384. } else {
  385. puts "\n[colorstr bold-white {\o/}] [colorstr bold-green {All tests passed without errors!}]\n"
  386. cleanup
  387. exit 0
  388. }
  389. }
  390. # The client is not even driven (the test server is instead) as we just need
  391. # to read the command, execute, reply... all this in a loop.
  392. proc test_client_main server_port {
  393. set ::test_server_fd [socket localhost $server_port]
  394. fconfigure $::test_server_fd -encoding binary
  395. send_data_packet $::test_server_fd ready [pid]
  396. while 1 {
  397. set bytes [gets $::test_server_fd]
  398. set payload [read $::test_server_fd $bytes]
  399. foreach {cmd data} $payload break
  400. if {$cmd eq {run}} {
  401. execute_tests $data
  402. } else {
  403. error "Unknown test client command: $cmd"
  404. }
  405. }
  406. }
  407. proc send_data_packet {fd status data} {
  408. set payload [list $status $data]
  409. puts $fd [string length $payload]
  410. puts -nonewline $fd $payload
  411. flush $fd
  412. }
  413. proc print_help_screen {} {
  414. puts [join {
  415. "--valgrind Run the test over valgrind."
  416. "--stack-logging Enable OSX leaks/malloc stack logging."
  417. "--accurate Run slow randomized tests for more iterations."
  418. "--quiet Don't show individual tests."
  419. "--single <unit> Just execute the specified unit (see next option). this option can be repeated."
  420. "--list-tests List all the available test units."
  421. "--only <test> Just execute the specified test by test name. this option can be repeated."
  422. "--skip-till <unit> Skip all units until (and including) the specified one."
  423. "--clients <num> Number of test clients (default 16)."
  424. "--timeout <sec> Test timeout in seconds (default 10 min)."
  425. "--force-failure Force the execution of a test that always fails."
  426. "--config <k> <v> Extra config file argument."
  427. "--skipfile <file> Name of a file containing test names that should be skipped (one per line)."
  428. "--dont-clean Don't delete redis log files after the run."
  429. "--stop Blocks once the first test fails."
  430. "--loop Execute the specified set of tests forever."
  431. "--wait-server Wait after server is started (so that you can attach a debugger)."
  432. "--tls Run tests in TLS mode."
  433. "--help Print this help screen."
  434. } "\n"]
  435. }
  436. # parse arguments
  437. for {set j 0} {$j < [llength $argv]} {incr j} {
  438. set opt [lindex $argv $j]
  439. set arg [lindex $argv [expr $j+1]]
  440. if {$opt eq {--tags}} {
  441. foreach tag $arg {
  442. if {[string index $tag 0] eq "-"} {
  443. lappend ::denytags [string range $tag 1 end]
  444. } else {
  445. lappend ::allowtags $tag
  446. }
  447. }
  448. incr j
  449. } elseif {$opt eq {--config}} {
  450. set arg2 [lindex $argv [expr $j+2]]
  451. lappend ::global_overrides $arg
  452. lappend ::global_overrides $arg2
  453. incr j 2
  454. } elseif {$opt eq {--skipfile}} {
  455. incr j
  456. set fp [open $arg r]
  457. set file_data [read $fp]
  458. close $fp
  459. set ::skiptests [split $file_data "\n"]
  460. } elseif {$opt eq {--valgrind}} {
  461. set ::valgrind 1
  462. } elseif {$opt eq {--stack-logging}} {
  463. if {[string match {*Darwin*} [exec uname -a]]} {
  464. set ::stack_logging 1
  465. }
  466. } elseif {$opt eq {--quiet}} {
  467. set ::quiet 1
  468. } elseif {$opt eq {--tls}} {
  469. package require tls 1.6
  470. set ::tls 1
  471. ::tls::init \
  472. -cafile "$::tlsdir/ca.crt" \
  473. -certfile "$::tlsdir/redis.crt" \
  474. -keyfile "$::tlsdir/redis.key"
  475. } elseif {$opt eq {--host}} {
  476. set ::external 1
  477. set ::host $arg
  478. incr j
  479. } elseif {$opt eq {--port}} {
  480. set ::port $arg
  481. incr j
  482. } elseif {$opt eq {--accurate}} {
  483. set ::accurate 1
  484. } elseif {$opt eq {--force-failure}} {
  485. set ::force_failure 1
  486. } elseif {$opt eq {--single}} {
  487. lappend ::single_tests $arg
  488. incr j
  489. } elseif {$opt eq {--only}} {
  490. lappend ::only_tests $arg
  491. incr j
  492. } elseif {$opt eq {--skip-till}} {
  493. set ::skip_till $arg
  494. incr j
  495. } elseif {$opt eq {--list-tests}} {
  496. foreach t $::all_tests {
  497. puts $t
  498. }
  499. exit 0
  500. } elseif {$opt eq {--verbose}} {
  501. set ::verbose 1
  502. } elseif {$opt eq {--client}} {
  503. set ::client 1
  504. set ::test_server_port $arg
  505. incr j
  506. } elseif {$opt eq {--clients}} {
  507. set ::numclients $arg
  508. incr j
  509. } elseif {$opt eq {--dont-clean}} {
  510. set ::dont_clean 1
  511. } elseif {$opt eq {--wait-server}} {
  512. set ::wait_server 1
  513. } elseif {$opt eq {--stop}} {
  514. set ::stop_on_failure 1
  515. } elseif {$opt eq {--loop}} {
  516. set ::loop 1
  517. } elseif {$opt eq {--timeout}} {
  518. set ::timeout $arg
  519. incr j
  520. } elseif {$opt eq {--help}} {
  521. print_help_screen
  522. exit 0
  523. } else {
  524. puts "Wrong argument: $opt"
  525. exit 1
  526. }
  527. }
  528. # If --skil-till option was given, we populate the list of single tests
  529. # to run with everything *after* the specified unit.
  530. if {$::skip_till != ""} {
  531. set skipping 1
  532. foreach t $::all_tests {
  533. if {$skipping == 0} {
  534. lappend ::single_tests $t
  535. }
  536. if {$t == $::skip_till} {
  537. set skipping 0
  538. }
  539. }
  540. if {$skipping} {
  541. puts "test $::skip_till not found"
  542. exit 0
  543. }
  544. }
  545. # Override the list of tests with the specific tests we want to run
  546. # in case there was some filter, that is --single or --skip-till options.
  547. if {[llength $::single_tests] > 0} {
  548. set ::all_tests $::single_tests
  549. }
  550. proc attach_to_replication_stream {} {
  551. if {$::tls} {
  552. set s [::tls::socket [srv 0 "host"] [srv 0 "port"]]
  553. } else {
  554. set s [socket [srv 0 "host"] [srv 0 "port"]]
  555. }
  556. fconfigure $s -translation binary
  557. puts -nonewline $s "SYNC\r\n"
  558. flush $s
  559. # Get the count
  560. while 1 {
  561. set count [gets $s]
  562. set prefix [string range $count 0 0]
  563. if {$prefix ne {}} break; # Newlines are allowed as PINGs.
  564. }
  565. if {$prefix ne {$}} {
  566. error "attach_to_replication_stream error. Received '$count' as count."
  567. }
  568. set count [string range $count 1 end]
  569. # Consume the bulk payload
  570. while {$count} {
  571. set buf [read $s $count]
  572. set count [expr {$count-[string length $buf]}]
  573. }
  574. return $s
  575. }
  576. proc read_from_replication_stream {s} {
  577. fconfigure $s -blocking 0
  578. set attempt 0
  579. while {[gets $s count] == -1} {
  580. if {[incr attempt] == 10} return ""
  581. after 100
  582. }
  583. fconfigure $s -blocking 1
  584. set count [string range $count 1 end]
  585. # Return a list of arguments for the command.
  586. set res {}
  587. for {set j 0} {$j < $count} {incr j} {
  588. read $s 1
  589. set arg [::redis::redis_bulk_read $s]
  590. if {$j == 0} {set arg [string tolower $arg]}
  591. lappend res $arg
  592. }
  593. return $res
  594. }
  595. proc assert_replication_stream {s patterns} {
  596. for {set j 0} {$j < [llength $patterns]} {incr j} {
  597. assert_match [lindex $patterns $j] [read_from_replication_stream $s]
  598. }
  599. }
  600. proc close_replication_stream {s} {
  601. close $s
  602. }
  603. # With the parallel test running multiple Redis instances at the same time
  604. # we need a fast enough computer, otherwise a lot of tests may generate
  605. # false positives.
  606. # If the computer is too slow we revert the sequential test without any
  607. # parallelism, that is, clients == 1.
  608. proc is_a_slow_computer {} {
  609. set start [clock milliseconds]
  610. for {set j 0} {$j < 1000000} {incr j} {}
  611. set elapsed [expr [clock milliseconds]-$start]
  612. expr {$elapsed > 200}
  613. }
  614. if {$::client} {
  615. if {[catch { test_client_main $::test_server_port } err]} {
  616. set estr "Executing test client: $err.\n$::errorInfo"
  617. if {[catch {send_data_packet $::test_server_fd exception $estr}]} {
  618. puts $estr
  619. }
  620. exit 1
  621. }
  622. } else {
  623. if {[is_a_slow_computer]} {
  624. puts "** SLOW COMPUTER ** Using a single client to avoid false positives."
  625. set ::numclients 1
  626. }
  627. if {[catch { test_server_main } err]} {
  628. if {[string length $err] > 0} {
  629. # only display error when not generated by the test suite
  630. if {$err ne "exception"} {
  631. puts $::errorInfo
  632. }
  633. exit 1
  634. }
  635. }
  636. }