aboutsummaryrefslogtreecommitdiff
path: root/examples/redis-unstable/tests/support
diff options
context:
space:
mode:
authorMitja Felicijan <mitja.felicijan@gmail.com>2026-01-21 22:52:54 +0100
committerMitja Felicijan <mitja.felicijan@gmail.com>2026-01-21 22:52:54 +0100
commitdcacc00e3750300617ba6e16eb346713f91a783a (patch)
tree38e2d4fb5ed9d119711d4295c6eda4b014af73fd /examples/redis-unstable/tests/support
parent58dac10aeb8f5a041c46bddbeaf4c7966a99b998 (diff)
downloadcrep-dcacc00e3750300617ba6e16eb346713f91a783a.tar.gz
Remove testing data
Diffstat (limited to 'examples/redis-unstable/tests/support')
-rw-r--r--examples/redis-unstable/tests/support/aofmanifest.tcl173
-rw-r--r--examples/redis-unstable/tests/support/benchmark.tcl33
-rw-r--r--examples/redis-unstable/tests/support/cli.tcl36
-rw-r--r--examples/redis-unstable/tests/support/cluster.tcl372
-rw-r--r--examples/redis-unstable/tests/support/cluster_util.tcl264
-rw-r--r--examples/redis-unstable/tests/support/redis.tcl471
-rw-r--r--examples/redis-unstable/tests/support/response_transformers.tcl110
-rw-r--r--examples/redis-unstable/tests/support/server.tcl850
-rw-r--r--examples/redis-unstable/tests/support/test.tcl280
-rw-r--r--examples/redis-unstable/tests/support/tmpfile.tcl15
-rw-r--r--examples/redis-unstable/tests/support/util.tcl1288
11 files changed, 0 insertions, 3892 deletions
diff --git a/examples/redis-unstable/tests/support/aofmanifest.tcl b/examples/redis-unstable/tests/support/aofmanifest.tcl
deleted file mode 100644
index 68eed03..0000000
--- a/examples/redis-unstable/tests/support/aofmanifest.tcl
+++ /dev/null
@@ -1,173 +0,0 @@
1set ::base_aof_sufix ".base"
2set ::incr_aof_sufix ".incr"
3set ::manifest_suffix ".manifest"
4set ::aof_format_suffix ".aof"
5set ::rdb_format_suffix ".rdb"
6
7proc get_full_path {dir filename} {
8 set _ [format "%s/%s" $dir $filename]
9}
10
11proc join_path {dir1 dir2} {
12 return [format "%s/%s" $dir1 $dir2]
13}
14
15proc get_redis_dir {} {
16 set config [srv config]
17 set _ [dict get $config "dir"]
18}
19
20proc check_file_exist {dir filename} {
21 set file_path [get_full_path $dir $filename]
22 return [file exists $file_path]
23}
24
25proc del_file {dir filename} {
26 set file_path [get_full_path $dir $filename]
27 catch {exec rm -rf $file_path}
28}
29
30proc get_cur_base_aof_name {manifest_filepath} {
31 set fp [open $manifest_filepath r+]
32 set lines {}
33 while {1} {
34 set line [gets $fp]
35 if {[eof $fp]} {
36 close $fp
37 break;
38 }
39
40 lappend lines $line
41 }
42
43 if {[llength $lines] == 0} {
44 return ""
45 }
46
47 set first_line [lindex $lines 0]
48 set aofname [lindex [split $first_line " "] 1]
49 set aoftype [lindex [split $first_line " "] 5]
50 if { $aoftype eq "b" } {
51 return $aofname
52 }
53
54 return ""
55}
56
57proc get_last_incr_aof_name {manifest_filepath} {
58 set fp [open $manifest_filepath r+]
59 set lines {}
60 while {1} {
61 set line [gets $fp]
62 if {[eof $fp]} {
63 close $fp
64 break;
65 }
66
67 lappend lines $line
68 }
69
70 if {[llength $lines] == 0} {
71 return ""
72 }
73
74 set len [llength $lines]
75 set last_line [lindex $lines [expr $len - 1]]
76 set aofname [lindex [split $last_line " "] 1]
77 set aoftype [lindex [split $last_line " "] 5]
78 if { $aoftype eq "i" } {
79 return $aofname
80 }
81
82 return ""
83}
84
85proc get_last_incr_aof_path {r} {
86 set dir [lindex [$r config get dir] 1]
87 set appenddirname [lindex [$r config get appenddirname] 1]
88 set appendfilename [lindex [$r config get appendfilename] 1]
89 set manifest_filepath [file join $dir $appenddirname $appendfilename$::manifest_suffix]
90 set last_incr_aof_name [get_last_incr_aof_name $manifest_filepath]
91 if {$last_incr_aof_name == ""} {
92 return ""
93 }
94 return [file join $dir $appenddirname $last_incr_aof_name]
95}
96
97proc get_base_aof_path {r} {
98 set dir [lindex [$r config get dir] 1]
99 set appenddirname [lindex [$r config get appenddirname] 1]
100 set appendfilename [lindex [$r config get appendfilename] 1]
101 set manifest_filepath [file join $dir $appenddirname $appendfilename$::manifest_suffix]
102 set cur_base_aof_name [get_cur_base_aof_name $manifest_filepath]
103 if {$cur_base_aof_name == ""} {
104 return ""
105 }
106 return [file join $dir $appenddirname $cur_base_aof_name]
107}
108
109proc assert_aof_manifest_content {manifest_path content} {
110 set fp [open $manifest_path r+]
111 set lines {}
112 while {1} {
113 set line [gets $fp]
114 if {[eof $fp]} {
115 close $fp
116 break;
117 }
118
119 lappend lines $line
120 }
121
122 assert_equal [llength $lines] [llength $content]
123
124 for { set i 0 } { $i < [llength $lines] } {incr i} {
125 assert {[string first [lindex $content $i] [lindex $lines $i]] != -1}
126 }
127}
128
129proc clean_aof_persistence {aof_dirpath} {
130 catch {eval exec rm -rf [glob $aof_dirpath]}
131}
132
133proc append_to_manifest {str} {
134 upvar fp fp
135 puts -nonewline $fp $str
136}
137
138proc create_aof_manifest {dir aof_manifest_file code} {
139 create_aof_dir $dir
140 upvar fp fp
141 set fp [open $aof_manifest_file w+]
142 uplevel 1 $code
143 close $fp
144}
145
146proc append_to_aof {str} {
147 upvar fp fp
148 puts -nonewline $fp $str
149}
150
151proc create_aof {dir aof_file code} {
152 create_aof_dir $dir
153 upvar fp fp
154 set fp [open $aof_file w+]
155 uplevel 1 $code
156 close $fp
157}
158
159proc create_aof_dir {dir_path} {
160 file mkdir $dir_path
161}
162
163proc start_server_aof {overrides code} {
164 upvar defaults defaults srv srv server_path server_path aof_basename aof_basename aof_dirpath aof_dirpath aof_manifest_file aof_manifest_file aof_manifest_file2 aof_manifest_file2
165 set config [concat $defaults $overrides]
166 start_server [list overrides $config keep_persistence true] $code
167}
168
169proc start_server_aof_ex {overrides options code} {
170 upvar defaults defaults srv srv server_path server_path
171 set config [concat $defaults $overrides]
172 start_server [concat [list overrides $config keep_persistence true] $options] $code
173}
diff --git a/examples/redis-unstable/tests/support/benchmark.tcl b/examples/redis-unstable/tests/support/benchmark.tcl
deleted file mode 100644
index 156b205..0000000
--- a/examples/redis-unstable/tests/support/benchmark.tcl
+++ /dev/null
@@ -1,33 +0,0 @@
1proc redisbenchmark_tls_config {testsdir} {
2 set tlsdir [file join $testsdir tls]
3 set cert [file join $tlsdir client.crt]
4 set key [file join $tlsdir client.key]
5 set cacert [file join $tlsdir ca.crt]
6
7 if {$::tls} {
8 return [list --tls --cert $cert --key $key --cacert $cacert]
9 } else {
10 return {}
11 }
12}
13
14proc redisbenchmark {host port {opts {}}} {
15 set cmd [list src/redis-benchmark -h $host -p $port]
16 lappend cmd {*}[redisbenchmark_tls_config "tests"]
17 lappend cmd {*}$opts
18 return $cmd
19}
20
21proc redisbenchmarkuri {host port {opts {}}} {
22 set cmd [list src/redis-benchmark -u redis://$host:$port]
23 lappend cmd {*}[redisbenchmark_tls_config "tests"]
24 lappend cmd {*}$opts
25 return $cmd
26}
27
28proc redisbenchmarkuriuserpass {host port user pass {opts {}}} {
29 set cmd [list src/redis-benchmark -u redis://$user:$pass@$host:$port]
30 lappend cmd {*}[redisbenchmark_tls_config "tests"]
31 lappend cmd {*}$opts
32 return $cmd
33}
diff --git a/examples/redis-unstable/tests/support/cli.tcl b/examples/redis-unstable/tests/support/cli.tcl
deleted file mode 100644
index a080823..0000000
--- a/examples/redis-unstable/tests/support/cli.tcl
+++ /dev/null
@@ -1,36 +0,0 @@
1proc rediscli_tls_config {testsdir} {
2 set tlsdir [file join $testsdir tls]
3 set cert [file join $tlsdir client.crt]
4 set key [file join $tlsdir client.key]
5 set cacert [file join $tlsdir ca.crt]
6
7 if {$::tls} {
8 return [list --tls --cert $cert --key $key --cacert $cacert]
9 } else {
10 return {}
11 }
12}
13
14# Returns command line for executing redis-cli
15proc rediscli {host port {opts {}}} {
16 set cmd [list src/redis-cli -h $host -p $port]
17 lappend cmd {*}[rediscli_tls_config "tests"]
18 lappend cmd {*}$opts
19 return $cmd
20}
21
22# Returns command line for executing redis-cli with a unix socket address
23proc rediscli_unixsocket {unixsocket {opts {}}} {
24 return [list src/redis-cli -s $unixsocket {*}$opts]
25}
26
27# Run redis-cli with specified args on the server of specified level.
28# Returns output broken down into individual lines.
29proc rediscli_exec {level args} {
30 set cmd [rediscli_unixsocket [srv $level unixsocket] $args]
31 set fd [open "|$cmd" "r"]
32 set ret [lrange [split [read $fd] "\n"] 0 end-1]
33 close $fd
34
35 return $ret
36}
diff --git a/examples/redis-unstable/tests/support/cluster.tcl b/examples/redis-unstable/tests/support/cluster.tcl
deleted file mode 100644
index 3a66684..0000000
--- a/examples/redis-unstable/tests/support/cluster.tcl
+++ /dev/null
@@ -1,372 +0,0 @@
1# Tcl redis cluster client as a wrapper of redis.rb.
2#
3# Copyright (C) 2014-Present, Redis Ltd.
4# All Rights reserved.
5#
6# Licensed under your choice of (a) the Redis Source Available License 2.0
7# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the
8# GNU Affero General Public License v3 (AGPLv3).
9#
10# Example usage:
11#
12# set c [redis_cluster {127.0.0.1:6379 127.0.0.1:6380}]
13# $c set foo
14# $c get foo
15# $c close
16
17package require Tcl 8.5
18package provide redis_cluster 0.1
19
20namespace eval redis_cluster {}
21set ::redis_cluster::internal_id 0
22set ::redis_cluster::id 0
23array set ::redis_cluster::startup_nodes {}
24array set ::redis_cluster::nodes {}
25array set ::redis_cluster::slots {}
26array set ::redis_cluster::tls {}
27
28# List of "plain" commands, which are commands where the sole key is always
29# the first argument.
30set ::redis_cluster::plain_commands {
31 get set setnx setex psetex append strlen exists setbit getbit
32 setrange getrange substr incr decr rpush lpush rpushx lpushx
33 linsert rpop lpop brpop llen lindex lset lrange ltrim lrem
34 sadd srem sismember smismember scard spop srandmember smembers sscan zadd
35 zincrby zrem zremrangebyscore zremrangebyrank zremrangebylex zrange
36 zrangebyscore zrevrangebyscore zrangebylex zrevrangebylex zcount
37 zlexcount zrevrange zcard zscore zmscore zrank zrevrank zscan hset hsetnx
38 hget hmset hmget hincrby hincrbyfloat hdel hlen hkeys hvals
39 hgetall hexists hscan incrby decrby incrbyfloat getset move
40 expire expireat pexpire pexpireat type ttl pttl persist restore
41 dump bitcount bitpos pfadd pfcount cluster ssubscribe spublish
42 sunsubscribe
43}
44
45# Create a cluster client. The nodes are given as a list of host:port. The TLS
46# parameter (1 or 0) is optional and defaults to the global $::tls.
47proc redis_cluster {nodes {tls -1}} {
48 set id [incr ::redis_cluster::id]
49 set ::redis_cluster::startup_nodes($id) $nodes
50 set ::redis_cluster::nodes($id) {}
51 set ::redis_cluster::slots($id) {}
52 set ::redis_cluster::tls($id) [expr $tls == -1 ? $::tls : $tls]
53 set handle [interp alias {} ::redis_cluster::instance$id {} ::redis_cluster::__dispatch__ $id]
54 $handle refresh_nodes_map
55 return $handle
56}
57
58# Totally reset the slots / nodes state for the client, calls
59# CLUSTER NODES in the first startup node available, populates the
60# list of nodes ::redis_cluster::nodes($id) with an hash mapping node
61# ip:port to a representation of the node (another hash), and finally
62# maps ::redis_cluster::slots($id) with an hash mapping slot numbers
63# to node IDs.
64#
65# This function is called when a new Redis Cluster client is initialized
66# and every time we get a -MOVED redirection error.
67proc ::redis_cluster::__method__refresh_nodes_map {id} {
68 # Contact the first responding startup node.
69 set idx 0; # Index of the node that will respond.
70 set errmsg {}
71 foreach start_node $::redis_cluster::startup_nodes($id) {
72 set ip_port [lindex [split $start_node @] 0]
73 lassign [split $ip_port :] start_host start_port
74 set tls $::redis_cluster::tls($id)
75 if {[catch {
76 set r {}
77 set r [redis $start_host $start_port 0 $tls]
78 set nodes_descr [$r cluster nodes]
79 $r close
80 } e]} {
81 if {$r ne {}} {catch {$r close}}
82 incr idx
83 if {[string length $errmsg] < 200} {
84 append errmsg " $ip_port: $e"
85 }
86 continue ; # Try next.
87 } else {
88 break; # Good node found.
89 }
90 }
91
92 if {$idx == [llength $::redis_cluster::startup_nodes($id)]} {
93 error "No good startup node found. $errmsg"
94 }
95
96 # Put the node that responded as first in the list if it is not
97 # already the first.
98 if {$idx != 0} {
99 set l $::redis_cluster::startup_nodes($id)
100 set left [lrange $l 0 [expr {$idx-1}]]
101 set right [lrange $l [expr {$idx+1}] end]
102 set l [concat [lindex $l $idx] $left $right]
103 set ::redis_cluster::startup_nodes($id) $l
104 }
105
106 # Parse CLUSTER NODES output to populate the nodes description.
107 set nodes {} ; # addr -> node description hash.
108 foreach line [split $nodes_descr "\n"] {
109 set line [string trim $line]
110 if {$line eq {}} continue
111 set args [split $line " "]
112 lassign $args nodeid addr flags slaveof pingsent pongrecv configepoch linkstate
113 set slots [lrange $args 8 end]
114 set addr [lindex [split $addr @] 0]
115 if {$addr eq {:0}} {
116 set addr $start_host:$start_port
117 }
118 lassign [split $addr :] host port
119
120 # Connect to the node
121 set link {}
122 set tls $::redis_cluster::tls($id)
123 catch {set link [redis $host $port 0 $tls]}
124
125 # Build this node description as an hash.
126 set node [dict create \
127 id $nodeid \
128 internal_id $id \
129 addr $addr \
130 host $host \
131 port $port \
132 flags $flags \
133 slaveof $slaveof \
134 slots $slots \
135 link $link \
136 ]
137 dict set nodes $addr $node
138 lappend ::redis_cluster::startup_nodes($id) $addr
139 }
140
141 # Close all the existing links in the old nodes map, and set the new
142 # map as current.
143 foreach n $::redis_cluster::nodes($id) {
144 catch {
145 [dict get $n link] close
146 }
147 }
148 set ::redis_cluster::nodes($id) $nodes
149
150 # Populates the slots -> nodes map.
151 dict for {addr node} $nodes {
152 foreach slotrange [dict get $node slots] {
153 lassign [split $slotrange -] start end
154 if {$end == {}} {set end $start}
155 for {set j $start} {$j <= $end} {incr j} {
156 dict set ::redis_cluster::slots($id) $j $addr
157 }
158 }
159 }
160
161 # Only retain unique entries in the startup nodes list
162 set ::redis_cluster::startup_nodes($id) [lsort -unique $::redis_cluster::startup_nodes($id)]
163}
164
165# Free a redis_cluster handle.
166proc ::redis_cluster::__method__close {id} {
167 catch {
168 set nodes $::redis_cluster::nodes($id)
169 dict for {addr node} $nodes {
170 catch {
171 [dict get $node link] close
172 }
173 }
174 }
175 catch {unset ::redis_cluster::startup_nodes($id)}
176 catch {unset ::redis_cluster::nodes($id)}
177 catch {unset ::redis_cluster::slots($id)}
178 catch {unset ::redis_cluster::tls($id)}
179 catch {interp alias {} ::redis_cluster::instance$id {}}
180}
181
182proc ::redis_cluster::__method__masternode_for_slot {id slot} {
183 # Get the node mapped to this slot.
184 set node_addr [dict get $::redis_cluster::slots($id) $slot]
185 if {$node_addr eq {}} {
186 error "No mapped node for slot $slot."
187 }
188 return [dict get $::redis_cluster::nodes($id) $node_addr]
189}
190
191proc ::redis_cluster::__method__masternode_notfor_slot {id slot} {
192 # Get a node that is not mapped to this slot.
193 set node_addr [dict get $::redis_cluster::slots($id) $slot]
194 set addrs [dict keys $::redis_cluster::nodes($id)]
195 foreach addr [lshuffle $addrs] {
196 set node [dict get $::redis_cluster::nodes($id) $addr]
197 if {$node_addr ne $addr && [dict get $node slaveof] eq "-"} {
198 return $node
199 }
200 }
201 error "Slot $slot is everywhere"
202}
203
204proc ::redis_cluster::__dispatch__ {id method args} {
205 if {[info command ::redis_cluster::__method__$method] eq {}} {
206 # Get the keys from the command.
207 set keys [::redis_cluster::get_keys_from_command $method $args]
208 if {$keys eq {}} {
209 error "Redis command '$method' is not supported by redis_cluster."
210 }
211
212 # Resolve the keys in the corresponding hash slot they hash to.
213 set slot [::redis_cluster::get_slot_from_keys $keys]
214 if {$slot eq {}} {
215 error "Invalid command: multiple keys not hashing to the same slot."
216 }
217
218 # Get the node mapped to this slot.
219 set node_addr [dict get $::redis_cluster::slots($id) $slot]
220 if {$node_addr eq {}} {
221 error "No mapped node for slot $slot."
222 }
223
224 # Execute the command in the node we think is the slot owner.
225 set retry 100
226 set asking 0
227 while {[incr retry -1]} {
228 if {$retry < 5} {after 100}
229 set node [dict get $::redis_cluster::nodes($id) $node_addr]
230 set link [dict get $node link]
231 if {$asking} {
232 $link ASKING
233 set asking 0
234 }
235 if {[catch {$link $method {*}$args} e]} {
236 if {$link eq {} || \
237 [string range $e 0 4] eq {MOVED} || \
238 [string range $e 0 2] eq {I/O} \
239 } {
240 # MOVED redirection.
241 ::redis_cluster::__method__refresh_nodes_map $id
242 set node_addr [dict get $::redis_cluster::slots($id) $slot]
243 continue
244 } elseif {[string range $e 0 2] eq {ASK}} {
245 # ASK redirection.
246 set node_addr [lindex $e 2]
247 set asking 1
248 continue
249 } else {
250 # Non redirecting error.
251 error $e $::errorInfo $::errorCode
252 }
253 } else {
254 # OK query went fine
255 return $e
256 }
257 }
258 error "Too many redirections or failures contacting Redis Cluster."
259 } else {
260 uplevel 1 [list ::redis_cluster::__method__$method $id] $args
261 }
262}
263
264proc ::redis_cluster::get_keys_from_command {cmd argv} {
265 set cmd [string tolower $cmd]
266 # Most Redis commands get just one key as first argument.
267 if {[lsearch -exact $::redis_cluster::plain_commands $cmd] != -1} {
268 return [list [lindex $argv 0]]
269 }
270
271 # Special handling for other commands
272 switch -exact $cmd {
273 mget {return $argv}
274 eval {return [lrange $argv 2 1+[lindex $argv 1]]}
275 evalsha {return [lrange $argv 2 1+[lindex $argv 1]]}
276 spublish {return [list [lindex $argv 1]]}
277 }
278
279 # All the remaining commands are not handled.
280 return {}
281}
282
283# Returns the CRC16 of the specified string.
284# The CRC parameters are described in the Redis Cluster specification.
285set ::redis_cluster::XMODEMCRC16Lookup {
286 0x0000 0x1021 0x2042 0x3063 0x4084 0x50a5 0x60c6 0x70e7
287 0x8108 0x9129 0xa14a 0xb16b 0xc18c 0xd1ad 0xe1ce 0xf1ef
288 0x1231 0x0210 0x3273 0x2252 0x52b5 0x4294 0x72f7 0x62d6
289 0x9339 0x8318 0xb37b 0xa35a 0xd3bd 0xc39c 0xf3ff 0xe3de
290 0x2462 0x3443 0x0420 0x1401 0x64e6 0x74c7 0x44a4 0x5485
291 0xa56a 0xb54b 0x8528 0x9509 0xe5ee 0xf5cf 0xc5ac 0xd58d
292 0x3653 0x2672 0x1611 0x0630 0x76d7 0x66f6 0x5695 0x46b4
293 0xb75b 0xa77a 0x9719 0x8738 0xf7df 0xe7fe 0xd79d 0xc7bc
294 0x48c4 0x58e5 0x6886 0x78a7 0x0840 0x1861 0x2802 0x3823
295 0xc9cc 0xd9ed 0xe98e 0xf9af 0x8948 0x9969 0xa90a 0xb92b
296 0x5af5 0x4ad4 0x7ab7 0x6a96 0x1a71 0x0a50 0x3a33 0x2a12
297 0xdbfd 0xcbdc 0xfbbf 0xeb9e 0x9b79 0x8b58 0xbb3b 0xab1a
298 0x6ca6 0x7c87 0x4ce4 0x5cc5 0x2c22 0x3c03 0x0c60 0x1c41
299 0xedae 0xfd8f 0xcdec 0xddcd 0xad2a 0xbd0b 0x8d68 0x9d49
300 0x7e97 0x6eb6 0x5ed5 0x4ef4 0x3e13 0x2e32 0x1e51 0x0e70
301 0xff9f 0xefbe 0xdfdd 0xcffc 0xbf1b 0xaf3a 0x9f59 0x8f78
302 0x9188 0x81a9 0xb1ca 0xa1eb 0xd10c 0xc12d 0xf14e 0xe16f
303 0x1080 0x00a1 0x30c2 0x20e3 0x5004 0x4025 0x7046 0x6067
304 0x83b9 0x9398 0xa3fb 0xb3da 0xc33d 0xd31c 0xe37f 0xf35e
305 0x02b1 0x1290 0x22f3 0x32d2 0x4235 0x5214 0x6277 0x7256
306 0xb5ea 0xa5cb 0x95a8 0x8589 0xf56e 0xe54f 0xd52c 0xc50d
307 0x34e2 0x24c3 0x14a0 0x0481 0x7466 0x6447 0x5424 0x4405
308 0xa7db 0xb7fa 0x8799 0x97b8 0xe75f 0xf77e 0xc71d 0xd73c
309 0x26d3 0x36f2 0x0691 0x16b0 0x6657 0x7676 0x4615 0x5634
310 0xd94c 0xc96d 0xf90e 0xe92f 0x99c8 0x89e9 0xb98a 0xa9ab
311 0x5844 0x4865 0x7806 0x6827 0x18c0 0x08e1 0x3882 0x28a3
312 0xcb7d 0xdb5c 0xeb3f 0xfb1e 0x8bf9 0x9bd8 0xabbb 0xbb9a
313 0x4a75 0x5a54 0x6a37 0x7a16 0x0af1 0x1ad0 0x2ab3 0x3a92
314 0xfd2e 0xed0f 0xdd6c 0xcd4d 0xbdaa 0xad8b 0x9de8 0x8dc9
315 0x7c26 0x6c07 0x5c64 0x4c45 0x3ca2 0x2c83 0x1ce0 0x0cc1
316 0xef1f 0xff3e 0xcf5d 0xdf7c 0xaf9b 0xbfba 0x8fd9 0x9ff8
317 0x6e17 0x7e36 0x4e55 0x5e74 0x2e93 0x3eb2 0x0ed1 0x1ef0
318}
319
320proc ::redis_cluster::crc16 {s} {
321 set s [encoding convertto ascii $s]
322 set crc 0
323 foreach char [split $s {}] {
324 scan $char %c byte
325 set crc [expr {(($crc<<8)&0xffff) ^ [lindex $::redis_cluster::XMODEMCRC16Lookup [expr {(($crc>>8)^$byte) & 0xff}]]}]
326 }
327 return $crc
328}
329
330# Hash a single key returning the slot it belongs to, Implemented hash
331# tags as described in the Redis Cluster specification.
332proc ::redis_cluster::hash {key} {
333 set keylen [string length $key]
334 set s {}
335 set e {}
336 for {set s 0} {$s < $keylen} {incr s} {
337 if {[string index $key $s] eq "\{"} break
338 }
339
340 if {[expr {$s == $keylen}]} {
341 set res [expr {[crc16 $key] & 16383}]
342 return $res
343 }
344
345 for {set e [expr {$s+1}]} {$e < $keylen} {incr e} {
346 if {[string index $key $e] == "\}"} break
347 }
348
349 if {$e == $keylen || $e == [expr {$s+1}]} {
350 set res [expr {[crc16 $key] & 16383}]
351 return $res
352 }
353
354 set key_sub [string range $key [expr {$s+1}] [expr {$e-1}]]
355 return [expr {[crc16 $key_sub] & 16383}]
356}
357
358# Return the slot the specified keys hash to.
359# If the keys hash to multiple slots, an empty string is returned to
360# signal that the command can't be run in Redis Cluster.
361proc ::redis_cluster::get_slot_from_keys {keys} {
362 set slot {}
363 foreach k $keys {
364 set s [::redis_cluster::hash $k]
365 if {$slot eq {}} {
366 set slot $s
367 } elseif {$slot != $s} {
368 return {} ; # Error
369 }
370 }
371 return $slot
372}
diff --git a/examples/redis-unstable/tests/support/cluster_util.tcl b/examples/redis-unstable/tests/support/cluster_util.tcl
deleted file mode 100644
index 6b7f423..0000000
--- a/examples/redis-unstable/tests/support/cluster_util.tcl
+++ /dev/null
@@ -1,264 +0,0 @@
1#
2# Copyright (c) 2009-Present, Redis Ltd.
3# All rights reserved.
4#
5# Copyright (c) 2024-present, Valkey contributors.
6# All rights reserved.
7#
8# Licensed under your choice of (a) the Redis Source Available License 2.0
9# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the
10# GNU Affero General Public License v3 (AGPLv3).
11#
12# Portions of this file are available under BSD3 terms; see REDISCONTRIBUTIONS for more information.
13#
14
15# Cluster helper functions
16# Normalize cluster slots configuration by sorting replicas by node ID
17proc normalize_cluster_slots {slots_config} {
18 set normalized {}
19 foreach slot_range $slots_config {
20 if {[llength $slot_range] <= 3} {
21 lappend normalized $slot_range
22 } else {
23 # Sort replicas (index 3+) by node ID, keep start/end/master unchanged
24 set replicas [lrange $slot_range 3 end]
25 set sorted_replicas [lsort -index 2 $replicas]
26 lappend normalized [concat [lrange $slot_range 0 2] $sorted_replicas]
27 }
28 }
29 return $normalized
30}
31
32# Check if cluster configuration is consistent.
33proc cluster_config_consistent {} {
34 for {set j 0} {$j < [llength $::servers]} {incr j} {
35 if {$j == 0} {
36 set base_cfg [R $j cluster slots]
37 set base_secret [R $j debug internal_secret]
38 set normalized_base_cfg [normalize_cluster_slots $base_cfg]
39 } else {
40 set cfg [R $j cluster slots]
41 set secret [R $j debug internal_secret]
42 set normalized_cfg [normalize_cluster_slots $cfg]
43 if {$normalized_cfg != $normalized_base_cfg || $secret != $base_secret} {
44 return 0
45 }
46 }
47 }
48
49 return 1
50}
51
52# Check if cluster size is consistent.
53proc cluster_size_consistent {cluster_size} {
54 for {set j 0} {$j < $cluster_size} {incr j} {
55 if {[CI $j cluster_known_nodes] ne $cluster_size} {
56 return 0
57 }
58 }
59 return 1
60}
61
62# Wait for cluster configuration to propagate and be consistent across nodes.
63proc wait_for_cluster_propagation {} {
64 wait_for_condition 50 100 {
65 [cluster_config_consistent] eq 1
66 } else {
67 fail "cluster config did not reach a consistent state"
68 }
69}
70
71# Wait for cluster size to be consistent across nodes.
72proc wait_for_cluster_size {cluster_size} {
73 wait_for_condition 1000 50 {
74 [cluster_size_consistent $cluster_size] eq 1
75 } else {
76 fail "cluster size did not reach a consistent size $cluster_size"
77 }
78}
79
80# Check that cluster nodes agree about "state", or raise an error.
81proc wait_for_cluster_state {state} {
82 for {set j 0} {$j < [llength $::servers]} {incr j} {
83 wait_for_condition 100 50 {
84 [CI $j cluster_state] eq $state
85 } else {
86 fail "Cluster node $j cluster_state:[CI $j cluster_state]"
87 }
88 }
89}
90
91# Default slot allocation for clusters, each master has a continuous block
92# and approximately equal number of slots.
93proc continuous_slot_allocation {masters} {
94 set avg [expr double(16384) / $masters]
95 set slot_start 0
96 for {set j 0} {$j < $masters} {incr j} {
97 set slot_end [expr int(ceil(($j + 1) * $avg) - 1)]
98 R $j cluster addslotsrange $slot_start $slot_end
99 set slot_start [expr $slot_end + 1]
100 }
101}
102
103# Setup method to be executed to configure the cluster before the
104# tests run.
105proc cluster_setup {masters node_count slot_allocator code} {
106 # Have all nodes meet
107 if {$::tls} {
108 set tls_cluster [lindex [R 0 CONFIG GET tls-cluster] 1]
109 }
110 if {$::tls && !$tls_cluster} {
111 for {set i 1} {$i < $node_count} {incr i} {
112 R 0 CLUSTER MEET [srv -$i host] [srv -$i pport]
113 }
114 } else {
115 for {set i 1} {$i < $node_count} {incr i} {
116 R 0 CLUSTER MEET [srv -$i host] [srv -$i port]
117 }
118 }
119
120 $slot_allocator $masters
121
122 wait_for_cluster_propagation
123
124 # Setup master/replica relationships
125 for {set i 0} {$i < $masters} {incr i} {
126 set nodeid [R $i CLUSTER MYID]
127 for {set j [expr $i + $masters]} {$j < $node_count} {incr j $masters} {
128 R $j CLUSTER REPLICATE $nodeid
129 }
130 }
131
132 wait_for_cluster_propagation
133 wait_for_cluster_state "ok"
134
135 uplevel 1 $code
136}
137
138# Start a cluster with the given number of masters and replicas. Replicas
139# will be allocated to masters by round robin.
140proc start_cluster {masters replicas options code {slot_allocator continuous_slot_allocation}} {
141 set ::cluster_master_nodes $masters
142 set ::cluster_replica_nodes $replicas
143 set node_count [expr $masters + $replicas]
144
145 # Set the final code to be the tests + cluster setup
146 set code [list cluster_setup $masters $node_count $slot_allocator $code]
147
148 # Configure the starting of multiple servers. Set cluster node timeout
149 # aggressively since many tests depend on ping/pong messages.
150 set cluster_options [list overrides [list cluster-enabled yes cluster-ping-interval 100 cluster-node-timeout 3000 cluster-slot-stats-enabled yes]]
151 set options [concat $cluster_options $options]
152
153 # Cluster mode only supports a single database, so before executing the tests
154 # it needs to be configured correctly and needs to be reset after the tests.
155 set old_singledb $::singledb
156 set ::singledb 1
157 start_multiple_servers $node_count $options $code
158 set ::singledb $old_singledb
159}
160
161# Test node for flag.
162proc cluster_has_flag {node flag} {
163 expr {[lsearch -exact [dict get $node flags] $flag] != -1}
164}
165
166# Returns the parsed "myself" node entry as a dictionary.
167proc cluster_get_myself id {
168 set nodes [get_cluster_nodes $id]
169 foreach n $nodes {
170 if {[cluster_has_flag $n myself]} {return $n}
171 }
172 return {}
173}
174
175# Returns a parsed CLUSTER NODES output as a list of dictionaries.
176proc get_cluster_nodes id {
177 set lines [split [R $id cluster nodes] "\r\n"]
178 set nodes {}
179 foreach l $lines {
180 set l [string trim $l]
181 if {$l eq {}} continue
182 set args [split $l]
183 set node [dict create \
184 id [lindex $args 0] \
185 addr [lindex $args 1] \
186 flags [split [lindex $args 2] ,] \
187 slaveof [lindex $args 3] \
188 ping_sent [lindex $args 4] \
189 pong_recv [lindex $args 5] \
190 config_epoch [lindex $args 6] \
191 linkstate [lindex $args 7] \
192 slots [lrange $args 8 end] \
193 ]
194 lappend nodes $node
195 }
196 return $nodes
197}
198
199# Returns 1 if no node knows node_id, 0 if any node knows it.
200proc node_is_forgotten {node_id} {
201 for {set j 0} {$j < [llength $::servers]} {incr j} {
202 set cluster_nodes [R $j CLUSTER NODES]
203 if { [string match "*$node_id*" $cluster_nodes] } {
204 return 0
205 }
206 }
207 return 1
208}
209
210# Isolate a node from the cluster and give it a new nodeid
211proc isolate_node {id} {
212 set node_id [R $id CLUSTER MYID]
213 R $id CLUSTER RESET HARD
214 # Here we additionally test that CLUSTER FORGET propagates to all nodes.
215 set other_id [expr $id == 0 ? 1 : 0]
216 R $other_id CLUSTER FORGET $node_id
217 wait_for_condition 50 100 {
218 [node_is_forgotten $node_id]
219 } else {
220 fail "CLUSTER FORGET was not propagated to all nodes"
221 }
222}
223
224# Check if cluster's view of hostnames is consistent
225proc are_hostnames_propagated {match_string} {
226 for {set j 0} {$j < [llength $::servers]} {incr j} {
227 set cfg [R $j cluster slots]
228 foreach node $cfg {
229 for {set i 2} {$i < [llength $node]} {incr i} {
230 if {! [string match $match_string [lindex [lindex [lindex $node $i] 3] 1]] } {
231 return 0
232 }
233 }
234 }
235 }
236 return 1
237}
238
239proc wait_node_marked_fail {ref_node_index instance_id_to_check} {
240 wait_for_condition 1000 50 {
241 [check_cluster_node_mark fail $ref_node_index $instance_id_to_check]
242 } else {
243 fail "Replica node never marked as FAIL ('fail')"
244 }
245}
246
247proc wait_node_marked_pfail {ref_node_index instance_id_to_check} {
248 wait_for_condition 1000 50 {
249 [check_cluster_node_mark fail\? $ref_node_index $instance_id_to_check]
250 } else {
251 fail "Replica node never marked as PFAIL ('fail?')"
252 }
253}
254
255proc check_cluster_node_mark {flag ref_node_index instance_id_to_check} {
256 set nodes [get_cluster_nodes $ref_node_index]
257
258 foreach n $nodes {
259 if {[dict get $n id] eq $instance_id_to_check} {
260 return [cluster_has_flag $n $flag]
261 }
262 }
263 fail "Unable to find instance id in cluster nodes. ID: $instance_id_to_check"
264}
diff --git a/examples/redis-unstable/tests/support/redis.tcl b/examples/redis-unstable/tests/support/redis.tcl
deleted file mode 100644
index 6c85855..0000000
--- a/examples/redis-unstable/tests/support/redis.tcl
+++ /dev/null
@@ -1,471 +0,0 @@
1# Tcl client library - used by the Redis test
2#
3# Copyright (C) 2014-Present, Redis Ltd.
4# All Rights reserved.
5#
6# Licensed under your choice of (a) the Redis Source Available License 2.0
7# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the
8# GNU Affero General Public License v3 (AGPLv3).
9#
10# Example usage:
11#
12# set r [redis 127.0.0.1 6379]
13# $r lpush mylist foo
14# $r lpush mylist bar
15# $r lrange mylist 0 -1
16# $r close
17#
18# Non blocking usage example:
19#
20# proc handlePong {r type reply} {
21# puts "PONG $type '$reply'"
22# if {$reply ne "PONG"} {
23# $r ping [list handlePong]
24# }
25# }
26#
27# set r [redis]
28# $r blocking 0
29# $r get fo [list handlePong]
30#
31# vwait forever
32
33package require Tcl 8.5
34package provide redis 0.1
35
36source [file join [file dirname [info script]] "response_transformers.tcl"]
37
38namespace eval redis {}
39set ::redis::id 0
40array set ::redis::fd {}
41array set ::redis::addr {}
42array set ::redis::blocking {}
43array set ::redis::deferred {}
44array set ::redis::readraw {}
45array set ::redis::attributes {} ;# Holds the RESP3 attributes from the last call
46array set ::redis::reconnect {}
47array set ::redis::tls {}
48array set ::redis::callback {}
49array set ::redis::state {} ;# State in non-blocking reply reading
50array set ::redis::statestack {} ;# Stack of states, for nested mbulks
51array set ::redis::curr_argv {} ;# Remember the current argv, to be used in response_transformers.tcl
52array set ::redis::testing_resp3 {} ;# Indicating if the current client is using RESP3 (only if the test is trying to test RESP3 specific behavior. It won't be on in case of force_resp3)
53
54set ::force_resp3 0
55set ::log_req_res 0
56
57proc redis {{server 127.0.0.1} {port 6379} {defer 0} {tls 0} {tlsoptions {}} {readraw 0}} {
58 if {$tls} {
59 package require tls
60 ::tls::init \
61 -cafile "$::tlsdir/ca.crt" \
62 -certfile "$::tlsdir/client.crt" \
63 -keyfile "$::tlsdir/client.key" \
64 {*}$tlsoptions
65 set fd [::tls::socket $server $port]
66 } else {
67 set fd [socket $server $port]
68 }
69 fconfigure $fd -translation binary
70 set id [incr ::redis::id]
71 set ::redis::fd($id) $fd
72 set ::redis::addr($id) [list $server $port]
73 set ::redis::blocking($id) 1
74 set ::redis::deferred($id) $defer
75 set ::redis::readraw($id) $readraw
76 set ::redis::reconnect($id) 0
77 set ::redis::curr_argv($id) 0
78 set ::redis::testing_resp3($id) 0
79 set ::redis::tls($id) $tls
80 ::redis::redis_reset_state $id
81 interp alias {} ::redis::redisHandle$id {} ::redis::__dispatch__ $id
82}
83
84# On recent versions of tcl-tls/OpenSSL, reading from a dropped connection
85# results with an error we need to catch and mimic the old behavior.
86proc ::redis::redis_safe_read {fd len} {
87 if {$len == -1} {
88 set err [catch {set val [read $fd]} msg]
89 } else {
90 set err [catch {set val [read $fd $len]} msg]
91 }
92 if {!$err} {
93 return $val
94 }
95 if {[string match "*connection abort*" $msg]} {
96 return {}
97 }
98 error $msg
99}
100
101proc ::redis::redis_safe_gets {fd} {
102 if {[catch {set val [gets $fd]} msg]} {
103 if {[string match "*connection abort*" $msg]} {
104 return {}
105 }
106 error $msg
107 }
108 return $val
109}
110
111# This is a wrapper to the actual dispatching procedure that handles
112# reconnection if needed.
113proc ::redis::__dispatch__ {id method args} {
114 set errorcode [catch {::redis::__dispatch__raw__ $id $method $args} retval]
115 if {$errorcode && $::redis::reconnect($id) && $::redis::fd($id) eq {}} {
116 # Try again if the connection was lost.
117 # FIXME: we don't re-select the previously selected DB, nor we check
118 # if we are inside a transaction that needs to be re-issued from
119 # scratch.
120 set errorcode [catch {::redis::__dispatch__raw__ $id $method $args} retval]
121 }
122 return -code $errorcode $retval
123}
124
125proc ::redis::__dispatch__raw__ {id method argv} {
126 set fd $::redis::fd($id)
127
128 # Reconnect the link if needed.
129 if {$fd eq {} && $method ne {close}} {
130 lassign $::redis::addr($id) host port
131 if {$::redis::tls($id)} {
132 set ::redis::fd($id) [::tls::socket $host $port]
133 } else {
134 set ::redis::fd($id) [socket $host $port]
135 }
136 fconfigure $::redis::fd($id) -translation binary
137 set fd $::redis::fd($id)
138 }
139
140 # Transform HELLO 2 to HELLO 3 if force_resp3
141 # All set the connection var testing_resp3 in case of HELLO 3
142 if {[llength $argv] > 0 && [string compare -nocase $method "HELLO"] == 0} {
143 if {[lindex $argv 0] == 3} {
144 set ::redis::testing_resp3($id) 1
145 } else {
146 set ::redis::testing_resp3($id) 0
147 if {$::force_resp3} {
148 # If we are in force_resp3 we run HELLO 3 instead of HELLO 2
149 lset argv 0 3
150 }
151 }
152 }
153
154 set blocking $::redis::blocking($id)
155 set deferred $::redis::deferred($id)
156 if {$blocking == 0} {
157 if {[llength $argv] == 0} {
158 error "Please provide a callback in non-blocking mode"
159 }
160 set callback [lindex $argv end]
161 set argv [lrange $argv 0 end-1]
162 }
163 if {[info command ::redis::__method__$method] eq {}} {
164 catch {unset ::redis::attributes($id)}
165 set cmd "*[expr {[llength $argv]+1}]\r\n"
166 append cmd "$[string length $method]\r\n$method\r\n"
167 foreach a $argv {
168 append cmd "$[string length $a]\r\n$a\r\n"
169 }
170 ::redis::redis_write $fd $cmd
171 if {[catch {flush $fd}]} {
172 catch {close $fd}
173 set ::redis::fd($id) {}
174 return -code error "I/O error reading reply"
175 }
176
177 set ::redis::curr_argv($id) [concat $method $argv]
178 if {!$deferred} {
179 if {$blocking} {
180 ::redis::redis_read_reply $id $fd
181 } else {
182 # Every well formed reply read will pop an element from this
183 # list and use it as a callback. So pipelining is supported
184 # in non blocking mode.
185 lappend ::redis::callback($id) $callback
186 fileevent $fd readable [list ::redis::redis_readable $fd $id]
187 }
188 }
189 } else {
190 uplevel 1 [list ::redis::__method__$method $id $fd] $argv
191 }
192}
193
194proc ::redis::__method__blocking {id fd val} {
195 set ::redis::blocking($id) $val
196 fconfigure $fd -blocking $val
197}
198
199proc ::redis::__method__reconnect {id fd val} {
200 set ::redis::reconnect($id) $val
201}
202
203proc ::redis::__method__read {id fd} {
204 ::redis::redis_read_reply $id $fd
205}
206
207proc ::redis::__method__rawread {id fd {len -1}} {
208 return [redis_safe_read $fd $len]
209}
210
211proc ::redis::__method__write {id fd buf} {
212 ::redis::redis_write $fd $buf
213}
214
215proc ::redis::__method__flush {id fd} {
216 flush $fd
217}
218
219proc ::redis::__method__close {id fd} {
220 catch {close $fd}
221 catch {unset ::redis::fd($id)}
222 catch {unset ::redis::addr($id)}
223 catch {unset ::redis::blocking($id)}
224 catch {unset ::redis::deferred($id)}
225 catch {unset ::redis::readraw($id)}
226 catch {unset ::redis::attributes($id)}
227 catch {unset ::redis::reconnect($id)}
228 catch {unset ::redis::tls($id)}
229 catch {unset ::redis::state($id)}
230 catch {unset ::redis::statestack($id)}
231 catch {unset ::redis::callback($id)}
232 catch {unset ::redis::curr_argv($id)}
233 catch {unset ::redis::testing_resp3($id)}
234 catch {interp alias {} ::redis::redisHandle$id {}}
235}
236
237proc ::redis::__method__channel {id fd} {
238 return $fd
239}
240
241proc ::redis::__method__deferred {id fd val} {
242 set ::redis::deferred($id) $val
243}
244
245proc ::redis::__method__readraw {id fd val} {
246 set ::redis::readraw($id) $val
247}
248
249proc ::redis::__method__readingraw {id fd} {
250 return $::redis::readraw($id)
251}
252
253proc ::redis::__method__attributes {id fd} {
254 set _ $::redis::attributes($id)
255}
256
257proc ::redis::redis_write {fd buf} {
258 puts -nonewline $fd $buf
259}
260
261proc ::redis::redis_writenl {fd buf} {
262 redis_write $fd $buf
263 redis_write $fd "\r\n"
264 flush $fd
265}
266
267proc ::redis::redis_readnl {fd len} {
268 set buf [redis_safe_read $fd $len]
269 redis_safe_read $fd 2 ; # discard CR LF
270 return $buf
271}
272
273proc ::redis::redis_bulk_read {fd} {
274 set count [redis_read_line $fd]
275 if {$count == -1} return {}
276 set buf [redis_readnl $fd $count]
277 return $buf
278}
279
280proc ::redis::redis_multi_bulk_read {id fd} {
281 set count [redis_read_line $fd]
282 if {$count == -1} return {}
283 set l {}
284 set err {}
285 for {set i 0} {$i < $count} {incr i} {
286 if {[catch {
287 lappend l [redis_read_reply_logic $id $fd]
288 } e] && $err eq {}} {
289 set err $e
290 }
291 }
292 if {$err ne {}} {return -code error $err}
293 return $l
294}
295
296proc ::redis::redis_read_map {id fd} {
297 set count [redis_read_line $fd]
298 if {$count == -1} return {}
299 set d {}
300 set err {}
301 for {set i 0} {$i < $count} {incr i} {
302 if {[catch {
303 set k [redis_read_reply_logic $id $fd] ; # key
304 set v [redis_read_reply_logic $id $fd] ; # value
305 dict set d $k $v
306 } e] && $err eq {}} {
307 set err $e
308 }
309 }
310 if {$err ne {}} {return -code error $err}
311 return $d
312}
313
314proc ::redis::redis_read_line fd {
315 string trim [redis_safe_gets $fd]
316}
317
318proc ::redis::redis_read_null fd {
319 redis_safe_gets $fd
320 return {}
321}
322
323proc ::redis::redis_read_bool fd {
324 set v [redis_read_line $fd]
325 if {$v == "t"} {return 1}
326 if {$v == "f"} {return 0}
327 return -code error "Bad protocol, '$v' as bool type"
328}
329
330proc ::redis::redis_read_double {id fd} {
331 set v [redis_read_line $fd]
332 # unlike many other DTs, there is a textual difference between double and a string with the same value,
333 # so we need to transform to double if we are testing RESP3 (i.e. some tests check that a
334 # double reply is "1.0" and not "1")
335 if {[should_transform_to_resp2 $id]} {
336 return $v
337 } else {
338 return [expr {double($v)}]
339 }
340}
341
342proc ::redis::redis_read_verbatim_str fd {
343 set v [redis_bulk_read $fd]
344 # strip the first 4 chars ("txt:")
345 return [string range $v 4 end]
346}
347
348proc ::redis::redis_read_reply_logic {id fd} {
349 if {$::redis::readraw($id)} {
350 return [redis_read_line $fd]
351 }
352
353 while {1} {
354 set type [redis_safe_read $fd 1]
355 switch -exact -- $type {
356 _ {return [redis_read_null $fd]}
357 : -
358 ( -
359 + {return [redis_read_line $fd]}
360 , {return [redis_read_double $id $fd]}
361 # {return [redis_read_bool $fd]}
362 = {return [redis_read_verbatim_str $fd]}
363 - {return -code error [redis_read_line $fd]}
364 $ {return [redis_bulk_read $fd]}
365 > -
366 ~ -
367 * {return [redis_multi_bulk_read $id $fd]}
368 % {return [redis_read_map $id $fd]}
369 | {
370 set attrib [redis_read_map $id $fd]
371 set ::redis::attributes($id) $attrib
372 continue
373 }
374 default {
375 if {$type eq {}} {
376 catch {close $fd}
377 set ::redis::fd($id) {}
378 return -code error "I/O error reading reply"
379 }
380 return -code error "Bad protocol, '$type' as reply type byte"
381 }
382 }
383 }
384}
385
386proc ::redis::redis_read_reply {id fd} {
387 set response [redis_read_reply_logic $id $fd]
388 ::response_transformers::transform_response_if_needed $id $::redis::curr_argv($id) $response
389}
390
391proc ::redis::redis_reset_state id {
392 set ::redis::state($id) [dict create buf {} mbulk -1 bulk -1 reply {}]
393 set ::redis::statestack($id) {}
394}
395
396proc ::redis::redis_call_callback {id type reply} {
397 set cb [lindex $::redis::callback($id) 0]
398 set ::redis::callback($id) [lrange $::redis::callback($id) 1 end]
399 uplevel #0 $cb [list ::redis::redisHandle$id $type $reply]
400 ::redis::redis_reset_state $id
401}
402
403# Read a reply in non-blocking mode.
404proc ::redis::redis_readable {fd id} {
405 if {[eof $fd]} {
406 redis_call_callback $id eof {}
407 ::redis::__method__close $id $fd
408 return
409 }
410 if {[dict get $::redis::state($id) bulk] == -1} {
411 set line [gets $fd]
412 if {$line eq {}} return ;# No complete line available, return
413 switch -exact -- [string index $line 0] {
414 : -
415 + {redis_call_callback $id reply [string range $line 1 end-1]}
416 - {redis_call_callback $id err [string range $line 1 end-1]}
417 ( {redis_call_callback $id reply [string range $line 1 end-1]}
418 $ {
419 dict set ::redis::state($id) bulk \
420 [expr [string range $line 1 end-1]+2]
421 if {[dict get $::redis::state($id) bulk] == 1} {
422 # We got a $-1, hack the state to play well with this.
423 dict set ::redis::state($id) bulk 2
424 dict set ::redis::state($id) buf "\r\n"
425 ::redis::redis_readable $fd $id
426 }
427 }
428 * {
429 dict set ::redis::state($id) mbulk [string range $line 1 end-1]
430 # Handle *-1
431 if {[dict get $::redis::state($id) mbulk] == -1} {
432 redis_call_callback $id reply {}
433 }
434 }
435 default {
436 redis_call_callback $id err \
437 "Bad protocol, $type as reply type byte"
438 }
439 }
440 } else {
441 set totlen [dict get $::redis::state($id) bulk]
442 set buflen [string length [dict get $::redis::state($id) buf]]
443 set toread [expr {$totlen-$buflen}]
444 set data [read $fd $toread]
445 set nread [string length $data]
446 dict append ::redis::state($id) buf $data
447 # Check if we read a complete bulk reply
448 if {[string length [dict get $::redis::state($id) buf]] ==
449 [dict get $::redis::state($id) bulk]} {
450 if {[dict get $::redis::state($id) mbulk] == -1} {
451 redis_call_callback $id reply \
452 [string range [dict get $::redis::state($id) buf] 0 end-2]
453 } else {
454 dict with ::redis::state($id) {
455 lappend reply [string range $buf 0 end-2]
456 incr mbulk -1
457 set bulk -1
458 }
459 if {[dict get $::redis::state($id) mbulk] == 0} {
460 redis_call_callback $id reply \
461 [dict get $::redis::state($id) reply]
462 }
463 }
464 }
465 }
466}
467
468# when forcing resp3 some tests that rely on resp2 can fail, so we have to translate the resp3 response to resp2
469proc ::redis::should_transform_to_resp2 {id} {
470 return [expr {$::force_resp3 && !$::redis::testing_resp3($id)}]
471}
diff --git a/examples/redis-unstable/tests/support/response_transformers.tcl b/examples/redis-unstable/tests/support/response_transformers.tcl
deleted file mode 100644
index 99c1ebb..0000000
--- a/examples/redis-unstable/tests/support/response_transformers.tcl
+++ /dev/null
@@ -1,110 +0,0 @@
1# Tcl client library - used by the Redis test
2#
3# Copyright (C) 2009-Present, Redis Ltd.
4# All Rights reserved.
5#
6# Licensed under your choice of (a) the Redis Source Available License 2.0
7# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the
8# GNU Affero General Public License v3 (AGPLv3).
9#
10# This file contains a bunch of commands whose purpose is to transform
11# a RESP3 response to RESP2
12# Why is it needed?
13# When writing the reply_schema part in COMMAND DOCS we decided to use
14# the existing tests in order to verify the schemas (see logreqres.c)
15# The problem was that many tests were relying on the RESP2 structure
16# of the response (e.g. HRANDFIELD WITHVALUES in RESP2: {f1 v1 f2 v2}
17# vs. RESP3: {{f1 v1} {f2 v2}}).
18# Instead of adjusting the tests to expect RESP3 responses (a lot of
19# changes in many files) we decided to transform the response to RESP2
20# when running with --force-resp3
21
22package require Tcl 8.5
23
24namespace eval response_transformers {}
25
26# Transform a map response into an array of tuples (tuple = array with 2 elements)
27# Used for XREAD[GROUP]
28proc transfrom_map_to_tupple_array {argv response} {
29 set tuparray {}
30 foreach {key val} $response {
31 set tmp {}
32 lappend tmp $key
33 lappend tmp $val
34 lappend tuparray $tmp
35 }
36 return $tuparray
37}
38
39# Transform an array of tuples to a flat array
40proc transfrom_tuple_array_to_flat_array {argv response} {
41 set flatarray {}
42 foreach pair $response {
43 lappend flatarray {*}$pair
44 }
45 return $flatarray
46}
47
48# With HRANDFIELD, we only need to transform the response if the request had WITHVALUES
49# (otherwise the returned response is a flat array in both RESPs)
50proc transfrom_hrandfield_command {argv response} {
51 foreach ele $argv {
52 if {[string compare -nocase $ele "WITHVALUES"] == 0} {
53 return [transfrom_tuple_array_to_flat_array $argv $response]
54 }
55 }
56 return $response
57}
58
59# With some zset commands, we only need to transform the response if the request had WITHSCORES
60# (otherwise the returned response is a flat array in both RESPs)
61proc transfrom_zset_withscores_command {argv response} {
62 foreach ele $argv {
63 if {[string compare -nocase $ele "WITHSCORES"] == 0} {
64 return [transfrom_tuple_array_to_flat_array $argv $response]
65 }
66 }
67 return $response
68}
69
70# With ZPOPMIN/ZPOPMAX, we only need to transform the response if the request had COUNT (3rd arg)
71# (otherwise the returned response is a flat array in both RESPs)
72proc transfrom_zpopmin_zpopmax {argv response} {
73 if {[llength $argv] == 3} {
74 return [transfrom_tuple_array_to_flat_array $argv $response]
75 }
76 return $response
77}
78
79set ::trasformer_funcs {
80 XREAD transfrom_map_to_tupple_array
81 XREADGROUP transfrom_map_to_tupple_array
82 HRANDFIELD transfrom_hrandfield_command
83 ZRANDMEMBER transfrom_zset_withscores_command
84 ZRANGE transfrom_zset_withscores_command
85 ZRANGEBYSCORE transfrom_zset_withscores_command
86 ZRANGEBYLEX transfrom_zset_withscores_command
87 ZREVRANGE transfrom_zset_withscores_command
88 ZREVRANGEBYSCORE transfrom_zset_withscores_command
89 ZREVRANGEBYLEX transfrom_zset_withscores_command
90 ZUNION transfrom_zset_withscores_command
91 ZDIFF transfrom_zset_withscores_command
92 ZINTER transfrom_zset_withscores_command
93 ZPOPMIN transfrom_zpopmin_zpopmax
94 ZPOPMAX transfrom_zpopmin_zpopmax
95}
96
97proc ::response_transformers::transform_response_if_needed {id argv response} {
98 if {![::redis::should_transform_to_resp2 $id] || $::redis::readraw($id)} {
99 return $response
100 }
101
102 set key [string toupper [lindex $argv 0]]
103 if {![dict exists $::trasformer_funcs $key]} {
104 return $response
105 }
106
107 set transform [dict get $::trasformer_funcs $key]
108
109 return [$transform $argv $response]
110}
diff --git a/examples/redis-unstable/tests/support/server.tcl b/examples/redis-unstable/tests/support/server.tcl
deleted file mode 100644
index d683b1b..0000000
--- a/examples/redis-unstable/tests/support/server.tcl
+++ /dev/null
@@ -1,850 +0,0 @@
1#
2# Copyright (c) 2009-Present, Redis Ltd.
3# All rights reserved.
4#
5# Copyright (c) 2024-present, Valkey contributors.
6# All rights reserved.
7#
8# Licensed under your choice of (a) the Redis Source Available License 2.0
9# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the
10# GNU Affero General Public License v3 (AGPLv3).
11#
12# Portions of this file are available under BSD3 terms; see REDISCONTRIBUTIONS for more information.
13#
14
15set ::global_overrides {}
16set ::tags {}
17set ::valgrind_errors {}
18
19proc start_server_error {config_file error} {
20 set err {}
21 append err "Can't start the Redis server\n"
22 append err "CONFIGURATION:\n"
23 append err [exec cat $config_file]
24 append err "\nERROR:\n"
25 append err [string trim $error]
26 send_data_packet $::test_server_fd err $err
27}
28
29proc check_valgrind_errors stderr {
30 set res [find_valgrind_errors $stderr true]
31 if {$res != ""} {
32 send_data_packet $::test_server_fd err "Valgrind error: $res\n"
33 }
34}
35
36proc check_sanitizer_errors stderr {
37 set res [sanitizer_errors_from_file $stderr]
38 if {$res != ""} {
39 send_data_packet $::test_server_fd err "Sanitizer error: $res\n"
40 }
41}
42
43proc clean_persistence config {
44 # we may wanna keep the logs for later, but let's clean the persistence
45 # files right away, since they can accumulate and take up a lot of space
46 set config [dict get $config "config"]
47 set dir [dict get $config "dir"]
48 set rdb [format "%s/%s" $dir "dump.rdb"]
49 if {[dict exists $config "appenddirname"]} {
50 set aofdir [dict get $config "appenddirname"]
51 } else {
52 set aofdir "appendonlydir"
53 }
54 set aof_dirpath [format "%s/%s" $dir $aofdir]
55 clean_aof_persistence $aof_dirpath
56 catch {exec rm -rf $rdb}
57}
58
59proc kill_server config {
60 # nothing to kill when running against external server
61 if {$::external} return
62
63 # Close client connection if exists
64 if {[dict exists $config "client"]} {
65 [dict get $config "client"] close
66 }
67
68 # nevermind if its already dead
69 set pid [dict get $config pid]
70 if {![is_alive $pid]} {
71 # Check valgrind errors if needed
72 if {$::valgrind} {
73 check_valgrind_errors [dict get $config stderr]
74 }
75
76 check_sanitizer_errors [dict get $config stderr]
77
78 # Remove this pid from the set of active pids in the test server.
79 send_data_packet $::test_server_fd server-killed $pid
80
81 return
82 }
83
84 # check for leaks
85 if {![dict exists $config "skipleaks"]} {
86 catch {
87 if {[string match {*Darwin*} [exec uname -a]]} {
88 tags {"leaks"} {
89 test "Check for memory leaks (pid $pid)" {
90 set output {0 leaks}
91 catch {exec leaks $pid} output option
92 # In a few tests we kill the server process, so leaks will not find it.
93 # It'll exits with exit code >1 on error, so we ignore these.
94 if {[dict exists $option -errorcode]} {
95 set details [dict get $option -errorcode]
96 if {[lindex $details 0] eq "CHILDSTATUS"} {
97 set status [lindex $details 2]
98 if {$status > 1} {
99 set output "0 leaks"
100 }
101 }
102 }
103 set output
104 } {*0 leaks*}
105 }
106 }
107 }
108 }
109
110 # kill server and wait for the process to be totally exited
111 send_data_packet $::test_server_fd server-killing $pid
112 # Node might have been stopped in the test
113 # Send SIGCONT before SIGTERM, otherwise shutdown may be slow with ASAN.
114 catch {exec kill -SIGCONT $pid}
115 catch {exec kill $pid}
116 if {$::valgrind} {
117 set max_wait 120000
118 } else {
119 set max_wait 10000
120 }
121 while {[is_alive $pid]} {
122 incr wait 10
123
124 if {$wait == $max_wait} {
125 puts "Forcing process $pid to crash..."
126 catch {exec kill -SEGV $pid}
127 } elseif {$wait >= $max_wait * 2} {
128 puts "Forcing process $pid to exit..."
129 catch {exec kill -KILL $pid}
130 } elseif {$wait % 1000 == 0} {
131 puts "Waiting for process $pid to exit..."
132 }
133 after 10
134 }
135
136 # Check valgrind errors if needed
137 if {$::valgrind} {
138 check_valgrind_errors [dict get $config stderr]
139 }
140
141 check_sanitizer_errors [dict get $config stderr]
142
143 # Remove this pid from the set of active pids in the test server.
144 send_data_packet $::test_server_fd server-killed $pid
145}
146
147proc is_alive pid {
148 if {[catch {exec kill -0 $pid} err]} {
149 return 0
150 } else {
151 return 1
152 }
153}
154
155proc ping_server {host port} {
156 set retval 0
157 if {[catch {
158 if {$::tls} {
159 set fd [::tls::socket $host $port]
160 } else {
161 set fd [socket $host $port]
162 }
163 fconfigure $fd -translation binary
164 puts $fd "PING\r\n"
165 flush $fd
166 set reply [gets $fd]
167 if {[string range $reply 0 0] eq {+} ||
168 [string range $reply 0 0] eq {-}} {
169 set retval 1
170 }
171 close $fd
172 } e]} {
173 if {$::verbose} {
174 puts -nonewline "."
175 }
176 } else {
177 if {$::verbose} {
178 puts -nonewline "ok"
179 }
180 }
181 return $retval
182}
183
184# Return 1 if the server at the specified addr is reachable by PING, otherwise
185# returns 0. Performs a try every 50 milliseconds for the specified number
186# of retries.
187proc server_is_up {host port retrynum} {
188 after 10 ;# Use a small delay to make likely a first-try success.
189 set retval 0
190 while {[incr retrynum -1]} {
191 if {[catch {ping_server $host $port} ping]} {
192 set ping 0
193 }
194 if {$ping} {return 1}
195 after 50
196 }
197 return 0
198}
199
200# Check if current ::tags match requested tags. If ::allowtags are used,
201# there must be some intersection. If ::denytags are used, no intersection
202# is allowed. Returns 1 if tags are acceptable or 0 otherwise, in which
203# case err_return names a return variable for the message to be logged.
204proc tags_acceptable {tags err_return} {
205 upvar $err_return err
206
207 # If tags are whitelisted, make sure there's match
208 if {[llength $::allowtags] > 0} {
209 set matched 0
210 foreach tag $::allowtags {
211 if {[lsearch $tags $tag] >= 0} {
212 incr matched
213 }
214 }
215 if {$matched < 1} {
216 set err "Tag: none of the tags allowed"
217 return 0
218 }
219 }
220
221 foreach tag $::denytags {
222 if {[lsearch $tags $tag] >= 0} {
223 set err "Tag: $tag denied"
224 return 0
225 }
226 }
227
228 # some units mess with the client output buffer so we can't really use the req-res logging mechanism.
229 if {$::log_req_res && [lsearch $tags "logreqres:skip"] >= 0} {
230 set err "Not supported when running in log-req-res mode"
231 return 0
232 }
233
234 if {$::external && [lsearch $tags "external:skip"] >= 0} {
235 set err "Not supported on external server"
236 return 0
237 }
238
239 if {$::debug_defrag && [lsearch $tags "debug_defrag:skip"] >= 0} {
240 set err "Not supported on server compiled with DEBUG_DEFRAG option"
241 return 0
242 }
243
244 if {$::singledb && [lsearch $tags "singledb:skip"] >= 0} {
245 set err "Not supported on singledb"
246 return 0
247 }
248
249 if {$::cluster_mode && [lsearch $tags "cluster:skip"] >= 0} {
250 set err "Not supported in cluster mode"
251 return 0
252 }
253
254 if {$::tsan && [lsearch $tags "tsan:skip"] >= 0} {
255 set err "Not supported under thread sanitizer"
256 return 0
257 }
258
259 if {$::tls && [lsearch $tags "tls:skip"] >= 0} {
260 set err "Not supported in tls mode"
261 return 0
262 }
263
264 if {!$::large_memory && [lsearch $tags "large-memory"] >= 0} {
265 set err "large memory flag not provided"
266 return 0
267 }
268
269 if { [lsearch $tags "experimental"] >=0 && [lsearch $::allowtags "experimental"] == -1 } {
270 set err "experimental test not allowed"
271 return 0
272 }
273
274 return 1
275}
276
277# doesn't really belong here, but highly coupled to code in start_server
278proc tags {tags code} {
279 # If we 'tags' contain multiple tags, quoted and separated by spaces,
280 # we want to get rid of the quotes in order to have a proper list
281 set tags [string map { \" "" } $tags]
282 set ::tags [concat $::tags $tags]
283 if {![tags_acceptable $::tags err]} {
284 incr ::num_aborted
285 send_data_packet $::test_server_fd ignore $err
286 set ::tags [lrange $::tags 0 end-[llength $tags]]
287 return
288 }
289 if {[catch {uplevel 1 $code} error]} {
290 set ::tags [lrange $::tags 0 end-[llength $tags]]
291 error $error $::errorInfo
292 }
293 set ::tags [lrange $::tags 0 end-[llength $tags]]
294}
295
296# Write the configuration in the dictionary 'config' in the specified
297# file name.
298proc create_server_config_file {filename config config_lines} {
299 set fp [open $filename w+]
300 foreach directive [dict keys $config] {
301 puts -nonewline $fp "$directive "
302 puts $fp [dict get $config $directive]
303 }
304 foreach {config_line_directive config_line_args} $config_lines {
305 puts $fp "$config_line_directive $config_line_args"
306 }
307 close $fp
308}
309
310proc spawn_server {config_file stdout stderr args} {
311 set cmd [list src/redis-server $config_file]
312 set args {*}$args
313 if {[llength $args] > 0} {
314 lappend cmd {*}$args
315 }
316
317 if {$::valgrind} {
318 set pid [exec valgrind --track-origins=yes --trace-children=yes --suppressions=[pwd]/src/valgrind.sup --show-reachable=no --show-possibly-lost=no --leak-check=full {*}$cmd >> $stdout 2>> $stderr &]
319 } elseif ($::stack_logging) {
320 set pid [exec /usr/bin/env MallocStackLogging=1 MallocLogFile=/tmp/malloc_log.txt {*}$cmd >> $stdout 2>> $stderr &]
321 } else {
322 # ASAN_OPTIONS environment variable is for address sanitizer. If a test
323 # tries to allocate huge memory area and expects allocator to return
324 # NULL, address sanitizer throws an error without this setting.
325 set env [list \
326 "ASAN_OPTIONS=allocator_may_return_null=1" \
327 "MSAN_OPTIONS=allocator_may_return_null=1" \
328 "TSAN_OPTIONS=allocator_may_return_null=1,detect_deadlocks=0,suppressions=src/tsan.sup" \
329 ]
330 set pid [exec /usr/bin/env {*}$env {*}$cmd >> $stdout 2>> $stderr &]
331 }
332
333 if {$::wait_server} {
334 set msg "server started PID: $pid. press any key to continue..."
335 puts $msg
336 read stdin 1
337 }
338
339 # Tell the test server about this new instance.
340 send_data_packet $::test_server_fd server-spawned $pid
341 return $pid
342}
343
344# Wait for actual startup, return 1 if port is busy, 0 otherwise
345proc wait_server_started {config_file stdout pid} {
346 set checkperiod 100; # Milliseconds
347 set maxiter [expr {120*1000/$checkperiod}] ; # Wait up to 2 minutes.
348 set port_busy 0
349 while 1 {
350 if {[regexp -- " PID: $pid.*Server initialized" [exec cat $stdout]]} {
351 break
352 }
353 after $checkperiod
354 incr maxiter -1
355 if {$maxiter == 0} {
356 start_server_error $config_file "No PID detected in log $stdout"
357 puts "--- LOG CONTENT ---"
358 puts [exec cat $stdout]
359 puts "-------------------"
360 break
361 }
362
363 # Check if the port is actually busy and the server failed
364 # for this reason.
365 if {[regexp {Failed listening on port} [exec cat $stdout]]} {
366 set port_busy 1
367 break
368 }
369 }
370 return $port_busy
371}
372
373proc dump_server_log {srv} {
374 set pid [dict get $srv "pid"]
375 puts "\n===== Start of server log (pid $pid) =====\n"
376 puts [exec cat [dict get $srv "stdout"]]
377 puts "===== End of server log (pid $pid) =====\n"
378
379 puts "\n===== Start of server stderr log (pid $pid) =====\n"
380 puts [exec cat [dict get $srv "stderr"]]
381 puts "===== End of server stderr log (pid $pid) =====\n"
382}
383
384proc run_external_server_test {code overrides} {
385 set srv {}
386 dict set srv "host" $::host
387 dict set srv "port" $::port
388 set client [redis $::host $::port 0 $::tls]
389 dict set srv "client" $client
390 if {!$::singledb} {
391 $client select 9
392 }
393
394 set config {}
395 dict set config "port" $::port
396 dict set srv "config" $config
397
398 # append the server to the stack
399 lappend ::servers $srv
400
401 if {[llength $::servers] > 1} {
402 if {$::verbose} {
403 puts "Notice: nested start_server statements in external server mode, test must be aware of that!"
404 }
405 }
406
407 r flushall
408 r function flush
409 r script flush
410 r config resetstat
411
412 # store configs
413 set saved_config {}
414 foreach {param val} [r config get *] {
415 dict set saved_config $param $val
416 }
417
418 # apply overrides
419 foreach {param val} $overrides {
420 r config set $param $val
421
422 # If we enable appendonly, wait for for rewrite to complete. This is
423 # required for tests that begin with a bg* command which will fail if
424 # the rewriteaof operation is not completed at this point.
425 if {$param == "appendonly" && $val == "yes"} {
426 waitForBgrewriteaof r
427 }
428 }
429
430 if {[catch {set retval [uplevel 2 $code]} error]} {
431 if {$::durable} {
432 set msg [string range $error 10 end]
433 lappend details $msg
434 lappend details $::errorInfo
435 lappend ::tests_failed $details
436
437 incr ::num_failed
438 send_data_packet $::test_server_fd err [join $details "\n"]
439 } else {
440 # Re-raise, let handler up the stack take care of this.
441 error $error $::errorInfo
442 }
443 }
444
445 # restore overrides
446 dict for {param val} $saved_config {
447 # some may fail, specifically immutable ones.
448 catch {r config set $param $val}
449 }
450
451 set srv [lpop ::servers]
452
453 if {[dict exists $srv "client"]} {
454 [dict get $srv "client"] close
455 }
456}
457
458proc start_server {options {code undefined}} {
459 # setup defaults
460 set baseconfig "default.conf"
461 set overrides {}
462 set omit {}
463 set tags {}
464 set args {}
465 set keep_persistence false
466 set config_lines {}
467
468 # Wait for the server to be ready and check for server liveness/client connectivity before starting the test.
469 set wait_ready true
470
471 # parse options
472 foreach {option value} $options {
473 switch $option {
474 "config" {
475 set baseconfig $value
476 }
477 "overrides" {
478 set overrides [concat $overrides $value]
479 }
480 "config_lines" {
481 set config_lines $value
482 }
483 "args" {
484 set args $value
485 }
486 "omit" {
487 set omit $value
488 }
489 "tags" {
490 # If we 'tags' contain multiple tags, quoted and separated by spaces,
491 # we want to get rid of the quotes in order to have a proper list
492 set _tags [string map { \" "" } $value]
493 set tags [concat $tags $_tags]
494 }
495 "keep_persistence" {
496 set keep_persistence $value
497 }
498 "wait_ready" {
499 set wait_ready $value
500 }
501 default {
502 error "Unknown option $option"
503 }
504 }
505 }
506 set ::tags [concat $::tags $tags]
507
508 # We skip unwanted tags
509 if {![tags_acceptable $::tags err]} {
510 incr ::num_aborted
511 send_data_packet $::test_server_fd ignore $err
512 set ::tags [lrange $::tags 0 end-[llength $tags]]
513 return
514 }
515
516 # If we are running against an external server, we just push the
517 # host/port pair in the stack the first time
518 if {$::external} {
519 run_external_server_test $code $overrides
520
521 set ::tags [lrange $::tags 0 end-[llength $tags]]
522 return
523 }
524
525 set data [split [exec cat "tests/assets/$baseconfig"] "\n"]
526 set config {}
527 if {$::tls} {
528 if {$::tls_module} {
529 lappend config_lines [list "loadmodule" [format "%s/src/redis-tls.so" [pwd]]]
530 }
531 dict set config "tls-cert-file" [format "%s/tests/tls/server.crt" [pwd]]
532 dict set config "tls-key-file" [format "%s/tests/tls/server.key" [pwd]]
533 dict set config "tls-client-cert-file" [format "%s/tests/tls/client.crt" [pwd]]
534 dict set config "tls-client-key-file" [format "%s/tests/tls/client.key" [pwd]]
535 dict set config "tls-dh-params-file" [format "%s/tests/tls/redis.dh" [pwd]]
536 dict set config "tls-ca-cert-file" [format "%s/tests/tls/ca.crt" [pwd]]
537 dict set config "loglevel" "debug"
538 }
539 foreach line $data {
540 if {[string length $line] > 0 && [string index $line 0] ne "#"} {
541 set elements [split $line " "]
542 set directive [lrange $elements 0 0]
543 set arguments [lrange $elements 1 end]
544 dict set config $directive $arguments
545 }
546 }
547
548 # use a different directory every time a server is started
549 dict set config dir [tmpdir server]
550
551 # start every server on a different port
552 set port [find_available_port $::baseport $::portcount]
553 if {$::tls} {
554 set pport [find_available_port $::baseport $::portcount]
555 dict set config "port" $pport
556 dict set config "tls-port" $port
557 dict set config "tls-cluster" "yes"
558 dict set config "tls-replication" "yes"
559 } else {
560 dict set config port $port
561 }
562
563 set unixsocket [file normalize [format "%s/%s" [dict get $config "dir"] "socket"]]
564 dict set config "unixsocket" $unixsocket
565
566 # apply overrides from global space and arguments
567 foreach {directive arguments} [concat $::global_overrides $overrides] {
568 dict set config $directive $arguments
569 }
570
571 # remove directives that are marked to be omitted
572 foreach directive $omit {
573 dict unset config $directive
574 }
575
576 if {$::log_req_res} {
577 dict set config "req-res-logfile" "stdout.reqres"
578 }
579
580 if {$::force_resp3} {
581 dict set config "client-default-resp" "3"
582 }
583
584 if {$::debug_defrag} {
585 dict set config "activedefrag" "yes" ;# defrag enabled
586 dict set config "active-defrag-cycle-min" "65"
587 dict set config "active-defrag-cycle-max" "75"
588 }
589
590 # write new configuration to temporary file
591 set config_file [tmpfile redis.conf]
592 create_server_config_file $config_file $config $config_lines
593
594 set stdout [format "%s/%s" [dict get $config "dir"] "stdout"]
595 set stderr [format "%s/%s" [dict get $config "dir"] "stderr"]
596
597 # if we're inside a test, write the test name to the server log file
598 if {[info exists ::cur_test]} {
599 set fd [open $stdout "a+"]
600 puts $fd "### Starting server for test $::cur_test"
601 close $fd
602 if {$::verbose > 1} {
603 puts "### Starting server $stdout for test - $::cur_test"
604 }
605 }
606
607 # We may have a stdout left over from the previous tests, so we need
608 # to get the current count of ready logs
609 set previous_ready_count [count_message_lines $stdout "Ready to accept"]
610
611 # We need a loop here to retry with different ports.
612 set server_started 0
613 while {$server_started == 0} {
614 if {$::verbose} {
615 puts -nonewline "=== ($tags) Starting server ${::host}:${port} "
616 }
617
618 send_data_packet $::test_server_fd "server-spawning" "port $port"
619
620 set pid [spawn_server $config_file $stdout $stderr $args]
621
622 # check that the server actually started
623 set port_busy [wait_server_started $config_file $stdout $pid]
624
625 # Sometimes we have to try a different port, even if we checked
626 # for availability. Other test clients may grab the port before we
627 # are able to do it for example.
628 if {$port_busy} {
629 puts "Port $port was already busy, trying another port..."
630 set port [find_available_port $::baseport $::portcount]
631 if {$::tls} {
632 set pport [find_available_port $::baseport $::portcount]
633 dict set config port $pport
634 dict set config "tls-port" $port
635 } else {
636 dict set config port $port
637 }
638 create_server_config_file $config_file $config $config_lines
639
640 # Truncate log so wait_server_started will not be looking at
641 # output of the failed server.
642 close [open $stdout "w"]
643
644 continue; # Try again
645 }
646
647 if {$::valgrind} {set retrynum 1000} else {set retrynum 100}
648 if {$code ne "undefined" && $wait_ready} {
649 set serverisup [server_is_up $::host $port $retrynum]
650 } else {
651 set serverisup 1
652 }
653
654 if {$::verbose} {
655 puts ""
656 }
657
658 if {!$serverisup} {
659 set err {}
660 append err [exec cat $stdout] "\n" [exec cat $stderr]
661 start_server_error $config_file $err
662 set ::tags [lrange $::tags 0 end-[llength $tags]]
663 return
664 }
665 set server_started 1
666 }
667
668 # setup properties to be able to initialize a client object
669 set port_param [expr $::tls ? {"tls-port"} : {"port"}]
670 set host $::host
671 if {[dict exists $config bind]} { set host [dict get $config bind] }
672 if {[dict exists $config $port_param]} { set port [dict get $config $port_param] }
673
674 # setup config dict
675 dict set srv "config_file" $config_file
676 dict set srv "config" $config
677 dict set srv "pid" $pid
678 dict set srv "host" $host
679 dict set srv "port" $port
680 dict set srv "stdout" $stdout
681 dict set srv "stderr" $stderr
682 dict set srv "unixsocket" $unixsocket
683 if {$::tls} {
684 dict set srv "pport" $pport
685 }
686
687 # if a block of code is supplied, we wait for the server to become
688 # available, create a client object and kill the server afterwards
689 if {$code ne "undefined"} {
690 set line [exec head -n1 $stdout]
691 if {[string match {*already in use*} $line]} {
692 set ::tags [lrange $::tags 0 end-[llength $tags]]
693 error_and_quit $config_file $line
694 }
695
696 # append the server to the stack
697 lappend ::servers $srv
698
699 if {$wait_ready} {
700 while 1 {
701 # check that the server actually started and is ready for connections
702 if {[count_message_lines $stdout "Ready to accept"] > $previous_ready_count} {
703 break
704 }
705 after 10
706 }
707
708 # connect client (after server dict is put on the stack)
709 reconnect
710 }
711
712 # remember previous num_failed to catch new errors
713 set prev_num_failed $::num_failed
714
715 # execute provided block
716 set num_tests $::num_tests
717 if {[catch { uplevel 1 $code } error]} {
718 set backtrace $::errorInfo
719 set assertion [string match "assertion:*" $error]
720
721 # fetch srv back from the server list, in case it was restarted by restart_server (new PID)
722 set srv [lindex $::servers end]
723
724 # pop the server object
725 set ::servers [lrange $::servers 0 end-1]
726
727 # Kill the server without checking for leaks
728 dict set srv "skipleaks" 1
729 kill_server $srv
730
731 if {$::dump_logs && $assertion} {
732 # if we caught an assertion ($::num_failed isn't incremented yet)
733 # this happens when the test spawns a server and not the other way around
734 dump_server_log $srv
735 } else {
736 # Print crash report from log
737 set crashlog [crashlog_from_file [dict get $srv "stdout"]]
738 if {[string length $crashlog] > 0} {
739 puts [format "\nLogged crash report (pid %d):" [dict get $srv "pid"]]
740 puts "$crashlog"
741 puts ""
742 }
743
744 set sanitizerlog [sanitizer_errors_from_file [dict get $srv "stderr"]]
745 if {[string length $sanitizerlog] > 0} {
746 puts [format "\nLogged sanitizer errors (pid %d):" [dict get $srv "pid"]]
747 puts "$sanitizerlog"
748 puts ""
749 }
750 }
751
752 if {!$assertion && $::durable} {
753 # durable is meant to prevent the whole tcl test from exiting on
754 # an exception. an assertion will be caught by the test proc.
755 set msg [string range $error 10 end]
756 lappend details $msg
757 lappend details $backtrace
758 lappend ::tests_failed $details
759
760 incr ::num_failed
761 send_data_packet $::test_server_fd err [join $details "\n"]
762 } else {
763 # Re-raise, let handler up the stack take care of this.
764 set ::tags [lrange $::tags 0 end-[llength $tags]]
765 error $error $backtrace
766 }
767 } else {
768 if {$::dump_logs && $prev_num_failed != $::num_failed} {
769 dump_server_log $srv
770 }
771 }
772
773 # fetch srv back from the server list, in case it was restarted by restart_server (new PID)
774 set srv [lindex $::servers end]
775
776 # pop the server object
777 set ::servers [lrange $::servers 0 end-1]
778
779 set ::tags [lrange $::tags 0 end-[llength $tags]]
780 kill_server $srv
781 if {!$keep_persistence} {
782 clean_persistence $srv
783 }
784 set _ ""
785 } else {
786 set ::tags [lrange $::tags 0 end-[llength $tags]]
787 set _ $srv
788 }
789}
790
791# Start multiple servers with the same options, run code, then stop them.
792proc start_multiple_servers {num options code} {
793 for {set i 0} {$i < $num} {incr i} {
794 set code [list start_server $options $code]
795 }
796 uplevel 1 $code
797}
798
799proc restart_server {level wait_ready rotate_logs {reconnect 1} {shutdown sigterm}} {
800 set srv [lindex $::servers end+$level]
801 if {$shutdown ne {sigterm}} {
802 catch {[dict get $srv "client"] shutdown $shutdown}
803 }
804 # Kill server doesn't mind if the server is already dead
805 kill_server $srv
806 # Remove the default client from the server
807 dict unset srv "client"
808
809 set pid [dict get $srv "pid"]
810 set stdout [dict get $srv "stdout"]
811 set stderr [dict get $srv "stderr"]
812 if {$rotate_logs} {
813 set ts [clock format [clock seconds] -format %y%m%d%H%M%S]
814 file rename $stdout $stdout.$ts.$pid
815 file rename $stderr $stderr.$ts.$pid
816 }
817 set prev_ready_count [count_message_lines $stdout "Ready to accept"]
818
819 # if we're inside a test, write the test name to the server log file
820 if {[info exists ::cur_test]} {
821 set fd [open $stdout "a+"]
822 puts $fd "### Restarting server for test $::cur_test"
823 close $fd
824 }
825
826 set config_file [dict get $srv "config_file"]
827
828 set pid [spawn_server $config_file $stdout $stderr {}]
829
830 # check that the server actually started
831 wait_server_started $config_file $stdout $pid
832
833 # update the pid in the servers list
834 dict set srv "pid" $pid
835 # re-set $srv in the servers list
836 lset ::servers end+$level $srv
837
838 if {$wait_ready} {
839 while 1 {
840 # check that the server actually started and is ready for connections
841 if {[count_message_lines $stdout "Ready to accept"] > $prev_ready_count} {
842 break
843 }
844 after 10
845 }
846 }
847 if {$reconnect} {
848 reconnect $level
849 }
850}
diff --git a/examples/redis-unstable/tests/support/test.tcl b/examples/redis-unstable/tests/support/test.tcl
deleted file mode 100644
index 60fd0a9..0000000
--- a/examples/redis-unstable/tests/support/test.tcl
+++ /dev/null
@@ -1,280 +0,0 @@
1set ::num_tests 0
2set ::num_passed 0
3set ::num_failed 0
4set ::num_skipped 0
5set ::num_aborted 0
6set ::tests_failed {}
7set ::cur_test ""
8
9proc fail {msg} {
10 error "assertion:$msg"
11}
12
13proc assert {condition} {
14 if {![uplevel 1 [list expr $condition]]} {
15 set context "(context: [info frame -1])"
16 error "assertion:Expected [uplevel 1 [list subst -nocommands $condition]] $context"
17 }
18}
19
20proc assert_no_match {pattern value} {
21 if {[string match $pattern $value]} {
22 set context "(context: [info frame -1])"
23 error "assertion:Expected '$value' to not match '$pattern' $context"
24 }
25}
26
27proc assert_match {pattern value {detail ""} {context ""}} {
28 if {![string match $pattern $value]} {
29 if {$context eq ""} {
30 set context "(context: [info frame -1])"
31 }
32 error "assertion:Expected '$value' to match '$pattern' $context $detail"
33 }
34}
35
36proc assert_failed {expected_err detail} {
37 if {$detail ne ""} {
38 set detail "(detail: $detail)"
39 } else {
40 set detail "(context: [info frame -2])"
41 }
42 error "assertion:$expected_err $detail"
43}
44
45proc assert_not_equal {value expected {detail ""}} {
46 if {!($expected ne $value)} {
47 assert_failed "Expected '$value' not equal to '$expected'" $detail
48 }
49}
50
51proc assert_equal {value expected {detail ""}} {
52 if {$expected ne $value} {
53 assert_failed "Expected '$value' to be equal to '$expected'" $detail
54 }
55}
56
57proc assert_lessthan {value expected {detail ""}} {
58 if {!($value < $expected)} {
59 assert_failed "Expected '$value' to be less than '$expected'" $detail
60 }
61}
62
63proc assert_lessthan_equal {value expected {detail ""}} {
64 if {!($value <= $expected)} {
65 assert_failed "Expected '$value' to be less than or equal to '$expected'" $detail
66 }
67}
68
69proc assert_morethan {value expected {detail ""}} {
70 if {!($value > $expected)} {
71 assert_failed "Expected '$value' to be more than '$expected'" $detail
72 }
73}
74
75proc assert_morethan_equal {value expected {detail ""}} {
76 if {!($value >= $expected)} {
77 assert_failed "Expected '$value' to be more than or equal to '$expected'" $detail
78 }
79}
80
81proc assert_range {value min max {detail ""}} {
82 if {!($value <= $max && $value >= $min)} {
83 assert_failed "Expected '$value' to be between to '$min' and '$max'" $detail
84 }
85}
86
87proc assert_error {pattern code {detail ""}} {
88 if {[catch {uplevel 1 $code} error]} {
89 assert_match $pattern $error $detail
90 } else {
91 assert_failed "Expected an error matching '$pattern' but got '$error'" $detail
92 }
93}
94
95proc assert_encoding {enc key} {
96 if {$::ignoreencoding} {
97 return
98 }
99 set val [r object encoding $key]
100 assert_match $enc $val
101}
102
103proc assert_type {type key} {
104 assert_equal $type [r type $key]
105}
106
107proc assert_refcount {ref key} {
108 if {[lsearch $::denytags "needs:debug"] >= 0} {
109 return
110 }
111
112 set val [r object refcount $key]
113 assert_equal $ref $val
114}
115
116proc assert_refcount_morethan {key ref} {
117 if {[lsearch $::denytags "needs:debug"] >= 0} {
118 return
119 }
120
121 set val [r object refcount $key]
122 assert_morethan $val $ref
123}
124
125# Wait for the specified condition to be true, with the specified number of
126# max retries and delay between retries. Otherwise the 'elsescript' is
127# executed.
128proc wait_for_condition {maxtries delay e _else_ elsescript} {
129 if {$_else_ ne "else"} {
130 error "$_else_ must be equal to \"else\""
131 }
132
133 while {[incr maxtries -1] >= 0} {
134 set errcode [catch {uplevel 1 [list expr $e]} result]
135 if {$errcode == 0} {
136 if {$result} break
137 } else {
138 return -code $errcode $result
139 }
140 after $delay
141 }
142 if {$maxtries == -1} {
143 set errcode [catch {uplevel 1 $elsescript} result]
144 return -code $errcode $result
145 }
146}
147
148# try to match a value to a list of patterns that are either regex (starts with "/") or plain string.
149# The caller can specify to use only glob-pattern match
150proc search_pattern_list {value pattern_list {glob_pattern false}} {
151 foreach el $pattern_list {
152 if {[string length $el] == 0} { continue }
153 if { $glob_pattern } {
154 if {[string match $el $value]} {
155 return 1
156 }
157 continue
158 }
159 if {[string equal / [string index $el 0]] && [regexp -- [string range $el 1 end] $value]} {
160 return 1
161 } elseif {[string equal $el $value]} {
162 return 1
163 }
164 }
165 return 0
166}
167
168proc test {name code {okpattern undefined} {tags {}}} {
169 # abort if test name in skiptests
170 if {[search_pattern_list $name $::skiptests]} {
171 incr ::num_skipped
172 send_data_packet $::test_server_fd skip $name
173 return
174 }
175 if {$::verbose > 1} {
176 puts "starting test $name"
177 }
178 # abort if only_tests was set but test name is not included
179 if {[llength $::only_tests] > 0 && ![search_pattern_list $name $::only_tests]} {
180 incr ::num_skipped
181 send_data_packet $::test_server_fd skip $name
182 return
183 }
184
185 set tags [concat $::tags $tags]
186 if {![tags_acceptable $tags err]} {
187 incr ::num_aborted
188 send_data_packet $::test_server_fd ignore "$name: $err"
189 return
190 }
191
192 incr ::num_tests
193 set details {}
194 lappend details "$name in $::curfile"
195
196 # set a cur_test global to be logged into new servers that are spawn
197 # and log the test name in all existing servers
198 set prev_test $::cur_test
199 set ::cur_test "$name in $::curfile"
200 if {$::external} {
201 catch {
202 set r [redis [srv 0 host] [srv 0 port] 0 $::tls]
203 catch {
204 $r debug log "### Starting test $::cur_test"
205 }
206 $r close
207 }
208 } else {
209 set servers {}
210 foreach srv $::servers {
211 set stdout [dict get $srv stdout]
212 set fd [open $stdout "a+"]
213 puts $fd "### Starting test $::cur_test"
214 close $fd
215 lappend servers $stdout
216 }
217 if {$::verbose > 1} {
218 puts "### Starting test $::cur_test - with servers: $servers"
219 }
220 }
221
222 send_data_packet $::test_server_fd testing $name
223
224 set failed false
225 set test_start_time [clock milliseconds]
226 if {[catch {set retval [uplevel 1 $code]} error]} {
227 set assertion [string match "assertion:*" $error]
228 if {$assertion || $::durable} {
229 # durable prevents the whole tcl test from exiting on an exception.
230 # an assertion is handled gracefully anyway.
231 set msg [string range $error 10 end]
232 lappend details $msg
233 if {!$assertion} {
234 lappend details $::errorInfo
235 }
236 lappend ::tests_failed $details
237
238 incr ::num_failed
239 set failed true
240 send_data_packet $::test_server_fd err [join $details "\n"]
241
242 if {$::stop_on_failure} {
243 puts "Test error (last server port:[srv port], log:[srv stdout]), press enter to teardown the test."
244 flush stdout
245 gets stdin
246 }
247 } else {
248 # Re-raise, let handler up the stack take care of this.
249 error $error $::errorInfo
250 }
251 } else {
252 if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
253 incr ::num_passed
254 set elapsed [expr {[clock milliseconds]-$test_start_time}]
255 send_data_packet $::test_server_fd ok $name $elapsed
256 } else {
257 set msg "Expected '$okpattern' to equal or match '$retval'"
258 lappend details $msg
259 lappend ::tests_failed $details
260
261 incr ::num_failed
262 set failed true
263 send_data_packet $::test_server_fd err [join $details "\n"]
264 }
265 }
266
267 if {$::dump_logs && $failed} {
268 foreach srv $::servers {
269 dump_server_log $srv
270 }
271 }
272
273 if {$::traceleaks} {
274 set output [exec leaks redis-server]
275 if {![string match {*0 leaks*} $output]} {
276 send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
277 }
278 }
279 set ::cur_test $prev_test
280}
diff --git a/examples/redis-unstable/tests/support/tmpfile.tcl b/examples/redis-unstable/tests/support/tmpfile.tcl
deleted file mode 100644
index 809f587..0000000
--- a/examples/redis-unstable/tests/support/tmpfile.tcl
+++ /dev/null
@@ -1,15 +0,0 @@
1set ::tmpcounter 0
2set ::tmproot "./tests/tmp"
3file mkdir $::tmproot
4
5# returns a dirname unique to this process to write to
6proc tmpdir {basename} {
7 set dir [file join $::tmproot $basename.[pid].[incr ::tmpcounter]]
8 file mkdir $dir
9 set _ $dir
10}
11
12# return a filename unique to this process to write to
13proc tmpfile {basename} {
14 file join $::tmproot $basename.[pid].[incr ::tmpcounter]
15}
diff --git a/examples/redis-unstable/tests/support/util.tcl b/examples/redis-unstable/tests/support/util.tcl
deleted file mode 100644
index 5d06c8c..0000000
--- a/examples/redis-unstable/tests/support/util.tcl
+++ /dev/null
@@ -1,1288 +0,0 @@
1#
2# Copyright (c) 2009-Present, Redis Ltd.
3# All rights reserved.
4#
5# Copyright (c) 2024-present, Valkey contributors.
6# All rights reserved.
7#
8# Licensed under your choice of (a) the Redis Source Available License 2.0
9# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the
10# GNU Affero General Public License v3 (AGPLv3).
11#
12# Portions of this file are available under BSD3 terms; see REDISCONTRIBUTIONS for more information.
13#
14
15proc randstring {min max {type binary}} {
16 set len [expr {$min+int(rand()*($max-$min+1))}]
17 set output {}
18 if {$type eq {binary}} {
19 set minval 0
20 set maxval 255
21 } elseif {$type eq {alpha} || $type eq {simplealpha}} {
22 set minval 48
23 set maxval 122
24 } elseif {$type eq {compr}} {
25 set minval 48
26 set maxval 52
27 }
28 while {$len} {
29 set num [expr {$minval+int(rand()*($maxval-$minval+1))}]
30 set rr [format "%c" $num]
31 if {$type eq {simplealpha} && ![string is alnum $rr]} {continue}
32 if {$type eq {alpha} && $num eq 92} {continue} ;# avoid putting '\' char in the string, it can mess up TCL processing
33 append output $rr
34 incr len -1
35 }
36 return $output
37}
38
39# Useful for some test
40proc zlistAlikeSort {a b} {
41 if {[lindex $a 0] > [lindex $b 0]} {return 1}
42 if {[lindex $a 0] < [lindex $b 0]} {return -1}
43 string compare [lindex $a 1] [lindex $b 1]
44}
45
46# Return all log lines starting with the first line that contains a warning.
47# Generally, this will be an assertion error with a stack trace.
48proc crashlog_from_file {filename} {
49 set lines [split [exec cat $filename] "\n"]
50 set matched 0
51 set logall 0
52 set result {}
53 foreach line $lines {
54 if {[string match {*REDIS BUG REPORT START*} $line]} {
55 set logall 1
56 }
57 if {[regexp {^\[\d+\]\s+\d+\s+\w+\s+\d{2}:\d{2}:\d{2} \#} $line]} {
58 set matched 1
59 }
60 if {$logall || $matched} {
61 lappend result $line
62 }
63 }
64 join $result "\n"
65}
66
67# Return sanitizer log lines
68proc sanitizer_errors_from_file {filename} {
69 set log [exec cat $filename]
70 set lines [split [exec cat $filename] "\n"]
71
72 foreach line $lines {
73 # Ignore huge allocation warnings for both ASan and MSan
74 if ([string match {*WARNING: AddressSanitizer failed to allocate*} $line]) {
75 continue
76 }
77
78 if ([string match {*WARNING: MemorySanitizer failed to allocate*} $line]) {
79 continue
80 }
81
82 # GCC UBSAN output does not contain 'Sanitizer' but 'runtime error'.
83 if {[string match {*runtime error*} $line] ||
84 [string match {*Sanitizer*} $line]} {
85 return $log
86 }
87 }
88
89 return ""
90}
91
92proc getInfoProperty {infostr property} {
93 if {[regexp -lineanchor "^$property:(.*?)\r\n" $infostr _ value]} {
94 return $value
95 }
96}
97
98# Return value for INFO property
99proc status {r property} {
100 set _ [getInfoProperty [{*}$r info] $property]
101}
102
103proc waitForBgsave r {
104 while 1 {
105 if {[status $r rdb_bgsave_in_progress] eq 1} {
106 if {$::verbose} {
107 puts -nonewline "\nWaiting for background save to finish... "
108 flush stdout
109 }
110 after 50
111 } else {
112 break
113 }
114 }
115}
116
117proc waitForBgrewriteaof r {
118 while 1 {
119 if {[status $r aof_rewrite_in_progress] eq 1} {
120 if {$::verbose} {
121 puts -nonewline "\nWaiting for background AOF rewrite to finish... "
122 flush stdout
123 }
124 after 50
125 } else {
126 break
127 }
128 }
129}
130
131proc wait_for_sync r {
132 set maxtries 50
133 # tsan adds significant overhead to the execution time, so we increase the
134 # wait time here JIC
135 if {$::tsan} {
136 set maxtries 100
137 }
138
139 wait_for_condition $maxtries 100 {
140 [status $r master_link_status] eq "up"
141 } else {
142 fail "replica didn't sync in time"
143 }
144}
145
146proc wait_replica_online {r {replica_id 0} {maxtries 50} {delay 100}} {
147 # tsan adds significant overhead to the execution time, so we increase the
148 # wait time here JIC
149 if {$::tsan} {
150 set maxtries [expr {$maxtries * 2}]
151 }
152
153 wait_for_condition $maxtries $delay {
154 [string match "*slave$replica_id:*,state=online*" [$r info replication]]
155 } else {
156 fail "replica $replica_id did not become online in time"
157 }
158}
159
160proc wait_for_ofs_sync {r1 r2} {
161 set maxtries 50
162 # tsan adds significant overhead to the execution time, so we increase the
163 # wait time here JIC
164 if {$::tsan} {
165 set maxtries 100
166 }
167 wait_for_condition $maxtries 100 {
168 [status $r1 master_repl_offset] eq [status $r2 master_repl_offset]
169 } else {
170 fail "replica offset didn't match in time"
171 }
172}
173
174proc wait_done_loading r {
175 wait_for_condition 50 100 {
176 [catch {$r ping} e] == 0
177 } else {
178 fail "Loading DB is taking too much time."
179 }
180}
181
182proc wait_lazyfree_done r {
183 wait_for_condition 50 100 {
184 [status $r lazyfree_pending_objects] == 0
185 } else {
186 fail "lazyfree isn't done"
187 }
188}
189
190# count current log lines in server's stdout
191proc count_log_lines {srv_idx} {
192 set _ [string trim [exec wc -l < [srv $srv_idx stdout]]]
193}
194
195# returns the number of times a line with that pattern appears in a file
196proc count_message_lines {file pattern} {
197 set res 0
198 # exec fails when grep exists with status other than 0 (when the pattern wasn't found)
199 catch {
200 set res [string trim [exec grep $pattern $file 2> /dev/null | wc -l]]
201 }
202 return $res
203}
204
205# returns the number of times a line with that pattern appears in the log
206proc count_log_message {srv_idx pattern} {
207 set stdout [srv $srv_idx stdout]
208 return [count_message_lines $stdout $pattern]
209}
210
211# verify pattern exists in server's sdtout after a certain line number
212proc verify_log_message {srv_idx pattern from_line} {
213 incr from_line
214 set result [exec tail -n +$from_line < [srv $srv_idx stdout]]
215 if {![string match $pattern $result]} {
216 error "assertion:expected message not found in log file: $pattern"
217 }
218}
219
220# wait for pattern to be found in server's stdout after certain line number
221# return value is a list containing the line that matched the pattern and the line number
222proc wait_for_log_messages {srv_idx patterns from_line maxtries delay} {
223 set retry $maxtries
224 set next_line [expr $from_line + 1] ;# searching form the line after
225 set stdout [srv $srv_idx stdout]
226 while {$retry} {
227 # re-read the last line (unless it's before to our first), last time we read it, it might have been incomplete
228 set next_line [expr $next_line - 1 > $from_line + 1 ? $next_line - 1 : $from_line + 1]
229 set result [exec tail -n +$next_line < $stdout]
230 set result [split $result "\n"]
231 foreach line $result {
232 foreach pattern $patterns {
233 if {[string match $pattern $line]} {
234 return [list $line $next_line]
235 }
236 }
237 incr next_line
238 }
239 incr retry -1
240 after $delay
241 }
242 if {$retry == 0} {
243 if {$::verbose} {
244 puts "content of $stdout from line: $from_line:"
245 puts [exec tail -n +$from_line < $stdout]
246 }
247 fail "log message of '$patterns' not found in $stdout after line: $from_line till line: [expr $next_line -1]"
248 }
249}
250
251# write line to server log file
252proc write_log_line {srv_idx msg} {
253 set logfile [srv $srv_idx stdout]
254 set fd [open $logfile "a+"]
255 puts $fd "### $msg"
256 close $fd
257}
258
259# Random integer between 0 and max (excluded).
260proc randomInt {max} {
261 expr {int(rand()*$max)}
262}
263
264# Random integer between min and max (excluded).
265proc randomRange {min max} {
266 expr {int(rand()*[expr $max - $min]) + $min}
267}
268
269# Random signed integer between -max and max (both extremes excluded).
270proc randomSignedInt {max} {
271 set i [randomInt $max]
272 if {rand() > 0.5} {
273 set i -$i
274 }
275 return $i
276}
277
278proc randpath args {
279 set path [expr {int(rand()*[llength $args])}]
280 uplevel 1 [lindex $args $path]
281}
282
283proc randomValue {} {
284 randpath {
285 # Small enough to likely collide
286 randomSignedInt 1000
287 } {
288 # 32 bit compressible signed/unsigned
289 randpath {randomSignedInt 2000000000} {randomSignedInt 4000000000}
290 } {
291 # 64 bit
292 randpath {randomSignedInt 1000000000000}
293 } {
294 # Random string
295 randpath {randstring 0 256 alpha} \
296 {randstring 0 256 compr} \
297 {randstring 0 256 binary}
298 }
299}
300
301proc randomKey {} {
302 randpath {
303 # Small enough to likely collide
304 randomInt 1000
305 } {
306 # 32 bit compressible signed/unsigned
307 randpath {randomInt 2000000000} {randomInt 4000000000}
308 } {
309 # 64 bit
310 randpath {randomInt 1000000000000}
311 } {
312 # Random string
313 randpath {randstring 1 256 alpha} \
314 {randstring 1 256 compr}
315 }
316}
317
318proc findKeyWithType {r type} {
319 for {set j 0} {$j < 20} {incr j} {
320 set k [{*}$r randomkey]
321 if {$k eq {}} {
322 return {}
323 }
324 if {[{*}$r type $k] eq $type} {
325 return $k
326 }
327 }
328 return {}
329}
330
331proc createComplexDataset {r ops {opt {}}} {
332 set useexpire [expr {[lsearch -exact $opt useexpire] != -1}]
333 set usehexpire [expr {[lsearch -exact $opt usehexpire] != -1}]
334
335 if {[lsearch -exact $opt usetag] != -1} {
336 set tag "{t}"
337 } else {
338 set tag ""
339 }
340 for {set j 0} {$j < $ops} {incr j} {
341 set k [randomKey]$tag
342 set k2 [randomKey]$tag
343 set f [randomValue]
344 set v [randomValue]
345
346 if {$useexpire} {
347 if {rand() < 0.1} {
348 {*}$r expire [randomKey] [randomInt 2]
349 }
350 }
351
352 randpath {
353 set d [expr {rand()}]
354 } {
355 set d [expr {rand()}]
356 } {
357 set d [expr {rand()}]
358 } {
359 set d [expr {rand()}]
360 } {
361 set d [expr {rand()}]
362 } {
363 randpath {set d +inf} {set d -inf}
364 }
365 set t [{*}$r type $k]
366
367 if {$t eq {none}} {
368 randpath {
369 {*}$r set $k $v
370 } {
371 {*}$r lpush $k $v
372 } {
373 {*}$r sadd $k $v
374 } {
375 {*}$r zadd $k $d $v
376 } {
377 {*}$r hset $k $f $v
378 } {
379 {*}$r del $k
380 }
381 set t [{*}$r type $k]
382 }
383
384 switch $t {
385 {string} {
386 # Nothing to do
387 }
388 {list} {
389 randpath {{*}$r lpush $k $v} \
390 {{*}$r rpush $k $v} \
391 {{*}$r lrem $k 0 $v} \
392 {{*}$r rpop $k} \
393 {{*}$r lpop $k}
394 }
395 {set} {
396 randpath {{*}$r sadd $k $v} \
397 {{*}$r srem $k $v} \
398 {
399 set otherset [findKeyWithType {*}$r set]
400 if {$otherset ne {}} {
401 randpath {
402 {*}$r sunionstore $k2 $k $otherset
403 } {
404 {*}$r sinterstore $k2 $k $otherset
405 } {
406 {*}$r sdiffstore $k2 $k $otherset
407 }
408 }
409 }
410 }
411 {zset} {
412 randpath {{*}$r zadd $k $d $v} \
413 {{*}$r zrem $k $v} \
414 {
415 set otherzset [findKeyWithType {*}$r zset]
416 if {$otherzset ne {}} {
417 randpath {
418 {*}$r zunionstore $k2 2 $k $otherzset
419 } {
420 {*}$r zinterstore $k2 2 $k $otherzset
421 }
422 }
423 }
424 }
425 {hash} {
426 randpath {{*}$r hset $k $f $v} \
427 {{*}$r hdel $k $f}
428
429 if { [{*}$r hexists $k $f] && $usehexpire && rand() < 0.5} {
430 {*}$r hexpire $k 1000 FIELDS 1 $f
431 }
432 }
433 }
434 }
435}
436
437proc formatCommand {args} {
438 set cmd "*[llength $args]\r\n"
439 foreach a $args {
440 append cmd "$[string length $a]\r\n$a\r\n"
441 }
442 set _ $cmd
443}
444
445proc csvdump r {
446 set o {}
447 if {$::singledb} {
448 set maxdb 1
449 } else {
450 set maxdb 16
451 }
452 for {set db 0} {$db < $maxdb} {incr db} {
453 if {!$::singledb} {
454 {*}$r select $db
455 }
456 foreach k [lsort [{*}$r keys *]] {
457 set type [{*}$r type $k]
458 append o [csvstring $db] , [csvstring $k] , [csvstring $type] ,
459 switch $type {
460 string {
461 append o [csvstring [{*}$r get $k]] "\n"
462 }
463 list {
464 foreach e [{*}$r lrange $k 0 -1] {
465 append o [csvstring $e] ,
466 }
467 append o "\n"
468 }
469 set {
470 foreach e [lsort [{*}$r smembers $k]] {
471 append o [csvstring $e] ,
472 }
473 append o "\n"
474 }
475 zset {
476 foreach e [{*}$r zrange $k 0 -1 withscores] {
477 append o [csvstring $e] ,
478 }
479 append o "\n"
480 }
481 hash {
482 set fields [{*}$r hgetall $k]
483 set newfields {}
484 foreach {f v} $fields {
485 set expirylist [{*}$r hexpiretime $k FIELDS 1 $f]
486 if {$expirylist eq (-1)} {
487 lappend newfields [list $f $v]
488 } else {
489 set e [lindex $expirylist 0]
490 lappend newfields [list $f $e $v] # TODO: extract the actual ttl value from the list in $e
491 }
492 }
493 set fields [lsort -index 0 $newfields]
494 foreach kv $fields {
495 append o [csvstring [lindex $kv 0]] ,
496 append o [csvstring [lindex $kv 1]] ,
497 }
498 append o "\n"
499 }
500 }
501 }
502 }
503 if {!$::singledb} {
504 {*}$r select 9
505 }
506 return $o
507}
508
509proc csvstring s {
510 return "\"$s\""
511}
512
513proc roundFloat f {
514 format "%.10g" $f
515}
516
517set ::last_port_attempted 0
518proc find_available_port {start count} {
519 set port [expr $::last_port_attempted + 1]
520 for {set attempts 0} {$attempts < $count} {incr attempts} {
521 if {$port < $start || $port >= $start+$count} {
522 set port $start
523 }
524 set fd1 -1
525 proc dummy_accept {chan addr port} {}
526 if {[catch {set fd1 [socket -server dummy_accept -myaddr 127.0.0.1 $port]}] ||
527 [catch {set fd2 [socket -server dummy_accept -myaddr 127.0.0.1 [expr $port+10000]]}]} {
528 if {$fd1 != -1} {
529 close $fd1
530 }
531 } else {
532 close $fd1
533 close $fd2
534 set ::last_port_attempted $port
535 return $port
536 }
537 incr port
538 }
539 error "Can't find a non busy port in the $start-[expr {$start+$count-1}] range."
540}
541
542# Test if TERM looks like to support colors
543proc color_term {} {
544 expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]}
545}
546
547proc colorstr {color str} {
548 if {[color_term]} {
549 set b 0
550 if {[string range $color 0 4] eq {bold-}} {
551 set b 1
552 set color [string range $color 5 end]
553 }
554 switch $color {
555 red {set colorcode {31}}
556 green {set colorcode {32}}
557 yellow {set colorcode {33}}
558 blue {set colorcode {34}}
559 magenta {set colorcode {35}}
560 cyan {set colorcode {36}}
561 white {set colorcode {37}}
562 default {set colorcode {37}}
563 }
564 if {$colorcode ne {}} {
565 return "\033\[$b;${colorcode};49m$str\033\[0m"
566 }
567 } else {
568 return $str
569 }
570}
571
572proc find_valgrind_errors {stderr on_termination} {
573 set fd [open $stderr]
574 set buf [read $fd]
575 close $fd
576
577 # Look for stack trace (" at 0x") and other errors (Invalid, Mismatched, etc).
578 # Look for "Warnings", but not the "set address range perms". These don't indicate any real concern.
579 # corrupt-dump unit, not sure why but it seems they don't indicate any real concern.
580 if {[regexp -- { at 0x} $buf] ||
581 [regexp -- {^(?=.*Warning)(?:(?!set address range perms).)*$} $buf] ||
582 [regexp -- {Invalid} $buf] ||
583 [regexp -- {Mismatched} $buf] ||
584 [regexp -- {uninitialized} $buf] ||
585 [regexp -- {has a fishy} $buf] ||
586 [regexp -- {overlap} $buf]} {
587 return $buf
588 }
589
590 # If the process didn't terminate yet, we can't look for the summary report
591 if {!$on_termination} {
592 return ""
593 }
594
595 # Look for the absence of a leak free summary (happens when redis isn't terminated properly).
596 if {(![regexp -- {definitely lost: 0 bytes} $buf] &&
597 ![regexp -- {no leaks are possible} $buf])} {
598 return $buf
599 }
600
601 return ""
602}
603
604# Execute a background process writing random data for the specified number
605# of seconds to the specified Redis instance. If key is omitted, a random key
606# is used for every SET command.
607proc start_write_load {host port seconds {key ""} {size 0} {sleep 0}} {
608 set tclsh [info nameofexecutable]
609 exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds $::tls $key $size $sleep &
610}
611
612# Stop a process generating write load executed with start_write_load.
613proc stop_write_load {handle} {
614 catch {exec /bin/kill -9 $handle}
615}
616
617proc wait_load_handlers_disconnected {{level 0}} {
618 wait_for_condition 50 100 {
619 ![string match {*name=LOAD_HANDLER*} [r $level client list]]
620 } else {
621 fail "load_handler(s) still connected after too long time."
622 }
623}
624
625proc K { x y } { set x }
626
627# Shuffle a list with Fisher-Yates algorithm.
628proc lshuffle {list} {
629 set n [llength $list]
630 while {$n>1} {
631 set j [expr {int(rand()*$n)}]
632 incr n -1
633 if {$n==$j} continue
634 set v [lindex $list $j]
635 lset list $j [lindex $list $n]
636 lset list $n $v
637 }
638 return $list
639}
640
641# Execute a background process writing complex data for the specified number
642# of ops to the specified Redis instance.
643proc start_bg_complex_data {host port db ops} {
644 set tclsh [info nameofexecutable]
645 exec $tclsh tests/helpers/bg_complex_data.tcl $host $port $db $ops $::tls &
646}
647
648# Stop a process generating write load executed with start_bg_complex_data.
649proc stop_bg_complex_data {handle} {
650 catch {exec /bin/kill -9 $handle}
651}
652
653# Write num keys with the given key prefix and value size (in bytes). If idx is
654# given, it's the index (AKA level) used with the srv procedure and it specifies
655# to which Redis instance to write the keys.
656proc populate {num {prefix key:} {size 3} {idx 0} {prints false} {expires 0}} {
657 r $idx deferred 1
658 if {$num > 16} {set pipeline 16} else {set pipeline $num}
659 set val [string repeat A $size]
660 for {set j 0} {$j < $pipeline} {incr j} {
661 if {$expires > 0} {
662 r $idx set $prefix$j $val ex $expires
663 } else {
664 r $idx set $prefix$j $val
665 }
666 if {$prints} {puts $j}
667 }
668 for {} {$j < $num} {incr j} {
669 if {$expires > 0} {
670 r $idx set $prefix$j $val ex $expires
671 } else {
672 r $idx set $prefix$j $val
673 }
674 r $idx read
675 if {$prints} {puts $j}
676 }
677 for {set j 0} {$j < $pipeline} {incr j} {
678 r $idx read
679 if {$prints} {puts $j}
680 }
681 r $idx deferred 0
682}
683
684proc get_child_pid {idx} {
685 set pid [srv $idx pid]
686 if {[file exists "/usr/bin/pgrep"]} {
687 set fd [open "|pgrep -P $pid" "r"]
688 set child_pid [string trim [lindex [split [read $fd] \n] 0]]
689 } else {
690 set fd [open "|ps --ppid $pid -o pid" "r"]
691 set child_pid [string trim [lindex [split [read $fd] \n] 1]]
692 }
693 close $fd
694
695 return $child_pid
696}
697
698proc process_is_alive pid {
699 if {[catch {exec ps -p $pid -f} err]} {
700 return 0
701 } else {
702 if {[string match "*<defunct>*" $err]} { return 0 }
703 return 1
704 }
705}
706
707proc get_system_name {} {
708 return [string tolower [exec uname -s]]
709}
710
711proc get_proc_state {pid} {
712 if {[get_system_name] eq {sunos}} {
713 return [exec ps -o s= -p $pid]
714 } else {
715 return [exec ps -o state= -p $pid]
716 }
717}
718
719proc get_proc_job {pid} {
720 if {[get_system_name] eq {sunos}} {
721 return [exec ps -l -p $pid]
722 } else {
723 return [exec ps j $pid]
724 }
725}
726
727proc pause_process {pid} {
728 exec kill -SIGSTOP $pid
729 wait_for_condition 50 100 {
730 [string match "T*" [get_proc_state $pid]]
731 } else {
732 puts [get_proc_job $pid]
733 fail "process didn't stop"
734 }
735}
736
737proc resume_process {pid} {
738 wait_for_condition 50 1000 {
739 [string match "T*" [get_proc_state $pid]]
740 } else {
741 puts [get_proc_job $pid]
742 fail "process was not stopped"
743 }
744
745 set max_attempts 10
746 set attempt 0
747 while {($attempt < $max_attempts) && [string match "T*" [exec ps -o state= -p $pid]]} {
748 exec kill -SIGCONT $pid
749
750 incr attempt
751 after 100
752 }
753
754 wait_for_condition 50 1000 {
755 [string match "R*" [exec ps -o state= -p $pid]] ||
756 [string match "S*" [exec ps -o state= -p $pid]]
757 } else {
758 puts [exec ps j $pid]
759 fail "process was not resumed"
760 }
761}
762
763proc cmdrstat {cmd r} {
764 if {[regexp "\r\ncmdstat_$cmd:(.*?)\r\n" [$r info commandstats] _ value]} {
765 set _ $value
766 }
767}
768
769proc errorrstat {cmd r} {
770 if {[regexp "\r\nerrorstat_$cmd:(.*?)\r\n" [$r info errorstats] _ value]} {
771 set _ $value
772 }
773}
774
775proc latencyrstat_percentiles {cmd r} {
776 if {[regexp "\r\nlatency_percentiles_usec_$cmd:(.*?)\r\n" [$r info latencystats] _ value]} {
777 set _ $value
778 }
779}
780
781proc get_io_thread_clients {id {client r}} {
782 set pattern "io_thread_$id:clients=(\[0-9\]+)"
783 set info [$client info threads]
784 if {[regexp $pattern $info _ value]} {
785 return $value
786 } else {
787 return -1
788 }
789}
790
791proc generate_fuzzy_traffic_on_key {key type duration} {
792 # Commands per type, blocking commands removed
793 # TODO: extract these from COMMAND DOCS, and improve to include other types
794 set string_commands {APPEND BITCOUNT BITFIELD BITOP BITPOS DECR DECRBY GET GETBIT GETRANGE GETSET INCR INCRBY INCRBYFLOAT MGET MSET MSETNX PSETEX SET SETBIT SETEX SETNX SETRANGE LCS STRLEN}
795 set hash_commands {HDEL HEXISTS HGET HGETALL HINCRBY HINCRBYFLOAT HKEYS HLEN HMGET HMSET HSCAN HSET HSETNX HSTRLEN HVALS HRANDFIELD}
796 set zset_commands {ZADD ZCARD ZCOUNT ZINCRBY ZINTERSTORE ZLEXCOUNT ZPOPMAX ZPOPMIN ZRANGE ZRANGEBYLEX ZRANGEBYSCORE ZRANK ZREM ZREMRANGEBYLEX ZREMRANGEBYRANK ZREMRANGEBYSCORE ZREVRANGE ZREVRANGEBYLEX ZREVRANGEBYSCORE ZREVRANK ZSCAN ZSCORE ZUNIONSTORE ZRANDMEMBER}
797 set list_commands {LINDEX LINSERT LLEN LPOP LPOS LPUSH LPUSHX LRANGE LREM LSET LTRIM RPOP RPOPLPUSH RPUSH RPUSHX}
798 set set_commands {SADD SCARD SDIFF SDIFFSTORE SINTER SINTERSTORE SISMEMBER SMEMBERS SMOVE SPOP SRANDMEMBER SREM SSCAN SUNION SUNIONSTORE}
799 set stream_commands {XACK XADD XCLAIM XDEL XGROUP XINFO XLEN XPENDING XRANGE XREAD XREADGROUP XREVRANGE XTRIM XDELEX XACKDEL}
800 set vset_commands {VADD VREM}
801 set commands [dict create string $string_commands hash $hash_commands zset $zset_commands list $list_commands set $set_commands stream $stream_commands vectorset $vset_commands]
802
803 set cmds [dict get $commands $type]
804 set start_time [clock seconds]
805 set sent {}
806 set succeeded 0
807 while {([clock seconds]-$start_time) < $duration} {
808 # find a random command for our key type
809 set cmd_idx [expr {int(rand()*[llength $cmds])}]
810 set cmd [lindex $cmds $cmd_idx]
811 # get the command details from redis
812 if { [ catch {
813 set cmd_info [lindex [r command info $cmd] 0]
814 } err ] } {
815 # if we failed, it means redis crashed after the previous command
816 return $sent
817 }
818 # try to build a valid command argument
819 set arity [lindex $cmd_info 1]
820 set arity [expr $arity < 0 ? - $arity: $arity]
821 set firstkey [lindex $cmd_info 3]
822 set lastkey [lindex $cmd_info 4]
823 set i 1
824 if {$cmd == "XINFO"} {
825 lappend cmd "STREAM"
826 lappend cmd $key
827 lappend cmd "FULL"
828 incr i 3
829 }
830 if {$cmd == "XREAD"} {
831 lappend cmd "STREAMS"
832 lappend cmd $key
833 randpath {
834 lappend cmd \$
835 } {
836 lappend cmd [randomValue]
837 }
838 incr i 3
839 }
840 if {$cmd == "XADD"} {
841 lappend cmd $key
842 randpath {
843 lappend cmd "*"
844 } {
845 lappend cmd [randomValue]
846 }
847 lappend cmd [randomValue]
848 lappend cmd [randomValue]
849 incr i 4
850 }
851 if {$cmd == "VADD"} {
852 lappend cmd $key
853 lappend cmd VALUES 3 1 1 1
854 lappend cmd [randomValue]
855 incr i 7
856 }
857 if {$cmd == "VREM"} {
858 lappend cmd $key
859 lappend cmd [randomValue]
860 incr i 2
861 }
862
863 for {} {$i < $arity} {incr i} {
864 if {$i == $firstkey || $i == $lastkey} {
865 lappend cmd $key
866 } else {
867 lappend cmd [randomValue]
868 }
869 }
870 # execute the command, we expect commands to fail on syntax errors
871 lappend sent $cmd
872 if { ! [ catch {
873 r {*}$cmd
874 } err ] } {
875 incr succeeded
876 } else {
877 set err [format "%s" $err] ;# convert to string for pattern matching
878 if {[string match "*SIGTERM*" $err]} {
879 puts "commands caused test to hang:"
880 foreach cmd $sent {
881 foreach arg $cmd {
882 puts -nonewline "[string2printable $arg] "
883 }
884 puts ""
885 }
886 # Re-raise, let handler up the stack take care of this.
887 error $err $::errorInfo
888 }
889 }
890 }
891
892 # print stats so that we know if we managed to generate commands that actually made sense
893 #if {$::verbose} {
894 # set count [llength $sent]
895 # puts "Fuzzy traffic sent: $count, succeeded: $succeeded"
896 #}
897
898 # return the list of commands we sent
899 return $sent
900}
901
902proc string2printable s {
903 set res {}
904 set has_special_chars false
905 foreach i [split $s {}] {
906 scan $i %c int
907 # non printable characters, including space and excluding: " \ $ { }
908 if {$int < 32 || $int > 122 || $int == 34 || $int == 36 || $int == 92} {
909 set has_special_chars true
910 }
911 # TCL8.5 has issues mixing \x notation and normal chars in the same
912 # source code string, so we'll convert the entire string.
913 append res \\x[format %02X $int]
914 }
915 if {!$has_special_chars} {
916 return $s
917 }
918 set res "\"$res\""
919 return $res
920}
921
922# Calculation value of Chi-Square Distribution. By this value
923# we can verify the random distribution sample confidence.
924# Based on the following wiki:
925# https://en.wikipedia.org/wiki/Chi-square_distribution
926#
927# param res Random sample list
928# return Value of Chi-Square Distribution
929#
930# x2_value: return of chi_square_value function
931# df: Degrees of freedom, Number of independent values minus 1
932#
933# By using x2_value and df to back check the cardinality table,
934# we can know the confidence of the random sample.
935proc chi_square_value {res} {
936 unset -nocomplain mydict
937 foreach key $res {
938 dict incr mydict $key 1
939 }
940
941 set x2_value 0
942 set p [expr [llength $res] / [dict size $mydict]]
943 foreach key [dict keys $mydict] {
944 set value [dict get $mydict $key]
945
946 # Aggregate the chi-square value of each element
947 set v [expr {pow($value - $p, 2) / $p}]
948 set x2_value [expr {$x2_value + $v}]
949 }
950
951 return $x2_value
952}
953
954#subscribe to Pub/Sub channels
955proc consume_subscribe_messages {client type channels} {
956 set numsub -1
957 set counts {}
958
959 for {set i [llength $channels]} {$i > 0} {incr i -1} {
960 set msg [$client read]
961 assert_equal $type [lindex $msg 0]
962
963 # when receiving subscribe messages the channels names
964 # are ordered. when receiving unsubscribe messages
965 # they are unordered
966 set idx [lsearch -exact $channels [lindex $msg 1]]
967 if {[string match "*unsubscribe" $type]} {
968 assert {$idx >= 0}
969 } else {
970 assert {$idx == 0}
971 }
972 set channels [lreplace $channels $idx $idx]
973
974 # aggregate the subscription count to return to the caller
975 lappend counts [lindex $msg 2]
976 }
977
978 # we should have received messages for channels
979 assert {[llength $channels] == 0}
980 return $counts
981}
982
983proc subscribe {client channels} {
984 $client subscribe {*}$channels
985 consume_subscribe_messages $client subscribe $channels
986}
987
988proc ssubscribe {client channels} {
989 $client ssubscribe {*}$channels
990 consume_subscribe_messages $client ssubscribe $channels
991}
992
993proc unsubscribe {client {channels {}}} {
994 $client unsubscribe {*}$channels
995 consume_subscribe_messages $client unsubscribe $channels
996}
997
998proc sunsubscribe {client {channels {}}} {
999 $client sunsubscribe {*}$channels
1000 consume_subscribe_messages $client sunsubscribe $channels
1001}
1002
1003proc psubscribe {client channels} {
1004 $client psubscribe {*}$channels
1005 consume_subscribe_messages $client psubscribe $channels
1006}
1007
1008proc punsubscribe {client {channels {}}} {
1009 $client punsubscribe {*}$channels
1010 consume_subscribe_messages $client punsubscribe $channels
1011}
1012
1013proc debug_digest_value {key} {
1014 if {[lsearch $::denytags "needs:debug"] >= 0 || $::ignoredigest} {
1015 return "dummy-digest-value"
1016 }
1017 r debug digest-value $key
1018}
1019
1020proc debug_digest {{level 0}} {
1021 if {[lsearch $::denytags "needs:debug"] >= 0 || $::ignoredigest} {
1022 return "dummy-digest"
1023 }
1024 r $level debug digest
1025}
1026
1027proc wait_for_blocked_client {{idx 0}} {
1028 wait_for_condition 50 100 {
1029 [s $idx blocked_clients] ne 0
1030 } else {
1031 fail "no blocked clients"
1032 }
1033}
1034
1035proc wait_for_blocked_clients_count {count {maxtries 100} {delay 10} {idx 0}} {
1036 wait_for_condition $maxtries $delay {
1037 [s $idx blocked_clients] == $count
1038 } else {
1039 fail "Timeout waiting for blocked clients (expected $count, actual [s $idx blocked_clients])"
1040 }
1041}
1042
1043proc wait_for_watched_clients_count {count {maxtries 100} {delay 10} {idx 0}} {
1044 wait_for_condition $maxtries $delay {
1045 [s $idx watching_clients] == $count
1046 } else {
1047 fail "Timeout waiting for watched clients"
1048 }
1049}
1050
1051proc read_from_aof {fp} {
1052 # Input fp is a blocking binary file descriptor of an opened AOF file.
1053 if {[gets $fp count] == -1} return ""
1054 set count [string range $count 1 end]
1055
1056 # Return a list of arguments for the command.
1057 set res {}
1058 for {set j 0} {$j < $count} {incr j} {
1059 read $fp 1
1060 set arg [::redis::redis_bulk_read $fp]
1061 if {$j == 0} {set arg [string tolower $arg]}
1062 lappend res $arg
1063 }
1064 return $res
1065}
1066
1067proc assert_aof_content {aof_path patterns} {
1068 set fp [open $aof_path r]
1069 fconfigure $fp -translation binary
1070 fconfigure $fp -blocking 1
1071
1072 for {set j 0} {$j < [llength $patterns]} {incr j} {
1073 assert_match [lindex $patterns $j] [read_from_aof $fp]
1074 }
1075}
1076
1077proc config_set {param value {options {}}} {
1078 set mayfail 0
1079 foreach option $options {
1080 switch $option {
1081 "mayfail" {
1082 set mayfail 1
1083 }
1084 default {
1085 error "Unknown option $option"
1086 }
1087 }
1088 }
1089
1090 if {[catch {r config set $param $value} err]} {
1091 if {!$mayfail} {
1092 error $err
1093 } else {
1094 if {$::verbose} {
1095 puts "Ignoring CONFIG SET $param $value failure: $err"
1096 }
1097 }
1098 }
1099}
1100
1101proc config_get_set {param value {options {}}} {
1102 set config [lindex [r config get $param] 1]
1103 config_set $param $value $options
1104 return $config
1105}
1106
1107proc delete_lines_with_pattern {filename tmpfilename pattern} {
1108 set fh_in [open $filename r]
1109 set fh_out [open $tmpfilename w]
1110 while {[gets $fh_in line] != -1} {
1111 if {![regexp $pattern $line]} {
1112 puts $fh_out $line
1113 }
1114 }
1115 close $fh_in
1116 close $fh_out
1117 file rename -force $tmpfilename $filename
1118}
1119
1120proc get_nonloopback_addr {} {
1121 set addrlist [list {}]
1122 catch { set addrlist [exec hostname -I] }
1123 return [lindex $addrlist 0]
1124}
1125
1126proc get_nonloopback_client {} {
1127 return [redis [get_nonloopback_addr] [srv 0 "port"] 0 $::tls]
1128}
1129
1130# The following functions and variables are used only when running large-memory
1131# tests. We avoid defining them when not running large-memory tests because the
1132# global variables takes up lots of memory.
1133proc init_large_mem_vars {} {
1134 if {![info exists ::str500]} {
1135 set ::str500 [string repeat x 500000000] ;# 500mb
1136 set ::str500_len [string length $::str500]
1137 }
1138}
1139
1140# Utility function to write big argument into redis client connection
1141proc write_big_bulk {size {prefix ""} {skip_read no}} {
1142 init_large_mem_vars
1143
1144 assert {[string length prefix] <= $size}
1145 r write "\$$size\r\n"
1146 r write $prefix
1147 incr size -[string length $prefix]
1148 while {$size >= 500000000} {
1149 r write $::str500
1150 incr size -500000000
1151 }
1152 if {$size > 0} {
1153 r write [string repeat x $size]
1154 }
1155 r write "\r\n"
1156 if {!$skip_read} {
1157 r flush
1158 r read
1159 }
1160}
1161
1162# Utility to read big bulk response (work around Tcl limitations)
1163proc read_big_bulk {code {compare no} {prefix ""}} {
1164 init_large_mem_vars
1165
1166 r readraw 1
1167 set resp_len [uplevel 1 $code] ;# get the first line of the RESP response
1168 assert_equal [string range $resp_len 0 0] "$"
1169 set resp_len [string range $resp_len 1 end]
1170 set prefix_len [string length $prefix]
1171 if {$compare} {
1172 assert {$prefix_len <= $resp_len}
1173 assert {$prefix_len <= $::str500_len}
1174 }
1175
1176 set remaining $resp_len
1177 while {$remaining > 0} {
1178 set l $remaining
1179 if {$l > $::str500_len} {set l $::str500_len} ; # can't read more than 2gb at a time, so read 500mb so we can easily verify read data
1180 set read_data [r rawread $l]
1181 set nbytes [string length $read_data]
1182 if {$compare} {
1183 set comp_len $nbytes
1184 # Compare prefix part
1185 if {$remaining == $resp_len} {
1186 assert_equal $prefix [string range $read_data 0 [expr $prefix_len - 1]]
1187 set read_data [string range $read_data $prefix_len $nbytes]
1188 incr comp_len -$prefix_len
1189 }
1190 # Compare rest of data, evaluate and then assert to avoid huge print in case of failure
1191 set data_equal [expr {$read_data == [string range $::str500 0 [expr $comp_len - 1]]}]
1192 assert $data_equal
1193 }
1194 incr remaining -$nbytes
1195 }
1196 assert_equal [r rawread 2] "\r\n"
1197 r readraw 0
1198 return $resp_len
1199}
1200
1201proc prepare_value {size} {
1202 set _v "c"
1203 for {set i 1} {$i < $size} {incr i} {
1204 append _v 0
1205 }
1206 return $_v
1207}
1208
1209proc memory_usage {key} {
1210 set usage [r memory usage $key]
1211 if {![string match {*jemalloc*} [s mem_allocator]]} {
1212 # libc allocator can sometimes return a different size allocation for the same requested size
1213 # this makes tests that rely on MEMORY USAGE unreliable, so instead we return a constant 1
1214 set usage 1
1215 }
1216 return $usage
1217}
1218
1219# Test if the server supports the specified command.
1220proc server_has_command {cmd_wanted} {
1221 set lowercase_commands {}
1222 foreach cmd [r command list] {
1223 lappend lowercase_commands [string tolower $cmd]
1224 }
1225 expr {[lsearch $lowercase_commands [string tolower $cmd_wanted]] != -1}
1226}
1227
1228# forward compatibility, lmap missing in TCL 8.5
1229proc lmap args {
1230 set body [lindex $args end]
1231 set args [lrange $args 0 end-1]
1232 set n 0
1233 set pairs [list]
1234 foreach {varnames listval} $args {
1235 set varlist [list]
1236 foreach varname $varnames {
1237 upvar 1 $varname var$n
1238 lappend varlist var$n
1239 incr n
1240 }
1241 lappend pairs $varlist $listval
1242 }
1243 set temp [list]
1244 foreach {*}$pairs {
1245 lappend temp [uplevel 1 $body]
1246 }
1247 set temp
1248}
1249
1250proc format_command {args} {
1251 set cmd "*[llength $args]\r\n"
1252 foreach a $args {
1253 append cmd "$[string length $a]\r\n$a\r\n"
1254 }
1255 set _ $cmd
1256}
1257
1258# Returns whether or not the system supports stack traces
1259proc system_backtrace_supported {} {
1260 # Thread sanitizer reports backtrace_symbols_fd() as
1261 # signal-unsafe since it allocates memory
1262 if {$::tsan} {
1263 return 0
1264 }
1265
1266 set system_name [get_system_name]
1267 if {$system_name eq {darwin}} {
1268 return 1
1269 } elseif {$system_name ne {linux}} {
1270 return 0
1271 }
1272
1273 # libmusl does not support backtrace. Also return 0 on
1274 # static binaries (ldd exit code 1) where we can't detect libmusl
1275 if {![catch {set ldd [exec ldd src/redis-server]}]} {
1276 if {![string match {*libc.*musl*} $ldd]} {
1277 return 1
1278 }
1279 }
1280 return 0
1281}
1282
1283proc generate_largevalue_test_array {} {
1284 array set largevalue {}
1285 set largevalue(listpack) "hello"
1286 set largevalue(quicklist) [string repeat "x" 8192]
1287 return [array get largevalue]
1288}
generated by cgit v1.2.3 (git 2.46.0) at 2026-04-30 02:23:18 +0000