]> git.saurik.com Git - redis.git/blame - tests/test_helper.tcl
Purely aesthetic code change.
[redis.git] / tests / test_helper.tcl
CommitLineData
98578b57
PN
1# Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com
2# This softare is released under the BSD License. See the COPYING file for
3# more information.
4
5set tcl_precision 17
ab72b483 6source tests/support/redis.tcl
7source tests/support/server.tcl
8source tests/support/tmpfile.tcl
9source tests/support/test.tcl
10source tests/support/util.tcl
98578b57 11
13566085 12set ::all_tests {
13 unit/printver
14 unit/auth
15 unit/protocol
16 unit/basic
17 unit/type/list
be9250c8 18 unit/type/list-2
6209797d 19 unit/type/list-3
13566085 20 unit/type/set
21 unit/type/zset
22 unit/type/hash
23 unit/sort
24 unit/expire
25 unit/other
26 unit/cas
27 unit/quit
570bbcf8 28 unit/aofrw
13566085 29 integration/replication
569f84aa 30 integration/replication-2
31 integration/replication-3
22c9c407 32 integration/replication-4
13566085 33 integration/aof
03116904 34 integration/rdb
c7937348 35 integration/convert-zipmap-hash-on-load
13566085 36 unit/pubsub
37 unit/slowlog
0681c5ad 38 unit/scripting
243b783f 39 unit/maxmemory
f4bddefe 40 unit/introspection
efc8f6c1 41 unit/obuf-limits
13566085 42}
43# Index to the next test to run in the ::all_tests list.
44set ::next_test 0
45
98578b57 46set ::host 127.0.0.1
24bfb570 47set ::port 21111
e59a64b8 48set ::traceleaks 0
c4669d25 49set ::valgrind 0
322ea972 50set ::verbose 0
38b957d8 51set ::quiet 0
6e0e5bed
PN
52set ::denytags {}
53set ::allowtags {}
7d04fc75 54set ::external 0; # If "1" this means, we are running against external instance
9f1ae9ab 55set ::file ""; # If set, runs only the tests in this comma separated list
6f8a32d5 56set ::curfile ""; # Hold the filename of the current suite
524d515f 57set ::accurate 0; # If true runs fuzz tests with more iterations
04e2410d 58set ::force_failure 0
13566085 59
60# Set to 1 when we are running in client mode. The Redis test uses a
61# server-client model to run tests simultaneously. The server instance
62# runs the specified number of client instances that will actually run tests.
63# The server is responsible of showing the result to the user, and exit with
64# the appropriate exit code depending on the test outcome.
65set ::client 0
66set ::numclients 16
98578b57
PN
67
68proc execute_tests name {
6f8a32d5
PN
69 set path "tests/$name.tcl"
70 set ::curfile $path
71 source $path
36e790a0 72 send_data_packet $::test_server_fd done "$name"
98578b57
PN
73}
74
1c4114be
PN
75# Setup a list to hold a stack of server configs. When calls to start_server
76# are nested, use "srv 0 pid" to get the pid of the inner server. To access
77# outer servers, use "srv -1 pid" etcetera.
78set ::servers {}
f2dd4769
PN
79proc srv {args} {
80 set level 0
81 if {[string is integer [lindex $args 0]]} {
82 set level [lindex $args 0]
83 set property [lindex $args 1]
84 } else {
85 set property [lindex $args 0]
86 }
1c4114be
PN
87 set srv [lindex $::servers end+$level]
88 dict get $srv $property
89}
90
91# Provide easy access to the client for the inner server. It's possible to
92# prepend the argument list with a negative level to access clients for
93# servers running in outer blocks.
98578b57 94proc r {args} {
1c4114be
PN
95 set level 0
96 if {[string is integer [lindex $args 0]]} {
97 set level [lindex $args 0]
98 set args [lrange $args 1 end]
99 }
100 [srv $level "client"] {*}$args
101}
102
941c9fa2
PN
103proc reconnect {args} {
104 set level [lindex $args 0]
105 if {[string length $level] == 0 || ![string is integer $level]} {
106 set level 0
107 }
108
109 set srv [lindex $::servers end+$level]
110 set host [dict get $srv "host"]
111 set port [dict get $srv "port"]
112 set config [dict get $srv "config"]
113 set client [redis $host $port]
114 dict set srv "client" $client
115
116 # select the right db when we don't have to authenticate
117 if {![dict exists $config "requirepass"]} {
118 $client select 9
119 }
120
121 # re-set $srv in the servers list
414c3dea 122 lset ::servers end+$level $srv
941c9fa2
PN
123}
124
5eedc9c6
PN
125proc redis_deferring_client {args} {
126 set level 0
127 if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
128 set level [lindex $args 0]
129 set args [lrange $args 1 end]
130 }
131
132 # create client that defers reading reply
133 set client [redis [srv $level "host"] [srv $level "port"] 1]
134
135 # select the right db and read the response (OK)
136 $client select 9
137 $client read
138 return $client
139}
140
1c4114be
PN
141# Provide easy access to INFO properties. Same semantic as "proc r".
142proc s {args} {
143 set level 0
144 if {[string is integer [lindex $args 0]]} {
145 set level [lindex $args 0]
146 set args [lrange $args 1 end]
147 }
148 status [srv $level "client"] [lindex $args 0]
98578b57
PN
149}
150
f166bb1d 151proc cleanup {} {
38b957d8 152 if {!$::quiet} {puts -nonewline "Cleanup: may take some time... "}
13566085 153 flush stdout
c4669d25 154 catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
155 catch {exec rm -rf {*}[glob tests/tmp/server.*]}
38b957d8 156 if {!$::quiet} {puts "OK"}
f166bb1d
PN
157}
158
24bfb570 159proc find_available_port start {
160 for {set j $start} {$j < $start+1024} {incr j} {
161 if {[catch {
dfcf5a0a 162 set fd [socket 127.0.0.1 $j]
24bfb570 163 }]} {
dfcf5a0a 164 return $j
24bfb570 165 } else {
166 close $fd
167 }
168 }
169 if {$j == $start+1024} {
170 error "Can't find a non busy port in the $start-[expr {$start+1023}] range."
171 }
172}
173
13566085 174proc test_server_main {} {
9f1ae9ab 175 cleanup
13566085 176 # Open a listening socket, trying different ports in order to find a
177 # non busy one.
24bfb570 178 set port [find_available_port 11111]
38b957d8 179 if {!$::quiet} {
180 puts "Starting test server at port $port"
181 }
24bfb570 182 socket -server accept_test_clients $port
3fe40d6e 183
13566085 184 # Start the client instances
569f84aa 185 set ::clients_pids {}
24bfb570 186 set start_port [expr {$::port+100}]
13566085 187 for {set j 0} {$j < $::numclients} {incr j} {
24bfb570 188 set start_port [find_available_port $start_port]
569f84aa 189 set p [exec tclsh8.5 [info script] {*}$::argv \
24bfb570 190 --client $port --port $start_port &]
569f84aa 191 lappend ::clients_pids $p
24bfb570 192 incr start_port 10
13566085 193 }
9f1ae9ab 194
13566085 195 # Setup global state for the test server
196 set ::idle_clients {}
197 set ::active_clients {}
36e790a0 198 array set ::clients_start_time {}
199 set ::clients_time_history {}
04e2410d 200 set ::failed_tests {}
13566085 201
202 # Enter the event loop to handle clients I/O
203 after 100 test_server_cron
204 vwait forever
205}
206
207# This function gets called 10 times per second, for now does nothing but
208# may be used in the future in order to detect test clients taking too much
209# time to execute the task.
210proc test_server_cron {} {
211}
212
213proc accept_test_clients {fd addr port} {
214 fileevent $fd readable [list read_from_test_client $fd]
215}
216
217# This is the readable handler of our test server. Clients send us messages
218# in the form of a status code such and additional data. Supported
219# status types are:
220#
221# ready: the client is ready to execute the command. Only sent at client
222# startup. The server will queue the client FD in the list of idle
223# clients.
224# testing: just used to signal that a given test started.
225# ok: a test was executed with success.
226# err: a test was executed with an error.
227# exception: there was a runtime exception while executing the test.
228# done: all the specified test file was processed, this test client is
229# ready to accept a new task.
230proc read_from_test_client fd {
231 set bytes [gets $fd]
232 set payload [read $fd $bytes]
233 foreach {status data} $payload break
13566085 234 if {$status eq {ready}} {
38b957d8 235 if {!$::quiet} {
236 puts "\[$status\]: $data"
237 }
13566085 238 signal_idle_client $fd
239 } elseif {$status eq {done}} {
36e790a0 240 set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}]
38b957d8 241 set all_tests_count [llength $::all_tests]
242 set running_tests_count [expr {[llength $::active_clients]-1}]
243 set completed_tests_count [expr {$::next_test-$running_tests_count}]
244 puts "\[$completed_tests_count/$all_tests_count [colorstr yellow $status]\]: $data ($elapsed seconds)"
36e790a0 245 lappend ::clients_time_history $elapsed $data
13566085 246 signal_idle_client $fd
3744824c 247 } elseif {$status eq {ok}} {
38b957d8 248 if {!$::quiet} {
249 puts "\[[colorstr green $status]\]: $data"
250 }
3744824c 251 } elseif {$status eq {err}} {
04e2410d 252 set err "\[[colorstr red $status]\]: $data"
253 puts $err
254 lappend ::failed_tests $err
569f84aa 255 } elseif {$status eq {exception}} {
256 puts "\[[colorstr red $status]\]: $data"
257 foreach p $::clients_pids {
258 catch {exec kill -9 $p}
9f1ae9ab 259 }
569f84aa 260 exit 1
daab1599 261 } elseif {$status eq {testing}} {
262 # No op
9f1ae9ab 263 } else {
38b957d8 264 if {!$::quiet} {
265 puts "\[$status\]: $data"
266 }
9f1ae9ab 267 }
13566085 268}
e39c8b50 269
13566085 270# A new client is idle. Remove it from the list of active clients and
271# if there are still test units to run, launch them.
272proc signal_idle_client fd {
273 # Remove this fd from the list of active clients.
274 set ::active_clients \
275 [lsearch -all -inline -not -exact $::active_clients $fd]
276 # New unit to process?
277 if {$::next_test != [llength $::all_tests]} {
38b957d8 278 if {!$::quiet} {
279 puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"]
280 }
36e790a0 281 set ::clients_start_time($fd) [clock seconds]
13566085 282 send_data_packet $fd run [lindex $::all_tests $::next_test]
283 lappend ::active_clients $fd
284 incr ::next_test
9f1ae9ab 285 } else {
13566085 286 lappend ::idle_clients $fd
287 if {[llength $::active_clients] == 0} {
288 the_end
6f8a32d5 289 }
9f1ae9ab 290 }
13566085 291}
6f8a32d5 292
13566085 293# The the_end funciton gets called when all the test units were already
294# executed, so the test finished.
295proc the_end {} {
296 # TODO: print the status, exit with the rigth exit code.
04e2410d 297 puts "\n The End\n"
36e790a0 298 puts "Execution time of different units:"
299 foreach {time name} $::clients_time_history {
300 puts " $time seconds - $name"
301 }
04e2410d 302 if {[llength $::failed_tests]} {
121ffc85 303 puts "\n[colorstr bold-red {!!! WARNING}] The following tests failed:\n"
04e2410d 304 foreach failed $::failed_tests {
305 puts "*** $failed"
306 }
c7c16a32 307 cleanup
e39c8b50 308 exit 1
04e2410d 309 } else {
310 puts "\n[colorstr bold-white {\o/}] [colorstr bold-green {All tests passed without errors!}]\n"
c7c16a32 311 cleanup
04e2410d 312 exit 0
98578b57 313 }
98578b57
PN
314}
315
13566085 316# The client is not even driven (the test server is instead) as we just need
317# to read the command, execute, reply... all this in a loop.
318proc test_client_main server_port {
319 set ::test_server_fd [socket localhost $server_port]
320 send_data_packet $::test_server_fd ready [pid]
321 while 1 {
322 set bytes [gets $::test_server_fd]
323 set payload [read $::test_server_fd $bytes]
324 foreach {cmd data} $payload break
325 if {$cmd eq {run}} {
326 execute_tests $data
327 } else {
328 error "Unknown test client command: $cmd"
6f8a32d5 329 }
98578b57 330 }
13566085 331}
cabe03eb 332
13566085 333proc send_data_packet {fd status data} {
334 set payload [list $status $data]
335 puts $fd [string length $payload]
336 puts -nonewline $fd $payload
337 flush $fd
98578b57
PN
338}
339
e4715f00 340proc print_help_screen {} {
341 puts [join {
342 "--valgrind Run the test over valgrind."
343 "--accurate Run slow randomized tests for more iterations."
38b957d8 344 "--quiet Don't show individual tests."
e4715f00 345 "--single <unit> Just execute the specified unit (see next option)."
346 "--list-tests List all the available test units."
347 "--force-failure Force the execution of a test that always fails."
348 "--help Print this help screen."
349 } "\n"]
350}
351
73bd6c58
PN
352# parse arguments
353for {set j 0} {$j < [llength $argv]} {incr j} {
354 set opt [lindex $argv $j]
355 set arg [lindex $argv [expr $j+1]]
356 if {$opt eq {--tags}} {
357 foreach tag $arg {
358 if {[string index $tag 0] eq "-"} {
359 lappend ::denytags [string range $tag 1 end]
360 } else {
361 lappend ::allowtags $tag
362 }
363 }
364 incr j
4b918769 365 } elseif {$opt eq {--valgrind}} {
366 set ::valgrind 1
38b957d8 367 } elseif {$opt eq {--quiet}} {
368 set ::quiet 1
7d04fc75 369 } elseif {$opt eq {--host}} {
370 set ::external 1
371 set ::host $arg
372 incr j
373 } elseif {$opt eq {--port}} {
374 set ::port $arg
375 incr j
524d515f 376 } elseif {$opt eq {--accurate}} {
377 set ::accurate 1
04e2410d 378 } elseif {$opt eq {--force-failure}} {
379 set ::force_failure 1
524d515f 380 } elseif {$opt eq {--single}} {
381 set ::all_tests $arg
382 incr j
383 } elseif {$opt eq {--list-tests}} {
384 foreach t $::all_tests {
385 puts $t
386 }
387 exit 0
13566085 388 } elseif {$opt eq {--client}} {
389 set ::client 1
390 set ::test_server_port $arg
391 incr j
524d515f 392 } elseif {$opt eq {--help}} {
e4715f00 393 print_help_screen
524d515f 394 exit 0
73bd6c58
PN
395 } else {
396 puts "Wrong argument: $opt"
397 exit 1
398 }
399}
400
13566085 401if {$::client} {
402 if {[catch { test_client_main $::test_server_port } err]} {
403 set estr "Executing test client: $err.\n$::errorInfo"
404 if {[catch {send_data_packet $::test_server_fd exception $estr}]} {
405 puts $estr
436f18b6
PN
406 }
407 exit 1
408 }
13566085 409} else {
410 if {[catch { test_server_main } err]} {
411 if {[string length $err] > 0} {
412 # only display error when not generated by the test suite
413 if {$err ne "exception"} {
414 puts $::errorInfo
415 }
416 exit 1
417 }
418 }
436f18b6 419}