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