]>
Commit | Line | Data |
---|---|---|
1 | set ::num_tests 0 | |
2 | set ::num_passed 0 | |
3 | set ::num_failed 0 | |
4 | set ::tests_failed {} | |
5 | ||
6 | proc assert {condition} { | |
7 | if {![uplevel 1 expr $condition]} { | |
8 | error "assertion:Expected condition '$condition' to be true ([uplevel 1 [list subst -nocommands $condition]])" | |
9 | } | |
10 | } | |
11 | ||
12 | proc assert_match {pattern value} { | |
13 | if {![string match $pattern $value]} { | |
14 | error "assertion:Expected '$value' to match '$pattern'" | |
15 | } | |
16 | } | |
17 | ||
18 | proc assert_equal {expected value} { | |
19 | if {$expected ne $value} { | |
20 | error "assertion:Expected '$value' to be equal to '$expected'" | |
21 | } | |
22 | } | |
23 | ||
24 | proc assert_error {pattern code} { | |
25 | if {[catch {uplevel 1 $code} error]} { | |
26 | assert_match $pattern $error | |
27 | } else { | |
28 | error "assertion:Expected an error but nothing was catched" | |
29 | } | |
30 | } | |
31 | ||
32 | proc assert_encoding {enc key} { | |
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] | |
36 | while {[string match "* swapped at:*" $dbg]} { | |
37 | r debug swapin $key | |
38 | set dbg [r debug object $key] | |
39 | } | |
40 | assert_match "* encoding:$enc *" $dbg | |
41 | } | |
42 | ||
43 | proc assert_type {type key} { | |
44 | assert_equal $type [r type $key] | |
45 | } | |
46 | ||
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 | ||
52 | proc colorstr {color str} { | |
53 | if {[color_term]} { | |
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 | } | |
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}} | |
66 | white {set colorcode {37}} | |
67 | default {set colorcode {37}} | |
68 | } | |
69 | if {$colorcode ne {}} { | |
70 | return "\033\[$b;${colorcode};40m$str\033\[0m" | |
71 | } | |
72 | } else { | |
73 | return $str | |
74 | } | |
75 | } | |
76 | ||
77 | proc test {name code {okpattern undefined}} { | |
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 { | |
90 | if {[lsearch $::tags $tag] >= 0} { | |
91 | incr matched | |
92 | } | |
93 | } | |
94 | if {$matched < 1} { | |
95 | return | |
96 | } | |
97 | } | |
98 | ||
99 | incr ::num_tests | |
100 | set details {} | |
101 | lappend details "$name in $::curfile" | |
102 | ||
103 | send_data_packet $::test_server_fd testing $name | |
104 | ||
105 | if {[catch {set retval [uplevel 1 $code]} error]} { | |
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 | |
112 | send_data_packet $::test_server_fd err [join $details "\n"] | |
113 | } else { | |
114 | # Re-raise, let handler up the stack take care of this. | |
115 | error $error $::errorInfo | |
116 | } | |
117 | } else { | |
118 | if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} { | |
119 | incr ::num_passed | |
120 | send_data_packet $::test_server_fd ok $name | |
121 | } else { | |
122 | set msg "Expected '$okpattern' to equal or match '$retval'" | |
123 | lappend details $msg | |
124 | lappend ::tests_failed $details | |
125 | ||
126 | incr ::num_failed | |
127 | send_data_packet $::test_server_fd err [join $details "\n"] | |
128 | } | |
129 | } | |
130 | ||
131 | if {$::traceleaks} { | |
132 | set output [exec leaks redis-server] | |
133 | if {![string match {*0 leaks*} $output]} { | |
134 | send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output" | |
135 | } | |
136 | } | |
137 | } |