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 if ([string match {*WARNING: AddressSanitizer 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 { wait_for_condition 50 100 { [status $r master_link_status] eq "up" } else { fail "replica didn't sync in time" } } proc wait_replica_online r { wait_for_condition 50 100 { [string match "*slave0:*,state=online*" [$r info replication]] } else { fail "replica didn't online in time" } } proc wait_for_ofs_sync {r1 r2} { wait_for_condition 50 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}] 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} } } } } 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 {k v} $fields { lappend newfields [list $k $v] } 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 if {[catch {set fd1 [socket -server 127.0.0.1 $port]}] || [catch {set fd2 [socket -server 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. proc start_write_load {host port seconds} { set tclsh [info nameofexecutable] exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds $::tls & } # 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}} { 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} { r $idx set $prefix$j $val if {$prints} {puts $j} } for {} {$j < $num} {incr j} { 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 "**" $err]} { return 0 } return 1 } } proc pause_process pid { exec kill -SIGSTOP $pid wait_for_condition 50 100 { [string match {*T*} [lindex [exec ps j $pid] 16]] } else { puts [exec ps j $pid] fail "process didn't stop" } } proc resume_process pid { exec kill -SIGCONT $pid } 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 generate_fuzzy_traffic_on_key {key 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} set commands [dict create string $string_commands hash $hash_commands zset $zset_commands list $list_commands set $set_commands stream $stream_commands] set type [r type $key] 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 } 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" } } 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 } # 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 }