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}} { set minval 48 set maxval 122 } elseif {$type eq {compr}} { set minval 48 set maxval 52 } while {$len} { append output [format "%c" [expr {$minval+int(rand()*($maxval-$minval+1))}]] 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 warnings_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 value for INFO property proc status {r property} { if {[regexp "\r\n$property:(.*?)\r\n" [{*}$r info] _ value]} { set _ $value } } 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 1000 } 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 1000 } else { break } } } proc wait_for_sync r { while 1 { if {[status $r master_link_status] eq "down"} { after 10 } else { break } } } 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 didn't sync in time" } } proc wait_for_log_message {srv_idx pattern last_lines maxtries delay} { set retry $maxtries set stdout [srv $srv_idx stdout] while {$retry} { set result [exec tail -$last_lines < $stdout] set result [split $result "\n"] foreach line $result { if {[string match $pattern $line]} { return $line } } incr retry -1 after $delay } if {$retry == 0} { fail "log message of '$pattern' not found" } } # Random integer between 0 and max (excluded). proc randomInt {max} { expr {int(rand()*$max)} } # 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 {}}} { for {set j 0} {$j < $ops} {incr j} { set k [randomKey] set k2 [randomKey] set f [randomValue] set v [randomValue] if {[lsearch -exact $opt useexpire] != -1} { 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 {} for {set db 0} {$db < 16} {incr db} { {*}$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" } } } } {*}$r select 9 return $o } proc csvstring s { return "\"$s\"" } proc roundFloat f { format "%.10g" $f } proc find_available_port start { for {set j $start} {$j < $start+1024} {incr j} { if {[catch {set fd1 [socket 127.0.0.1 $j]}] && [catch {set fd2 [socket 127.0.0.1 [expr $j+10000]]}]} { return $j } else { catch { close $fd1 close $fd2 } } } if {$j == $start+1024} { error "Can't find a non busy port in the $start-[expr {$start+1023}] 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 } } # 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 K { x y } { set x } # Shuffle a list. From Tcl wiki. Originally from Steve Cohen that improved # other versions. Code should be under public domain. proc lshuffle {list} { set n [llength $list] while {$n>0} { set j [expr {int(rand()*$n)}] lappend slist [lindex $list $j] incr n -1 set temp [lindex $list $n] set list [lreplace [K $list [set list {}]] $j $j $temp] } return $slist } # 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} }