+ # Start the client instances
+ set ::clients_pids {}
+ for {set j 0} {$j < $::numclients} {incr j} {
+ set p [exec tclsh8.5 [info script] {*}$::argv \
+ --client $port --port [expr {$::port+($j*10)}] &]
+ lappend ::clients_pids $p
+ }
+
+ # Setup global state for the test server
+ set ::idle_clients {}
+ set ::active_clients {}
+ array set ::clients_start_time {}
+ set ::clients_time_history {}
+
+ # Enter the event loop to handle clients I/O
+ after 100 test_server_cron
+ vwait forever
+}
+
+# This function gets called 10 times per second, for now does nothing but
+# may be used in the future in order to detect test clients taking too much
+# time to execute the task.
+proc test_server_cron {} {
+}
+
+proc accept_test_clients {fd addr port} {
+ fileevent $fd readable [list read_from_test_client $fd]
+}
+
+# This is the readable handler of our test server. Clients send us messages
+# in the form of a status code such and additional data. Supported
+# status types are:
+#
+# ready: the client is ready to execute the command. Only sent at client
+# startup. The server will queue the client FD in the list of idle
+# clients.
+# testing: just used to signal that a given test started.
+# ok: a test was executed with success.
+# err: a test was executed with an error.
+# exception: there was a runtime exception while executing the test.
+# done: all the specified test file was processed, this test client is
+# ready to accept a new task.
+proc read_from_test_client fd {
+ set bytes [gets $fd]
+ set payload [read $fd $bytes]
+ foreach {status data} $payload break
+ if {$status eq {ready}} {
+ puts "\[$status\]: $data"
+ signal_idle_client $fd
+ } elseif {$status eq {done}} {
+ set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}]
+ puts "\[[colorstr yellow $status]\]: $data ($elapsed seconds)"
+ puts "+++ [expr {[llength $::active_clients]-1}] units still in execution."
+ lappend ::clients_time_history $elapsed $data
+ signal_idle_client $fd
+ } elseif {$status eq {ok}} {
+ puts "\[[colorstr green $status]\]: $data"
+ } elseif {$status eq {err}} {
+ puts "\[[colorstr red $status]\]: $data"
+ } elseif {$status eq {exception}} {
+ puts "\[[colorstr red $status]\]: $data"
+ foreach p $::clients_pids {
+ catch {exec kill -9 $p}
+ }
+ exit 1
+ } elseif {$status eq {testing}} {
+ # No op
+ } else {
+ puts "\[$status\]: $data"
+ }
+}
+
+# A new client is idle. Remove it from the list of active clients and
+# if there are still test units to run, launch them.
+proc signal_idle_client fd {
+ # Remove this fd from the list of active clients.
+ set ::active_clients \
+ [lsearch -all -inline -not -exact $::active_clients $fd]
+ # New unit to process?
+ if {$::next_test != [llength $::all_tests]} {
+ puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"]
+ set ::clients_start_time($fd) [clock seconds]
+ send_data_packet $fd run [lindex $::all_tests $::next_test]
+ lappend ::active_clients $fd
+ incr ::next_test
+ } else {
+ lappend ::idle_clients $fd
+ if {[llength $::active_clients] == 0} {
+ the_end
+ }
+ }
+}
+
+# The the_end funciton gets called when all the test units were already
+# executed, so the test finished.
+proc the_end {} {
+ # TODO: print the status, exit with the rigth exit code.
+ puts "The End\n"
+ puts "Execution time of different units:"
+ foreach {time name} $::clients_time_history {
+ puts " $time seconds - $name"
+ }
+ exit 1
+}
+
+# The client is not even driven (the test server is instead) as we just need
+# to read the command, execute, reply... all this in a loop.
+proc test_client_main server_port {
+ set ::test_server_fd [socket localhost $server_port]
+ send_data_packet $::test_server_fd ready [pid]
+ while 1 {
+ set bytes [gets $::test_server_fd]
+ set payload [read $::test_server_fd $bytes]
+ foreach {cmd data} $payload break
+ if {$cmd eq {run}} {
+ execute_tests $data
+ } else {
+ error "Unknown test client command: $cmd"
+ }
+ }
+}
+
+proc send_data_packet {fd status data} {
+ set payload [list $status $data]
+ puts $fd [string length $payload]
+ puts -nonewline $fd $payload
+ flush $fd
projects / redis.git / blobdiff