]> git.saurik.com Git - redis.git/blame - tests/support/test.tcl
New commands: BITOP and BITCOUNT.
[redis.git] / tests / support / test.tcl
CommitLineData
6f8a32d5
PN
1set ::num_tests 0
2set ::num_passed 0
3set ::num_failed 0
4set ::tests_failed {}
98578b57 5
5080e625 6proc fail {msg} {
7 error "assertion:$msg"
8}
9
c2ff0e90 10proc assert {condition} {
414c3dea 11 if {![uplevel 1 [list expr $condition]]} {
202e3091 12 error "assertion:Expected condition '$condition' to be true ([uplevel 1 [list subst -nocommands $condition]])"
c2ff0e90
PN
13 }
14}
15
d4507ec6
PN
16proc assert_match {pattern value} {
17 if {![string match $pattern $value]} {
6f8a32d5 18 error "assertion:Expected '$value' to match '$pattern'"
d4507ec6
PN
19 }
20}
21
22proc assert_equal {expected value} {
23 if {$expected ne $value} {
6f8a32d5 24 error "assertion:Expected '$value' to be equal to '$expected'"
d4507ec6
PN
25 }
26}
27
28proc assert_error {pattern code} {
5eedc9c6 29 if {[catch {uplevel 1 $code} error]} {
d4507ec6
PN
30 assert_match $pattern $error
31 } else {
6f8a32d5 32 error "assertion:Expected an error but nothing was catched"
d4507ec6
PN
33 }
34}
35
36proc assert_encoding {enc key} {
86d39249
PN
37 # Swapped out values don't have an encoding, so make sure that
38 # the value is swapped in before checking the encoding.
39 set dbg [r debug object $key]
68254919
PN
40 while {[string match "* swapped at:*" $dbg]} {
41 r debug swapin $key
86d39249
PN
42 set dbg [r debug object $key]
43 }
44 assert_match "* encoding:$enc *" $dbg
d4507ec6
PN
45}
46
47proc assert_type {type key} {
48 assert_equal $type [r type $key]
49}
50
5080e625 51# Wait for the specified condition to be true, with the specified number of
52# max retries and delay between retries. Otherwise the 'elsescript' is
53# executed.
54proc wait_for_condition {maxtries delay e _else_ elsescript} {
55 while {[incr maxtries -1] >= 0} {
28ccb530 56 if {[uplevel 1 [list expr $e]]} break
5080e625 57 after $delay
58 }
59 if {$maxtries == -1} {
60 uplevel 1 $elsescript
61 }
62}
63
4a67d194 64# Test if TERM looks like to support colors
65proc color_term {} {
66 expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]}
67}
68
3744824c 69proc colorstr {color str} {
4a67d194 70 if {[color_term]} {
82e5dd35 71 set b 0
72 if {[string range $color 0 4] eq {bold-}} {
73 set b 1
74 set color [string range $color 5 end]
75 }
3744824c 76 switch $color {
77 red {set colorcode {31}}
78 green {set colorcode {32}}
79 yellow {set colorcode {33}}
80 blue {set colorcode {34}}
81 magenta {set colorcode {35}}
82 cyan {set colorcode {36}}
82e5dd35 83 white {set colorcode {37}}
84 default {set colorcode {37}}
eae9cce1 85 }
86 if {$colorcode ne {}} {
82e5dd35 87 return "\033\[$b;${colorcode};40m$str\033\[0m"
eae9cce1 88 }
89 } else {
3744824c 90 return $str
eae9cce1 91 }
92}
93
6f8a32d5 94proc test {name code {okpattern undefined}} {
6e0e5bed
PN
95 # abort if tagged with a tag to deny
96 foreach tag $::denytags {
97 if {[lsearch $::tags $tag] >= 0} {
98 return
99 }
100 }
101
102 # check if tagged with at least 1 tag to allow when there *is* a list
103 # of tags to allow, because default policy is to run everything
104 if {[llength $::allowtags] > 0} {
105 set matched 0
106 foreach tag $::allowtags {
73bd6c58 107 if {[lsearch $::tags $tag] >= 0} {
6e0e5bed
PN
108 incr matched
109 }
110 }
111 if {$matched < 1} {
112 return
113 }
114 }
115
6f8a32d5
PN
116 incr ::num_tests
117 set details {}
121ffc85 118 lappend details "$name in $::curfile"
6f8a32d5 119
13566085 120 send_data_packet $::test_server_fd testing $name
6f8a32d5 121
fdfb02e7 122 if {[catch {set retval [uplevel 1 $code]} error]} {
6f8a32d5
PN
123 if {[string match "assertion:*" $error]} {
124 set msg [string range $error 10 end]
125 lappend details $msg
126 lappend ::tests_failed $details
127
128 incr ::num_failed
121ffc85 129 send_data_packet $::test_server_fd err [join $details "\n"]
d4507ec6 130 } else {
6f8a32d5
PN
131 # Re-raise, let handler up the stack take care of this.
132 error $error $::errorInfo
d4507ec6 133 }
98578b57 134 } else {
6f8a32d5
PN
135 if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
136 incr ::num_passed
13566085 137 send_data_packet $::test_server_fd ok $name
d4507ec6 138 } else {
6f8a32d5
PN
139 set msg "Expected '$okpattern' to equal or match '$retval'"
140 lappend details $msg
141 lappend ::tests_failed $details
142
143 incr ::num_failed
121ffc85 144 send_data_packet $::test_server_fd err [join $details "\n"]
d4507ec6 145 }
98578b57 146 }
6f8a32d5 147
98578b57 148 if {$::traceleaks} {
5b12b47d
PN
149 set output [exec leaks redis-server]
150 if {![string match {*0 leaks*} $output]} {
13566085 151 send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
98578b57
PN
152 }
153 }
154}