]> git.saurik.com Git - redis.git/blob - tests/test_helper.tcl
valgrind suppression file added
[redis.git] / tests / test_helper.tcl
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
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
12 set ::host 127.0.0.1
13 set ::port 16379
14 set ::traceleaks 0
15 set ::valgrind 0
16 set ::denytags {}
17 set ::allowtags {}
18 set ::external 0; # If "1" this means, we are running against external instance
19 set ::file ""; # If set, runs only the tests in this comma separated list
20
21 proc execute_tests name {
22 source "tests/$name.tcl"
23 }
24
25 # Setup a list to hold a stack of server configs. When calls to start_server
26 # are nested, use "srv 0 pid" to get the pid of the inner server. To access
27 # outer servers, use "srv -1 pid" etcetera.
28 set ::servers {}
29 proc srv {args} {
30 set level 0
31 if {[string is integer [lindex $args 0]]} {
32 set level [lindex $args 0]
33 set property [lindex $args 1]
34 } else {
35 set property [lindex $args 0]
36 }
37 set srv [lindex $::servers end+$level]
38 dict get $srv $property
39 }
40
41 # Provide easy access to the client for the inner server. It's possible to
42 # prepend the argument list with a negative level to access clients for
43 # servers running in outer blocks.
44 proc r {args} {
45 set level 0
46 if {[string is integer [lindex $args 0]]} {
47 set level [lindex $args 0]
48 set args [lrange $args 1 end]
49 }
50 [srv $level "client"] {*}$args
51 }
52
53 proc reconnect {args} {
54 set level [lindex $args 0]
55 if {[string length $level] == 0 || ![string is integer $level]} {
56 set level 0
57 }
58
59 set srv [lindex $::servers end+$level]
60 set host [dict get $srv "host"]
61 set port [dict get $srv "port"]
62 set config [dict get $srv "config"]
63 set client [redis $host $port]
64 dict set srv "client" $client
65
66 # select the right db when we don't have to authenticate
67 if {![dict exists $config "requirepass"]} {
68 $client select 9
69 }
70
71 # re-set $srv in the servers list
72 set ::servers [lreplace $::servers end+$level 1 $srv]
73 }
74
75 proc redis_deferring_client {args} {
76 set level 0
77 if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
78 set level [lindex $args 0]
79 set args [lrange $args 1 end]
80 }
81
82 # create client that defers reading reply
83 set client [redis [srv $level "host"] [srv $level "port"] 1]
84
85 # select the right db and read the response (OK)
86 $client select 9
87 $client read
88 return $client
89 }
90
91 # Provide easy access to INFO properties. Same semantic as "proc r".
92 proc s {args} {
93 set level 0
94 if {[string is integer [lindex $args 0]]} {
95 set level [lindex $args 0]
96 set args [lrange $args 1 end]
97 }
98 status [srv $level "client"] [lindex $args 0]
99 }
100
101 proc cleanup {} {
102 catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
103 catch {exec rm -rf {*}[glob tests/tmp/server.*]}
104 }
105
106 proc execute_everything {} {
107 execute_tests "unit/auth"
108 execute_tests "unit/protocol"
109 execute_tests "unit/basic"
110 execute_tests "unit/type/list"
111 execute_tests "unit/type/set"
112 execute_tests "unit/type/zset"
113 execute_tests "unit/type/hash"
114 execute_tests "unit/sort"
115 execute_tests "unit/expire"
116 execute_tests "unit/other"
117 execute_tests "unit/cas"
118 execute_tests "unit/quit"
119 execute_tests "integration/replication"
120 execute_tests "integration/aof"
121 # execute_tests "integration/redis-cli"
122 execute_tests "unit/pubsub"
123
124 # run tests with VM enabled
125 set ::global_overrides {vm-enabled yes}
126 execute_tests "unit/protocol"
127 execute_tests "unit/basic"
128 execute_tests "unit/type/list"
129 execute_tests "unit/type/set"
130 execute_tests "unit/type/zset"
131 execute_tests "unit/type/hash"
132 execute_tests "unit/sort"
133 execute_tests "unit/expire"
134 execute_tests "unit/other"
135 execute_tests "unit/cas"
136 }
137
138 proc main {} {
139 cleanup
140
141 if {[string length $::file] > 0} {
142 foreach {file} [split $::file ,] {
143 execute_tests $file
144 }
145 } else {
146 execute_everything
147 }
148
149 cleanup
150 puts "\n[expr $::passed+$::failed] tests, $::passed passed, $::failed failed"
151 if {$::failed > 0} {
152 puts "\n*** WARNING!!! $::failed FAILED TESTS ***\n"
153 exit 1
154 }
155 }
156
157 # parse arguments
158 for {set j 0} {$j < [llength $argv]} {incr j} {
159 set opt [lindex $argv $j]
160 set arg [lindex $argv [expr $j+1]]
161 if {$opt eq {--tags}} {
162 foreach tag $arg {
163 if {[string index $tag 0] eq "-"} {
164 lappend ::denytags [string range $tag 1 end]
165 } else {
166 lappend ::allowtags $tag
167 }
168 }
169 incr j
170 } elseif {$opt eq {--file}} {
171 set ::file $arg
172 incr j
173 } elseif {$opt eq {--host}} {
174 set ::external 1
175 set ::host $arg
176 incr j
177 } elseif {$opt eq {--port}} {
178 set ::port $arg
179 incr j
180 } else {
181 puts "Wrong argument: $opt"
182 exit 1
183 }
184 }
185
186 if {[catch { main } err]} {
187 if {[string length $err] > 0} {
188 # only display error when not generated by the test suite
189 if {$err ne "exception"} {
190 puts $err
191 }
192 exit 1
193 }
194 }