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