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