"Fossies" - the Fresh Open Source Software Archive

Member "redis-5.0.6/tests/support/util.tcl" (25 Sep 2019, 10942 Bytes) of package /linux/misc/redis-5.0.6.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the last Fossies "Diffs" side-by-side code changes report for "util.tcl": 5.0.2_vs_5.0.3.

    1 proc randstring {min max {type binary}} {
    2     set len [expr {$min+int(rand()*($max-$min+1))}]
    3     set output {}
    4     if {$type eq {binary}} {
    5         set minval 0
    6         set maxval 255
    7     } elseif {$type eq {alpha}} {
    8         set minval 48
    9         set maxval 122
   10     } elseif {$type eq {compr}} {
   11         set minval 48
   12         set maxval 52
   13     }
   14     while {$len} {
   15         append output [format "%c" [expr {$minval+int(rand()*($maxval-$minval+1))}]]
   16         incr len -1
   17     }
   18     return $output
   19 }
   20 
   21 # Useful for some test
   22 proc zlistAlikeSort {a b} {
   23     if {[lindex $a 0] > [lindex $b 0]} {return 1}
   24     if {[lindex $a 0] < [lindex $b 0]} {return -1}
   25     string compare [lindex $a 1] [lindex $b 1]
   26 }
   27 
   28 # Return all log lines starting with the first line that contains a warning.
   29 # Generally, this will be an assertion error with a stack trace.
   30 proc warnings_from_file {filename} {
   31     set lines [split [exec cat $filename] "\n"]
   32     set matched 0
   33     set logall 0
   34     set result {}
   35     foreach line $lines {
   36         if {[string match {*REDIS BUG REPORT START*} $line]} {
   37             set logall 1
   38         }
   39         if {[regexp {^\[\d+\]\s+\d+\s+\w+\s+\d{2}:\d{2}:\d{2} \#} $line]} {
   40             set matched 1
   41         }
   42         if {$logall || $matched} {
   43             lappend result $line
   44         }
   45     }
   46     join $result "\n"
   47 }
   48 
   49 # Return value for INFO property
   50 proc status {r property} {
   51     if {[regexp "\r\n$property:(.*?)\r\n" [{*}$r info] _ value]} {
   52         set _ $value
   53     }
   54 }
   55 
   56 proc waitForBgsave r {
   57     while 1 {
   58         if {[status r rdb_bgsave_in_progress] eq 1} {
   59             if {$::verbose} {
   60                 puts -nonewline "\nWaiting for background save to finish... "
   61                 flush stdout
   62             }
   63             after 1000
   64         } else {
   65             break
   66         }
   67     }
   68 }
   69 
   70 proc waitForBgrewriteaof r {
   71     while 1 {
   72         if {[status r aof_rewrite_in_progress] eq 1} {
   73             if {$::verbose} {
   74                 puts -nonewline "\nWaiting for background AOF rewrite to finish... "
   75                 flush stdout
   76             }
   77             after 1000
   78         } else {
   79             break
   80         }
   81     }
   82 }
   83 
   84 proc wait_for_sync r {
   85     while 1 {
   86         if {[status $r master_link_status] eq "down"} {
   87             after 10
   88         } else {
   89             break
   90         }
   91     }
   92 }
   93 
   94 proc wait_for_ofs_sync {r1 r2} {
   95     wait_for_condition 50 100 {
   96         [status $r1 master_repl_offset] eq [status $r2 master_repl_offset]
   97     } else {
   98         fail "replica didn't sync in time"
   99     }
  100 }
  101 
  102 # Random integer between 0 and max (excluded).
  103 proc randomInt {max} {
  104     expr {int(rand()*$max)}
  105 }
  106 
  107 # Random signed integer between -max and max (both extremes excluded).
  108 proc randomSignedInt {max} {
  109     set i [randomInt $max]
  110     if {rand() > 0.5} {
  111         set i -$i
  112     }
  113     return $i
  114 }
  115 
  116 proc randpath args {
  117     set path [expr {int(rand()*[llength $args])}]
  118     uplevel 1 [lindex $args $path]
  119 }
  120 
  121 proc randomValue {} {
  122     randpath {
  123         # Small enough to likely collide
  124         randomSignedInt 1000
  125     } {
  126         # 32 bit compressible signed/unsigned
  127         randpath {randomSignedInt 2000000000} {randomSignedInt 4000000000}
  128     } {
  129         # 64 bit
  130         randpath {randomSignedInt 1000000000000}
  131     } {
  132         # Random string
  133         randpath {randstring 0 256 alpha} \
  134                 {randstring 0 256 compr} \
  135                 {randstring 0 256 binary}
  136     }
  137 }
  138 
  139 proc randomKey {} {
  140     randpath {
  141         # Small enough to likely collide
  142         randomInt 1000
  143     } {
  144         # 32 bit compressible signed/unsigned
  145         randpath {randomInt 2000000000} {randomInt 4000000000}
  146     } {
  147         # 64 bit
  148         randpath {randomInt 1000000000000}
  149     } {
  150         # Random string
  151         randpath {randstring 1 256 alpha} \
  152                 {randstring 1 256 compr}
  153     }
  154 }
  155 
  156 proc findKeyWithType {r type} {
  157     for {set j 0} {$j < 20} {incr j} {
  158         set k [{*}$r randomkey]
  159         if {$k eq {}} {
  160             return {}
  161         }
  162         if {[{*}$r type $k] eq $type} {
  163             return $k
  164         }
  165     }
  166     return {}
  167 }
  168 
  169 proc createComplexDataset {r ops {opt {}}} {
  170     for {set j 0} {$j < $ops} {incr j} {
  171         set k [randomKey]
  172         set k2 [randomKey]
  173         set f [randomValue]
  174         set v [randomValue]
  175 
  176         if {[lsearch -exact $opt useexpire] != -1} {
  177             if {rand() < 0.1} {
  178                 {*}$r expire [randomKey] [randomInt 2]
  179             }
  180         }
  181 
  182         randpath {
  183             set d [expr {rand()}]
  184         } {
  185             set d [expr {rand()}]
  186         } {
  187             set d [expr {rand()}]
  188         } {
  189             set d [expr {rand()}]
  190         } {
  191             set d [expr {rand()}]
  192         } {
  193             randpath {set d +inf} {set d -inf}
  194         }
  195         set t [{*}$r type $k]
  196 
  197         if {$t eq {none}} {
  198             randpath {
  199                 {*}$r set $k $v
  200             } {
  201                 {*}$r lpush $k $v
  202             } {
  203                 {*}$r sadd $k $v
  204             } {
  205                 {*}$r zadd $k $d $v
  206             } {
  207                 {*}$r hset $k $f $v
  208             } {
  209                 {*}$r del $k
  210             }
  211             set t [{*}$r type $k]
  212         }
  213 
  214         switch $t {
  215             {string} {
  216                 # Nothing to do
  217             }
  218             {list} {
  219                 randpath {{*}$r lpush $k $v} \
  220                         {{*}$r rpush $k $v} \
  221                         {{*}$r lrem $k 0 $v} \
  222                         {{*}$r rpop $k} \
  223                         {{*}$r lpop $k}
  224             }
  225             {set} {
  226                 randpath {{*}$r sadd $k $v} \
  227                         {{*}$r srem $k $v} \
  228                         {
  229                             set otherset [findKeyWithType {*}$r set]
  230                             if {$otherset ne {}} {
  231                                 randpath {
  232                                     {*}$r sunionstore $k2 $k $otherset
  233                                 } {
  234                                     {*}$r sinterstore $k2 $k $otherset
  235                                 } {
  236                                     {*}$r sdiffstore $k2 $k $otherset
  237                                 }
  238                             }
  239                         }
  240             }
  241             {zset} {
  242                 randpath {{*}$r zadd $k $d $v} \
  243                         {{*}$r zrem $k $v} \
  244                         {
  245                             set otherzset [findKeyWithType {*}$r zset]
  246                             if {$otherzset ne {}} {
  247                                 randpath {
  248                                     {*}$r zunionstore $k2 2 $k $otherzset
  249                                 } {
  250                                     {*}$r zinterstore $k2 2 $k $otherzset
  251                                 }
  252                             }
  253                         }
  254             }
  255             {hash} {
  256                 randpath {{*}$r hset $k $f $v} \
  257                         {{*}$r hdel $k $f}
  258             }
  259         }
  260     }
  261 }
  262 
  263 proc formatCommand {args} {
  264     set cmd "*[llength $args]\r\n"
  265     foreach a $args {
  266         append cmd "$[string length $a]\r\n$a\r\n"
  267     }
  268     set _ $cmd
  269 }
  270 
  271 proc csvdump r {
  272     set o {}
  273     for {set db 0} {$db < 16} {incr db} {
  274         {*}$r select $db
  275         foreach k [lsort [{*}$r keys *]] {
  276             set type [{*}$r type $k]
  277             append o [csvstring $db] , [csvstring $k] , [csvstring $type] ,
  278             switch $type {
  279                 string {
  280                     append o [csvstring [{*}$r get $k]] "\n"
  281                 }
  282                 list {
  283                     foreach e [{*}$r lrange $k 0 -1] {
  284                         append o [csvstring $e] ,
  285                     }
  286                     append o "\n"
  287                 }
  288                 set {
  289                     foreach e [lsort [{*}$r smembers $k]] {
  290                         append o [csvstring $e] ,
  291                     }
  292                     append o "\n"
  293                 }
  294                 zset {
  295                     foreach e [{*}$r zrange $k 0 -1 withscores] {
  296                         append o [csvstring $e] ,
  297                     }
  298                     append o "\n"
  299                 }
  300                 hash {
  301                     set fields [{*}$r hgetall $k]
  302                     set newfields {}
  303                     foreach {k v} $fields {
  304                         lappend newfields [list $k $v]
  305                     }
  306                     set fields [lsort -index 0 $newfields]
  307                     foreach kv $fields {
  308                         append o [csvstring [lindex $kv 0]] ,
  309                         append o [csvstring [lindex $kv 1]] ,
  310                     }
  311                     append o "\n"
  312                 }
  313             }
  314         }
  315     }
  316     {*}$r select 9
  317     return $o
  318 }
  319 
  320 proc csvstring s {
  321     return "\"$s\""
  322 }
  323 
  324 proc roundFloat f {
  325     format "%.10g" $f
  326 }
  327 
  328 proc find_available_port start {
  329     for {set j $start} {$j < $start+1024} {incr j} {
  330         if {[catch {set fd1 [socket 127.0.0.1 $j]}] &&
  331             [catch {set fd2 [socket 127.0.0.1 [expr $j+10000]]}]} {
  332             return $j
  333         } else {
  334             catch {
  335                 close $fd1
  336                 close $fd2
  337             }
  338         }
  339     }
  340     if {$j == $start+1024} {
  341         error "Can't find a non busy port in the $start-[expr {$start+1023}] range."
  342     }
  343 }
  344 
  345 # Test if TERM looks like to support colors
  346 proc color_term {} {
  347     expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]}
  348 }
  349 
  350 proc colorstr {color str} {
  351     if {[color_term]} {
  352         set b 0
  353         if {[string range $color 0 4] eq {bold-}} {
  354             set b 1
  355             set color [string range $color 5 end]
  356         }
  357         switch $color {
  358             red {set colorcode {31}}
  359             green {set colorcode {32}}
  360             yellow {set colorcode {33}}
  361             blue {set colorcode {34}}
  362             magenta {set colorcode {35}}
  363             cyan {set colorcode {36}}
  364             white {set colorcode {37}}
  365             default {set colorcode {37}}
  366         }
  367         if {$colorcode ne {}} {
  368             return "\033\[$b;${colorcode};49m$str\033\[0m"
  369         }
  370     } else {
  371         return $str
  372     }
  373 }
  374 
  375 # Execute a background process writing random data for the specified number
  376 # of seconds to the specified Redis instance.
  377 proc start_write_load {host port seconds} {
  378     set tclsh [info nameofexecutable]
  379     exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds &
  380 }
  381 
  382 # Stop a process generating write load executed with start_write_load.
  383 proc stop_write_load {handle} {
  384     catch {exec /bin/kill -9 $handle}
  385 }
  386 
  387 proc K { x y } { set x } 
  388 
  389 # Shuffle a list. From Tcl wiki. Originally from Steve Cohen that improved
  390 # other versions. Code should be under public domain.
  391 proc lshuffle {list} {
  392     set n [llength $list]
  393     while {$n>0} {
  394         set j [expr {int(rand()*$n)}]
  395         lappend slist [lindex $list $j]
  396         incr n -1
  397         set temp [lindex $list $n]
  398         set list [lreplace [K $list [set list {}]] $j $j $temp]
  399     }
  400     return $slist
  401 }