diff options
Diffstat (limited to 'examples/redis-unstable/tests/support/util.tcl')
| -rw-r--r-- | examples/redis-unstable/tests/support/util.tcl | 1288 |
1 files changed, 0 insertions, 1288 deletions
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 @@ -# -# Copyright (c) 2009-Present, Redis Ltd. -# All rights reserved. -# -# Copyright (c) 2024-present, Valkey contributors. -# All rights reserved. -# -# Licensed under your choice of (a) the Redis Source Available License 2.0 -# (RSALv2); or (b) the Server Side Public License v1 (SSPLv1); or (c) the -# GNU Affero General Public License v3 (AGPLv3). -# -# Portions of this file are available under BSD3 terms; see REDISCONTRIBUTIONS for more information. -# - -proc randstring {min max {type binary}} { - set len [expr {$min+int(rand()*($max-$min+1))}] - set output {} - if {$type eq {binary}} { - set minval 0 - set maxval 255 - } elseif {$type eq {alpha} || $type eq {simplealpha}} { - set minval 48 - set maxval 122 - } elseif {$type eq {compr}} { - set minval 48 - set maxval 52 - } - while {$len} { - set num [expr {$minval+int(rand()*($maxval-$minval+1))}] - set rr [format "%c" $num] - if {$type eq {simplealpha} && ![string is alnum $rr]} {continue} - if {$type eq {alpha} && $num eq 92} {continue} ;# avoid putting '\' char in the string, it can mess up TCL processing - append output $rr - incr len -1 - } - return $output -} - -# Useful for some test -proc zlistAlikeSort {a b} { - if {[lindex $a 0] > [lindex $b 0]} {return 1} - if {[lindex $a 0] < [lindex $b 0]} {return -1} - string compare [lindex $a 1] [lindex $b 1] -} - -# Return all log lines starting with the first line that contains a warning. -# Generally, this will be an assertion error with a stack trace. -proc crashlog_from_file {filename} { - set lines [split [exec cat $filename] "\n"] - set matched 0 - set logall 0 - set result {} - foreach line $lines { - if {[string match {*REDIS BUG REPORT START*} $line]} { - set logall 1 - } - if {[regexp {^\[\d+\]\s+\d+\s+\w+\s+\d{2}:\d{2}:\d{2} \#} $line]} { - set matched 1 - } - if {$logall || $matched} { - lappend result $line - } - } - join $result "\n" -} - -# Return sanitizer log lines -proc sanitizer_errors_from_file {filename} { - set log [exec cat $filename] - set lines [split [exec cat $filename] "\n"] - - foreach line $lines { - # Ignore huge allocation warnings for both ASan and MSan - if ([string match {*WARNING: AddressSanitizer failed to allocate*} $line]) { - continue - } - - if ([string match {*WARNING: MemorySanitizer failed to allocate*} $line]) { - continue - } - - # GCC UBSAN output does not contain 'Sanitizer' but 'runtime error'. - if {[string match {*runtime error*} $line] || - [string match {*Sanitizer*} $line]} { - return $log - } - } - - return "" -} - -proc getInfoProperty {infostr property} { - if {[regexp -lineanchor "^$property:(.*?)\r\n" $infostr _ value]} { - return $value - } -} - -# Return value for INFO property -proc status {r property} { - set _ [getInfoProperty [{*}$r info] $property] -} - -proc waitForBgsave r { - while 1 { - if {[status $r rdb_bgsave_in_progress] eq 1} { - if {$::verbose} { - puts -nonewline "\nWaiting for background save to finish... " - flush stdout - } - after 50 - } else { - break - } - } -} - -proc waitForBgrewriteaof r { - while 1 { - if {[status $r aof_rewrite_in_progress] eq 1} { - if {$::verbose} { - puts -nonewline "\nWaiting for background AOF rewrite to finish... " - flush stdout - } - after 50 - } else { - break - } - } -} - -proc wait_for_sync r { - set maxtries 50 - # tsan adds significant overhead to the execution time, so we increase the - # wait time here JIC - if {$::tsan} { - set maxtries 100 - } - - wait_for_condition $maxtries 100 { - [status $r master_link_status] eq "up" - } else { - fail "replica didn't sync in time" - } -} - -proc wait_replica_online {r {replica_id 0} {maxtries 50} {delay 100}} { - # tsan adds significant overhead to the execution time, so we increase the - # wait time here JIC - if {$::tsan} { - set maxtries [expr {$maxtries * 2}] - } - - wait_for_condition $maxtries $delay { - [string match "*slave$replica_id:*,state=online*" [$r info replication]] - } else { - fail "replica $replica_id did not become online in time" - } -} - -proc wait_for_ofs_sync {r1 r2} { - set maxtries 50 - # tsan adds significant overhead to the execution time, so we increase the - # wait time here JIC - if {$::tsan} { - set maxtries 100 - } - wait_for_condition $maxtries 100 { - [status $r1 master_repl_offset] eq [status $r2 master_repl_offset] - } else { - fail "replica offset didn't match in time" - } -} - -proc wait_done_loading r { - wait_for_condition 50 100 { - [catch {$r ping} e] == 0 - } else { - fail "Loading DB is taking too much time." - } -} - -proc wait_lazyfree_done r { - wait_for_condition 50 100 { - [status $r lazyfree_pending_objects] == 0 - } else { - fail "lazyfree isn't done" - } -} - -# count current log lines in server's stdout -proc count_log_lines {srv_idx} { - set _ [string trim [exec wc -l < [srv $srv_idx stdout]]] -} - -# returns the number of times a line with that pattern appears in a file -proc count_message_lines {file pattern} { - set res 0 - # exec fails when grep exists with status other than 0 (when the pattern wasn't found) - catch { - set res [string trim [exec grep $pattern $file 2> /dev/null | wc -l]] - } - return $res -} - -# returns the number of times a line with that pattern appears in the log -proc count_log_message {srv_idx pattern} { - set stdout [srv $srv_idx stdout] - return [count_message_lines $stdout $pattern] -} - -# verify pattern exists in server's sdtout after a certain line number -proc verify_log_message {srv_idx pattern from_line} { - incr from_line - set result [exec tail -n +$from_line < [srv $srv_idx stdout]] - if {![string match $pattern $result]} { - error "assertion:expected message not found in log file: $pattern" - } -} - -# wait for pattern to be found in server's stdout after certain line number -# return value is a list containing the line that matched the pattern and the line number -proc wait_for_log_messages {srv_idx patterns from_line maxtries delay} { - set retry $maxtries - set next_line [expr $from_line + 1] ;# searching form the line after - set stdout [srv $srv_idx stdout] - while {$retry} { - # re-read the last line (unless it's before to our first), last time we read it, it might have been incomplete - set next_line [expr $next_line - 1 > $from_line + 1 ? $next_line - 1 : $from_line + 1] - set result [exec tail -n +$next_line < $stdout] - set result [split $result "\n"] - foreach line $result { - foreach pattern $patterns { - if {[string match $pattern $line]} { - return [list $line $next_line] - } - } - incr next_line - } - incr retry -1 - after $delay - } - if {$retry == 0} { - if {$::verbose} { - puts "content of $stdout from line: $from_line:" - puts [exec tail -n +$from_line < $stdout] - } - fail "log message of '$patterns' not found in $stdout after line: $from_line till line: [expr $next_line -1]" - } -} - -# write line to server log file -proc write_log_line {srv_idx msg} { - set logfile [srv $srv_idx stdout] - set fd [open $logfile "a+"] - puts $fd "### $msg" - close $fd -} - -# Random integer between 0 and max (excluded). -proc randomInt {max} { - expr {int(rand()*$max)} -} - -# Random integer between min and max (excluded). -proc randomRange {min max} { - expr {int(rand()*[expr $max - $min]) + $min} -} - -# Random signed integer between -max and max (both extremes excluded). -proc randomSignedInt {max} { - set i [randomInt $max] - if {rand() > 0.5} { - set i -$i - } - return $i -} - -proc randpath args { - set path [expr {int(rand()*[llength $args])}] - uplevel 1 [lindex $args $path] -} - -proc randomValue {} { - randpath { - # Small enough to likely collide - randomSignedInt 1000 - } { - # 32 bit compressible signed/unsigned - randpath {randomSignedInt 2000000000} {randomSignedInt 4000000000} - } { - # 64 bit - randpath {randomSignedInt 1000000000000} - } { - # Random string - randpath {randstring 0 256 alpha} \ - {randstring 0 256 compr} \ - {randstring 0 256 binary} - } -} - -proc randomKey {} { - randpath { - # Small enough to likely collide - randomInt 1000 - } { - # 32 bit compressible signed/unsigned - randpath {randomInt 2000000000} {randomInt 4000000000} - } { - # 64 bit - randpath {randomInt 1000000000000} - } { - # Random string - randpath {randstring 1 256 alpha} \ - {randstring 1 256 compr} - } -} - -proc findKeyWithType {r type} { - for {set j 0} {$j < 20} {incr j} { - set k [{*}$r randomkey] - if {$k eq {}} { - return {} - } - if {[{*}$r type $k] eq $type} { - return $k - } - } - return {} -} - -proc createComplexDataset {r ops {opt {}}} { - set useexpire [expr {[lsearch -exact $opt useexpire] != -1}] - set usehexpire [expr {[lsearch -exact $opt usehexpire] != -1}] - - if {[lsearch -exact $opt usetag] != -1} { - set tag "{t}" - } else { - set tag "" - } - for {set j 0} {$j < $ops} {incr j} { - set k [randomKey]$tag - set k2 [randomKey]$tag - set f [randomValue] - set v [randomValue] - - if {$useexpire} { - if {rand() < 0.1} { - {*}$r expire [randomKey] [randomInt 2] - } - } - - randpath { - set d [expr {rand()}] - } { - set d [expr {rand()}] - } { - set d [expr {rand()}] - } { - set d [expr {rand()}] - } { - set d [expr {rand()}] - } { - randpath {set d +inf} {set d -inf} - } - set t [{*}$r type $k] - - if {$t eq {none}} { - randpath { - {*}$r set $k $v - } { - {*}$r lpush $k $v - } { - {*}$r sadd $k $v - } { - {*}$r zadd $k $d $v - } { - {*}$r hset $k $f $v - } { - {*}$r del $k - } - set t [{*}$r type $k] - } - - switch $t { - {string} { - # Nothing to do - } - {list} { - randpath {{*}$r lpush $k $v} \ - {{*}$r rpush $k $v} \ - {{*}$r lrem $k 0 $v} \ - {{*}$r rpop $k} \ - {{*}$r lpop $k} - } - {set} { - randpath {{*}$r sadd $k $v} \ - {{*}$r srem $k $v} \ - { - set otherset [findKeyWithType {*}$r set] - if {$otherset ne {}} { - randpath { - {*}$r sunionstore $k2 $k $otherset - } { - {*}$r sinterstore $k2 $k $otherset - } { - {*}$r sdiffstore $k2 $k $otherset - } - } - } - } - {zset} { - randpath {{*}$r zadd $k $d $v} \ - {{*}$r zrem $k $v} \ - { - set otherzset [findKeyWithType {*}$r zset] - if {$otherzset ne {}} { - randpath { - {*}$r zunionstore $k2 2 $k $otherzset - } { - {*}$r zinterstore $k2 2 $k $otherzset - } - } - } - } - {hash} { - randpath {{*}$r hset $k $f $v} \ - {{*}$r hdel $k $f} - - if { [{*}$r hexists $k $f] && $usehexpire && rand() < 0.5} { - {*}$r hexpire $k 1000 FIELDS 1 $f - } - } - } - } -} - -proc formatCommand {args} { - set cmd "*[llength $args]\r\n" - foreach a $args { - append cmd "$[string length $a]\r\n$a\r\n" - } - set _ $cmd -} - -proc csvdump r { - set o {} - if {$::singledb} { - set maxdb 1 - } else { - set maxdb 16 - } - for {set db 0} {$db < $maxdb} {incr db} { - if {!$::singledb} { - {*}$r select $db - } - foreach k [lsort [{*}$r keys *]] { - set type [{*}$r type $k] - append o [csvstring $db] , [csvstring $k] , [csvstring $type] , - switch $type { - string { - append o [csvstring [{*}$r get $k]] "\n" - } - list { - foreach e [{*}$r lrange $k 0 -1] { - append o [csvstring $e] , - } - append o "\n" - } - set { - foreach e [lsort [{*}$r smembers $k]] { - append o [csvstring $e] , - } - append o "\n" - } - zset { - foreach e [{*}$r zrange $k 0 -1 withscores] { - append o [csvstring $e] , - } - append o "\n" - } - hash { - set fields [{*}$r hgetall $k] - set newfields {} - foreach {f v} $fields { - set expirylist [{*}$r hexpiretime $k FIELDS 1 $f] - if {$expirylist eq (-1)} { - lappend newfields [list $f $v] - } else { - set e [lindex $expirylist 0] - lappend newfields [list $f $e $v] # TODO: extract the actual ttl value from the list in $e - } - } - set fields [lsort -index 0 $newfields] - foreach kv $fields { - append o [csvstring [lindex $kv 0]] , - append o [csvstring [lindex $kv 1]] , - } - append o "\n" - } - } - } - } - if {!$::singledb} { - {*}$r select 9 - } - return $o -} - -proc csvstring s { - return "\"$s\"" -} - -proc roundFloat f { - format "%.10g" $f -} - -set ::last_port_attempted 0 -proc find_available_port {start count} { - set port [expr $::last_port_attempted + 1] - for {set attempts 0} {$attempts < $count} {incr attempts} { - if {$port < $start || $port >= $start+$count} { - set port $start - } - set fd1 -1 - proc dummy_accept {chan addr port} {} - if {[catch {set fd1 [socket -server dummy_accept -myaddr 127.0.0.1 $port]}] || - [catch {set fd2 [socket -server dummy_accept -myaddr 127.0.0.1 [expr $port+10000]]}]} { - if {$fd1 != -1} { - close $fd1 - } - } else { - close $fd1 - close $fd2 - set ::last_port_attempted $port - return $port - } - incr port - } - error "Can't find a non busy port in the $start-[expr {$start+$count-1}] range." -} - -# Test if TERM looks like to support colors -proc color_term {} { - expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]} -} - -proc colorstr {color str} { - if {[color_term]} { - set b 0 - if {[string range $color 0 4] eq {bold-}} { - set b 1 - set color [string range $color 5 end] - } - switch $color { - red {set colorcode {31}} - green {set colorcode {32}} - yellow {set colorcode {33}} - blue {set colorcode {34}} - magenta {set colorcode {35}} - cyan {set colorcode {36}} - white {set colorcode {37}} - default {set colorcode {37}} - } - if {$colorcode ne {}} { - return "\033\[$b;${colorcode};49m$str\033\[0m" - } - } else { - return $str - } -} - -proc find_valgrind_errors {stderr on_termination} { - set fd [open $stderr] - set buf [read $fd] - close $fd - - # Look for stack trace (" at 0x") and other errors (Invalid, Mismatched, etc). - # Look for "Warnings", but not the "set address range perms". These don't indicate any real concern. - # corrupt-dump unit, not sure why but it seems they don't indicate any real concern. - if {[regexp -- { at 0x} $buf] || - [regexp -- {^(?=.*Warning)(?:(?!set address range perms).)*$} $buf] || - [regexp -- {Invalid} $buf] || - [regexp -- {Mismatched} $buf] || - [regexp -- {uninitialized} $buf] || - [regexp -- {has a fishy} $buf] || - [regexp -- {overlap} $buf]} { - return $buf - } - - # If the process didn't terminate yet, we can't look for the summary report - if {!$on_termination} { - return "" - } - - # Look for the absence of a leak free summary (happens when redis isn't terminated properly). - if {(![regexp -- {definitely lost: 0 bytes} $buf] && - ![regexp -- {no leaks are possible} $buf])} { - return $buf - } - - return "" -} - -# Execute a background process writing random data for the specified number -# of seconds to the specified Redis instance. If key is omitted, a random key -# is used for every SET command. -proc start_write_load {host port seconds {key ""} {size 0} {sleep 0}} { - set tclsh [info nameofexecutable] - exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds $::tls $key $size $sleep & -} - -# Stop a process generating write load executed with start_write_load. -proc stop_write_load {handle} { - catch {exec /bin/kill -9 $handle} -} - -proc wait_load_handlers_disconnected {{level 0}} { - wait_for_condition 50 100 { - ![string match {*name=LOAD_HANDLER*} [r $level client list]] - } else { - fail "load_handler(s) still connected after too long time." - } -} - -proc K { x y } { set x } - -# Shuffle a list with Fisher-Yates algorithm. -proc lshuffle {list} { - set n [llength $list] - while {$n>1} { - set j [expr {int(rand()*$n)}] - incr n -1 - if {$n==$j} continue - set v [lindex $list $j] - lset list $j [lindex $list $n] - lset list $n $v - } - return $list -} - -# Execute a background process writing complex data for the specified number -# of ops to the specified Redis instance. -proc start_bg_complex_data {host port db ops} { - set tclsh [info nameofexecutable] - exec $tclsh tests/helpers/bg_complex_data.tcl $host $port $db $ops $::tls & -} - -# Stop a process generating write load executed with start_bg_complex_data. -proc stop_bg_complex_data {handle} { - catch {exec /bin/kill -9 $handle} -} - -# Write num keys with the given key prefix and value size (in bytes). If idx is -# given, it's the index (AKA level) used with the srv procedure and it specifies -# to which Redis instance to write the keys. -proc populate {num {prefix key:} {size 3} {idx 0} {prints false} {expires 0}} { - r $idx deferred 1 - if {$num > 16} {set pipeline 16} else {set pipeline $num} - set val [string repeat A $size] - for {set j 0} {$j < $pipeline} {incr j} { - if {$expires > 0} { - r $idx set $prefix$j $val ex $expires - } else { - r $idx set $prefix$j $val - } - if {$prints} {puts $j} - } - for {} {$j < $num} {incr j} { - if {$expires > 0} { - r $idx set $prefix$j $val ex $expires - } else { - r $idx set $prefix$j $val - } - r $idx read - if {$prints} {puts $j} - } - for {set j 0} {$j < $pipeline} {incr j} { - r $idx read - if {$prints} {puts $j} - } - r $idx deferred 0 -} - -proc get_child_pid {idx} { - set pid [srv $idx pid] - if {[file exists "/usr/bin/pgrep"]} { - set fd [open "|pgrep -P $pid" "r"] - set child_pid [string trim [lindex [split [read $fd] \n] 0]] - } else { - set fd [open "|ps --ppid $pid -o pid" "r"] - set child_pid [string trim [lindex [split [read $fd] \n] 1]] - } - close $fd - - return $child_pid -} - -proc process_is_alive pid { - if {[catch {exec ps -p $pid -f} err]} { - return 0 - } else { - if {[string match "*<defunct>*" $err]} { return 0 } - return 1 - } -} - -proc get_system_name {} { - return [string tolower [exec uname -s]] -} - -proc get_proc_state {pid} { - if {[get_system_name] eq {sunos}} { - return [exec ps -o s= -p $pid] - } else { - return [exec ps -o state= -p $pid] - } -} - -proc get_proc_job {pid} { - if {[get_system_name] eq {sunos}} { - return [exec ps -l -p $pid] - } else { - return [exec ps j $pid] - } -} - -proc pause_process {pid} { - exec kill -SIGSTOP $pid - wait_for_condition 50 100 { - [string match "T*" [get_proc_state $pid]] - } else { - puts [get_proc_job $pid] - fail "process didn't stop" - } -} - -proc resume_process {pid} { - wait_for_condition 50 1000 { - [string match "T*" [get_proc_state $pid]] - } else { - puts [get_proc_job $pid] - fail "process was not stopped" - } - - set max_attempts 10 - set attempt 0 - while {($attempt < $max_attempts) && [string match "T*" [exec ps -o state= -p $pid]]} { - exec kill -SIGCONT $pid - - incr attempt - after 100 - } - - wait_for_condition 50 1000 { - [string match "R*" [exec ps -o state= -p $pid]] || - [string match "S*" [exec ps -o state= -p $pid]] - } else { - puts [exec ps j $pid] - fail "process was not resumed" - } -} - -proc cmdrstat {cmd r} { - if {[regexp "\r\ncmdstat_$cmd:(.*?)\r\n" [$r info commandstats] _ value]} { - set _ $value - } -} - -proc errorrstat {cmd r} { - if {[regexp "\r\nerrorstat_$cmd:(.*?)\r\n" [$r info errorstats] _ value]} { - set _ $value - } -} - -proc latencyrstat_percentiles {cmd r} { - if {[regexp "\r\nlatency_percentiles_usec_$cmd:(.*?)\r\n" [$r info latencystats] _ value]} { - set _ $value - } -} - -proc get_io_thread_clients {id {client r}} { - set pattern "io_thread_$id:clients=(\[0-9\]+)" - set info [$client info threads] - if {[regexp $pattern $info _ value]} { - return $value - } else { - return -1 - } -} - -proc generate_fuzzy_traffic_on_key {key type duration} { - # Commands per type, blocking commands removed - # TODO: extract these from COMMAND DOCS, and improve to include other types - 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} - set hash_commands {HDEL HEXISTS HGET HGETALL HINCRBY HINCRBYFLOAT HKEYS HLEN HMGET HMSET HSCAN HSET HSETNX HSTRLEN HVALS HRANDFIELD} - 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} - set list_commands {LINDEX LINSERT LLEN LPOP LPOS LPUSH LPUSHX LRANGE LREM LSET LTRIM RPOP RPOPLPUSH RPUSH RPUSHX} - set set_commands {SADD SCARD SDIFF SDIFFSTORE SINTER SINTERSTORE SISMEMBER SMEMBERS SMOVE SPOP SRANDMEMBER SREM SSCAN SUNION SUNIONSTORE} - set stream_commands {XACK XADD XCLAIM XDEL XGROUP XINFO XLEN XPENDING XRANGE XREAD XREADGROUP XREVRANGE XTRIM XDELEX XACKDEL} - set vset_commands {VADD VREM} - 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] - - set cmds [dict get $commands $type] - set start_time [clock seconds] - set sent {} - set succeeded 0 - while {([clock seconds]-$start_time) < $duration} { - # find a random command for our key type - set cmd_idx [expr {int(rand()*[llength $cmds])}] - set cmd [lindex $cmds $cmd_idx] - # get the command details from redis - if { [ catch { - set cmd_info [lindex [r command info $cmd] 0] - } err ] } { - # if we failed, it means redis crashed after the previous command - return $sent - } - # try to build a valid command argument - set arity [lindex $cmd_info 1] - set arity [expr $arity < 0 ? - $arity: $arity] - set firstkey [lindex $cmd_info 3] - set lastkey [lindex $cmd_info 4] - set i 1 - if {$cmd == "XINFO"} { - lappend cmd "STREAM" - lappend cmd $key - lappend cmd "FULL" - incr i 3 - } - if {$cmd == "XREAD"} { - lappend cmd "STREAMS" - lappend cmd $key - randpath { - lappend cmd \$ - } { - lappend cmd [randomValue] - } - incr i 3 - } - if {$cmd == "XADD"} { - lappend cmd $key - randpath { - lappend cmd "*" - } { - lappend cmd [randomValue] - } - lappend cmd [randomValue] - lappend cmd [randomValue] - incr i 4 - } - if {$cmd == "VADD"} { - lappend cmd $key - lappend cmd VALUES 3 1 1 1 - lappend cmd [randomValue] - incr i 7 - } - if {$cmd == "VREM"} { - lappend cmd $key - lappend cmd [randomValue] - incr i 2 - } - - for {} {$i < $arity} {incr i} { - if {$i == $firstkey || $i == $lastkey} { - lappend cmd $key - } else { - lappend cmd [randomValue] - } - } - # execute the command, we expect commands to fail on syntax errors - lappend sent $cmd - if { ! [ catch { - r {*}$cmd - } err ] } { - incr succeeded - } else { - set err [format "%s" $err] ;# convert to string for pattern matching - if {[string match "*SIGTERM*" $err]} { - puts "commands caused test to hang:" - foreach cmd $sent { - foreach arg $cmd { - puts -nonewline "[string2printable $arg] " - } - puts "" - } - # Re-raise, let handler up the stack take care of this. - error $err $::errorInfo - } - } - } - - # print stats so that we know if we managed to generate commands that actually made sense - #if {$::verbose} { - # set count [llength $sent] - # puts "Fuzzy traffic sent: $count, succeeded: $succeeded" - #} - - # return the list of commands we sent - return $sent -} - -proc string2printable s { - set res {} - set has_special_chars false - foreach i [split $s {}] { - scan $i %c int - # non printable characters, including space and excluding: " \ $ { } - if {$int < 32 || $int > 122 || $int == 34 || $int == 36 || $int == 92} { - set has_special_chars true - } - # TCL8.5 has issues mixing \x notation and normal chars in the same - # source code string, so we'll convert the entire string. - append res \\x[format %02X $int] - } - if {!$has_special_chars} { - return $s - } - set res "\"$res\"" - return $res -} - -# Calculation value of Chi-Square Distribution. By this value -# we can verify the random distribution sample confidence. -# Based on the following wiki: -# https://en.wikipedia.org/wiki/Chi-square_distribution -# -# param res Random sample list -# return Value of Chi-Square Distribution -# -# x2_value: return of chi_square_value function -# df: Degrees of freedom, Number of independent values minus 1 -# -# By using x2_value and df to back check the cardinality table, -# we can know the confidence of the random sample. -proc chi_square_value {res} { - unset -nocomplain mydict - foreach key $res { - dict incr mydict $key 1 - } - - set x2_value 0 - set p [expr [llength $res] / [dict size $mydict]] - foreach key [dict keys $mydict] { - set value [dict get $mydict $key] - - # Aggregate the chi-square value of each element - set v [expr {pow($value - $p, 2) / $p}] - set x2_value [expr {$x2_value + $v}] - } - - return $x2_value -} - -#subscribe to Pub/Sub channels -proc consume_subscribe_messages {client type channels} { - set numsub -1 - set counts {} - - for {set i [llength $channels]} {$i > 0} {incr i -1} { - set msg [$client read] - assert_equal $type [lindex $msg 0] - - # when receiving subscribe messages the channels names - # are ordered. when receiving unsubscribe messages - # they are unordered - set idx [lsearch -exact $channels [lindex $msg 1]] - if {[string match "*unsubscribe" $type]} { - assert {$idx >= 0} - } else { - assert {$idx == 0} - } - set channels [lreplace $channels $idx $idx] - - # aggregate the subscription count to return to the caller - lappend counts [lindex $msg 2] - } - - # we should have received messages for channels - assert {[llength $channels] == 0} - return $counts -} - -proc subscribe {client channels} { - $client subscribe {*}$channels - consume_subscribe_messages $client subscribe $channels -} - -proc ssubscribe {client channels} { - $client ssubscribe {*}$channels - consume_subscribe_messages $client ssubscribe $channels -} - -proc unsubscribe {client {channels {}}} { - $client unsubscribe {*}$channels - consume_subscribe_messages $client unsubscribe $channels -} - -proc sunsubscribe {client {channels {}}} { - $client sunsubscribe {*}$channels - consume_subscribe_messages $client sunsubscribe $channels -} - -proc psubscribe {client channels} { - $client psubscribe {*}$channels - consume_subscribe_messages $client psubscribe $channels -} - -proc punsubscribe {client {channels {}}} { - $client punsubscribe {*}$channels - consume_subscribe_messages $client punsubscribe $channels -} - -proc debug_digest_value {key} { - if {[lsearch $::denytags "needs:debug"] >= 0 || $::ignoredigest} { - return "dummy-digest-value" - } - r debug digest-value $key -} - -proc debug_digest {{level 0}} { - if {[lsearch $::denytags "needs:debug"] >= 0 || $::ignoredigest} { - return "dummy-digest" - } - r $level debug digest -} - -proc wait_for_blocked_client {{idx 0}} { - wait_for_condition 50 100 { - [s $idx blocked_clients] ne 0 - } else { - fail "no blocked clients" - } -} - -proc wait_for_blocked_clients_count {count {maxtries 100} {delay 10} {idx 0}} { - wait_for_condition $maxtries $delay { - [s $idx blocked_clients] == $count - } else { - fail "Timeout waiting for blocked clients (expected $count, actual [s $idx blocked_clients])" - } -} - -proc wait_for_watched_clients_count {count {maxtries 100} {delay 10} {idx 0}} { - wait_for_condition $maxtries $delay { - [s $idx watching_clients] == $count - } else { - fail "Timeout waiting for watched clients" - } -} - -proc read_from_aof {fp} { - # Input fp is a blocking binary file descriptor of an opened AOF file. - if {[gets $fp count] == -1} return "" - set count [string range $count 1 end] - - # Return a list of arguments for the command. - set res {} - for {set j 0} {$j < $count} {incr j} { - read $fp 1 - set arg [::redis::redis_bulk_read $fp] - if {$j == 0} {set arg [string tolower $arg]} - lappend res $arg - } - return $res -} - -proc assert_aof_content {aof_path patterns} { - set fp [open $aof_path r] - fconfigure $fp -translation binary - fconfigure $fp -blocking 1 - - for {set j 0} {$j < [llength $patterns]} {incr j} { - assert_match [lindex $patterns $j] [read_from_aof $fp] - } -} - -proc config_set {param value {options {}}} { - set mayfail 0 - foreach option $options { - switch $option { - "mayfail" { - set mayfail 1 - } - default { - error "Unknown option $option" - } - } - } - - if {[catch {r config set $param $value} err]} { - if {!$mayfail} { - error $err - } else { - if {$::verbose} { - puts "Ignoring CONFIG SET $param $value failure: $err" - } - } - } -} - -proc config_get_set {param value {options {}}} { - set config [lindex [r config get $param] 1] - config_set $param $value $options - return $config -} - -proc delete_lines_with_pattern {filename tmpfilename pattern} { - set fh_in [open $filename r] - set fh_out [open $tmpfilename w] - while {[gets $fh_in line] != -1} { - if {![regexp $pattern $line]} { - puts $fh_out $line - } - } - close $fh_in - close $fh_out - file rename -force $tmpfilename $filename -} - -proc get_nonloopback_addr {} { - set addrlist [list {}] - catch { set addrlist [exec hostname -I] } - return [lindex $addrlist 0] -} - -proc get_nonloopback_client {} { - return [redis [get_nonloopback_addr] [srv 0 "port"] 0 $::tls] -} - -# The following functions and variables are used only when running large-memory -# tests. We avoid defining them when not running large-memory tests because the -# global variables takes up lots of memory. -proc init_large_mem_vars {} { - if {![info exists ::str500]} { - set ::str500 [string repeat x 500000000] ;# 500mb - set ::str500_len [string length $::str500] - } -} - -# Utility function to write big argument into redis client connection -proc write_big_bulk {size {prefix ""} {skip_read no}} { - init_large_mem_vars - - assert {[string length prefix] <= $size} - r write "\$$size\r\n" - r write $prefix - incr size -[string length $prefix] - while {$size >= 500000000} { - r write $::str500 - incr size -500000000 - } - if {$size > 0} { - r write [string repeat x $size] - } - r write "\r\n" - if {!$skip_read} { - r flush - r read - } -} - -# Utility to read big bulk response (work around Tcl limitations) -proc read_big_bulk {code {compare no} {prefix ""}} { - init_large_mem_vars - - r readraw 1 - set resp_len [uplevel 1 $code] ;# get the first line of the RESP response - assert_equal [string range $resp_len 0 0] "$" - set resp_len [string range $resp_len 1 end] - set prefix_len [string length $prefix] - if {$compare} { - assert {$prefix_len <= $resp_len} - assert {$prefix_len <= $::str500_len} - } - - set remaining $resp_len - while {$remaining > 0} { - set l $remaining - 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 - set read_data [r rawread $l] - set nbytes [string length $read_data] - if {$compare} { - set comp_len $nbytes - # Compare prefix part - if {$remaining == $resp_len} { - assert_equal $prefix [string range $read_data 0 [expr $prefix_len - 1]] - set read_data [string range $read_data $prefix_len $nbytes] - incr comp_len -$prefix_len - } - # Compare rest of data, evaluate and then assert to avoid huge print in case of failure - set data_equal [expr {$read_data == [string range $::str500 0 [expr $comp_len - 1]]}] - assert $data_equal - } - incr remaining -$nbytes - } - assert_equal [r rawread 2] "\r\n" - r readraw 0 - return $resp_len -} - -proc prepare_value {size} { - set _v "c" - for {set i 1} {$i < $size} {incr i} { - append _v 0 - } - return $_v -} - -proc memory_usage {key} { - set usage [r memory usage $key] - if {![string match {*jemalloc*} [s mem_allocator]]} { - # libc allocator can sometimes return a different size allocation for the same requested size - # this makes tests that rely on MEMORY USAGE unreliable, so instead we return a constant 1 - set usage 1 - } - return $usage -} - -# Test if the server supports the specified command. -proc server_has_command {cmd_wanted} { - set lowercase_commands {} - foreach cmd [r command list] { - lappend lowercase_commands [string tolower $cmd] - } - expr {[lsearch $lowercase_commands [string tolower $cmd_wanted]] != -1} -} - -# forward compatibility, lmap missing in TCL 8.5 -proc lmap args { - set body [lindex $args end] - set args [lrange $args 0 end-1] - set n 0 - set pairs [list] - foreach {varnames listval} $args { - set varlist [list] - foreach varname $varnames { - upvar 1 $varname var$n - lappend varlist var$n - incr n - } - lappend pairs $varlist $listval - } - set temp [list] - foreach {*}$pairs { - lappend temp [uplevel 1 $body] - } - set temp -} - -proc format_command {args} { - set cmd "*[llength $args]\r\n" - foreach a $args { - append cmd "$[string length $a]\r\n$a\r\n" - } - set _ $cmd -} - -# Returns whether or not the system supports stack traces -proc system_backtrace_supported {} { - # Thread sanitizer reports backtrace_symbols_fd() as - # signal-unsafe since it allocates memory - if {$::tsan} { - return 0 - } - - set system_name [get_system_name] - if {$system_name eq {darwin}} { - return 1 - } elseif {$system_name ne {linux}} { - return 0 - } - - # libmusl does not support backtrace. Also return 0 on - # static binaries (ldd exit code 1) where we can't detect libmusl - if {![catch {set ldd [exec ldd src/redis-server]}]} { - if {![string match {*libc.*musl*} $ldd]} { - return 1 - } - } - return 0 -} - -proc generate_largevalue_test_array {} { - array set largevalue {} - set largevalue(listpack) "hello" - set largevalue(quicklist) [string repeat "x" 8192] - return [array get largevalue] -} |