"Fossies" - the Fresh Open Source Software Archive

Member "redis-6.0.8/tests/support/util.tcl" (10 Sep 2020, 14866 Bytes) of package /linux/misc/redis-6.0.8.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 latest Fossies "Diffs" side-by-side code changes report for "util.tcl": 6.0.7_vs_6.0.8.

    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 proc wait_done_loading r {
  103     wait_for_condition 50 100 {
  104         [catch {$r ping} e] == 0
  105     } else {
  106         fail "Loading DB is taking too much time."
  107     }
  108 }
  109 
  110 # count current log lines in server's stdout
  111 proc count_log_lines {srv_idx} {
  112     set _ [exec wc -l < [srv $srv_idx stdout]]
  113 }
  114 
  115 # verify pattern exists in server's sdtout after a certain line number
  116 proc verify_log_message {srv_idx pattern from_line} {
  117     incr from_line
  118     set result [exec tail -n +$from_line < [srv $srv_idx stdout]]
  119     if {![string match $pattern $result]} {
  120         error "assertion:expected message not found in log file: $pattern"
  121     }
  122 }
  123 
  124 # wait for pattern to be found in server's stdout after certain line number
  125 # return value is a list containing the line that matched the pattern and the line number
  126 proc wait_for_log_messages {srv_idx patterns from_line maxtries delay} {
  127     set retry $maxtries
  128     set next_line [expr $from_line + 1] ;# searching form the line after
  129     set stdout [srv $srv_idx stdout]
  130     while {$retry} {
  131         set result [exec tail -n +$next_line < $stdout]
  132         set result [split $result "\n"]
  133         foreach line $result {
  134             foreach pattern $patterns {
  135                 if {[string match $pattern $line]} {
  136                     return [list $line $next_line]
  137                 }
  138             }
  139             incr next_line
  140         }
  141         incr retry -1
  142         after $delay
  143     }
  144     if {$retry == 0} {
  145         fail "log message of '$patterns' not found in $stdout after line: $from_line till line: [expr $next_line -1]"
  146     }
  147 }
  148 
  149 # write line to server log file
  150 proc write_log_line {srv_idx msg} {
  151     set logfile [srv $srv_idx stdout]
  152     set fd [open $logfile "a+"]
  153     puts $fd "### $msg"
  154     close $fd
  155 }
  156 
  157 # Random integer between 0 and max (excluded).
  158 proc randomInt {max} {
  159     expr {int(rand()*$max)}
  160 }
  161 
  162 # Random signed integer between -max and max (both extremes excluded).
  163 proc randomSignedInt {max} {
  164     set i [randomInt $max]
  165     if {rand() > 0.5} {
  166         set i -$i
  167     }
  168     return $i
  169 }
  170 
  171 proc randpath args {
  172     set path [expr {int(rand()*[llength $args])}]
  173     uplevel 1 [lindex $args $path]
  174 }
  175 
  176 proc randomValue {} {
  177     randpath {
  178         # Small enough to likely collide
  179         randomSignedInt 1000
  180     } {
  181         # 32 bit compressible signed/unsigned
  182         randpath {randomSignedInt 2000000000} {randomSignedInt 4000000000}
  183     } {
  184         # 64 bit
  185         randpath {randomSignedInt 1000000000000}
  186     } {
  187         # Random string
  188         randpath {randstring 0 256 alpha} \
  189                 {randstring 0 256 compr} \
  190                 {randstring 0 256 binary}
  191     }
  192 }
  193 
  194 proc randomKey {} {
  195     randpath {
  196         # Small enough to likely collide
  197         randomInt 1000
  198     } {
  199         # 32 bit compressible signed/unsigned
  200         randpath {randomInt 2000000000} {randomInt 4000000000}
  201     } {
  202         # 64 bit
  203         randpath {randomInt 1000000000000}
  204     } {
  205         # Random string
  206         randpath {randstring 1 256 alpha} \
  207                 {randstring 1 256 compr}
  208     }
  209 }
  210 
  211 proc findKeyWithType {r type} {
  212     for {set j 0} {$j < 20} {incr j} {
  213         set k [{*}$r randomkey]
  214         if {$k eq {}} {
  215             return {}
  216         }
  217         if {[{*}$r type $k] eq $type} {
  218             return $k
  219         }
  220     }
  221     return {}
  222 }
  223 
  224 proc createComplexDataset {r ops {opt {}}} {
  225     for {set j 0} {$j < $ops} {incr j} {
  226         set k [randomKey]
  227         set k2 [randomKey]
  228         set f [randomValue]
  229         set v [randomValue]
  230 
  231         if {[lsearch -exact $opt useexpire] != -1} {
  232             if {rand() < 0.1} {
  233                 {*}$r expire [randomKey] [randomInt 2]
  234             }
  235         }
  236 
  237         randpath {
  238             set d [expr {rand()}]
  239         } {
  240             set d [expr {rand()}]
  241         } {
  242             set d [expr {rand()}]
  243         } {
  244             set d [expr {rand()}]
  245         } {
  246             set d [expr {rand()}]
  247         } {
  248             randpath {set d +inf} {set d -inf}
  249         }
  250         set t [{*}$r type $k]
  251 
  252         if {$t eq {none}} {
  253             randpath {
  254                 {*}$r set $k $v
  255             } {
  256                 {*}$r lpush $k $v
  257             } {
  258                 {*}$r sadd $k $v
  259             } {
  260                 {*}$r zadd $k $d $v
  261             } {
  262                 {*}$r hset $k $f $v
  263             } {
  264                 {*}$r del $k
  265             }
  266             set t [{*}$r type $k]
  267         }
  268 
  269         switch $t {
  270             {string} {
  271                 # Nothing to do
  272             }
  273             {list} {
  274                 randpath {{*}$r lpush $k $v} \
  275                         {{*}$r rpush $k $v} \
  276                         {{*}$r lrem $k 0 $v} \
  277                         {{*}$r rpop $k} \
  278                         {{*}$r lpop $k}
  279             }
  280             {set} {
  281                 randpath {{*}$r sadd $k $v} \
  282                         {{*}$r srem $k $v} \
  283                         {
  284                             set otherset [findKeyWithType {*}$r set]
  285                             if {$otherset ne {}} {
  286                                 randpath {
  287                                     {*}$r sunionstore $k2 $k $otherset
  288                                 } {
  289                                     {*}$r sinterstore $k2 $k $otherset
  290                                 } {
  291                                     {*}$r sdiffstore $k2 $k $otherset
  292                                 }
  293                             }
  294                         }
  295             }
  296             {zset} {
  297                 randpath {{*}$r zadd $k $d $v} \
  298                         {{*}$r zrem $k $v} \
  299                         {
  300                             set otherzset [findKeyWithType {*}$r zset]
  301                             if {$otherzset ne {}} {
  302                                 randpath {
  303                                     {*}$r zunionstore $k2 2 $k $otherzset
  304                                 } {
  305                                     {*}$r zinterstore $k2 2 $k $otherzset
  306                                 }
  307                             }
  308                         }
  309             }
  310             {hash} {
  311                 randpath {{*}$r hset $k $f $v} \
  312                         {{*}$r hdel $k $f}
  313             }
  314         }
  315     }
  316 }
  317 
  318 proc formatCommand {args} {
  319     set cmd "*[llength $args]\r\n"
  320     foreach a $args {
  321         append cmd "$[string length $a]\r\n$a\r\n"
  322     }
  323     set _ $cmd
  324 }
  325 
  326 proc csvdump r {
  327     set o {}
  328     for {set db 0} {$db < 16} {incr db} {
  329         {*}$r select $db
  330         foreach k [lsort [{*}$r keys *]] {
  331             set type [{*}$r type $k]
  332             append o [csvstring $db] , [csvstring $k] , [csvstring $type] ,
  333             switch $type {
  334                 string {
  335                     append o [csvstring [{*}$r get $k]] "\n"
  336                 }
  337                 list {
  338                     foreach e [{*}$r lrange $k 0 -1] {
  339                         append o [csvstring $e] ,
  340                     }
  341                     append o "\n"
  342                 }
  343                 set {
  344                     foreach e [lsort [{*}$r smembers $k]] {
  345                         append o [csvstring $e] ,
  346                     }
  347                     append o "\n"
  348                 }
  349                 zset {
  350                     foreach e [{*}$r zrange $k 0 -1 withscores] {
  351                         append o [csvstring $e] ,
  352                     }
  353                     append o "\n"
  354                 }
  355                 hash {
  356                     set fields [{*}$r hgetall $k]
  357                     set newfields {}
  358                     foreach {k v} $fields {
  359                         lappend newfields [list $k $v]
  360                     }
  361                     set fields [lsort -index 0 $newfields]
  362                     foreach kv $fields {
  363                         append o [csvstring [lindex $kv 0]] ,
  364                         append o [csvstring [lindex $kv 1]] ,
  365                     }
  366                     append o "\n"
  367                 }
  368             }
  369         }
  370     }
  371     {*}$r select 9
  372     return $o
  373 }
  374 
  375 proc csvstring s {
  376     return "\"$s\""
  377 }
  378 
  379 proc roundFloat f {
  380     format "%.10g" $f
  381 }
  382 
  383 set ::last_port_attempted 0
  384 proc find_available_port {start count} {
  385     set port [expr $::last_port_attempted + 1]
  386     for {set attempts 0} {$attempts < $count} {incr attempts} {
  387         if {$port < $start || $port >= $start+$count} {
  388             set port $start
  389         }
  390         if {[catch {set fd1 [socket 127.0.0.1 $port]}] &&
  391             [catch {set fd2 [socket 127.0.0.1 [expr $port+10000]]}]} {
  392             set ::last_port_attempted $port
  393             return $port
  394         } else {
  395             catch {
  396                 close $fd1
  397                 close $fd2
  398             }
  399         }
  400         incr port
  401     }
  402     error "Can't find a non busy port in the $start-[expr {$start+$count-1}] range."
  403 }
  404 
  405 # Test if TERM looks like to support colors
  406 proc color_term {} {
  407     expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]}
  408 }
  409 
  410 proc colorstr {color str} {
  411     if {[color_term]} {
  412         set b 0
  413         if {[string range $color 0 4] eq {bold-}} {
  414             set b 1
  415             set color [string range $color 5 end]
  416         }
  417         switch $color {
  418             red {set colorcode {31}}
  419             green {set colorcode {32}}
  420             yellow {set colorcode {33}}
  421             blue {set colorcode {34}}
  422             magenta {set colorcode {35}}
  423             cyan {set colorcode {36}}
  424             white {set colorcode {37}}
  425             default {set colorcode {37}}
  426         }
  427         if {$colorcode ne {}} {
  428             return "\033\[$b;${colorcode};49m$str\033\[0m"
  429         }
  430     } else {
  431         return $str
  432     }
  433 }
  434 
  435 proc find_valgrind_errors {stderr} {
  436     set fd [open $stderr]
  437     set buf [read $fd]
  438     close $fd
  439 
  440     # Look for stack trace (" at 0x") and other errors (Invalid, Mismatched, etc).
  441     # Look for "Warnings", but not the "set address range perms". These don't indicate any real concern.
  442     # Look for the absense of a leak free summary (happens when redis isn't terminated properly).
  443     if {[regexp -- { at 0x} $buf] ||
  444         [regexp -- {^(?=.*Warning)(?:(?!set address range perms).)*$} $buf] ||
  445         [regexp -- {Invalid} $buf] ||
  446         [regexp -- {Mismatched} $buf] ||
  447         [regexp -- {uninitialized} $buf] ||
  448         [regexp -- {has a fishy} $buf] ||
  449         [regexp -- {overlap} $buf] ||
  450         (![regexp -- {definitely lost: 0 bytes} $buf] &&
  451          ![regexp -- {no leaks are possible} $buf])} {
  452         return $buf
  453     }
  454 
  455     return ""
  456 }
  457 
  458 # Execute a background process writing random data for the specified number
  459 # of seconds to the specified Redis instance.
  460 proc start_write_load {host port seconds} {
  461     set tclsh [info nameofexecutable]
  462     exec $tclsh tests/helpers/gen_write_load.tcl $host $port $seconds $::tls &
  463 }
  464 
  465 # Stop a process generating write load executed with start_write_load.
  466 proc stop_write_load {handle} {
  467     catch {exec /bin/kill -9 $handle}
  468 }
  469 
  470 proc K { x y } { set x } 
  471 
  472 # Shuffle a list. From Tcl wiki. Originally from Steve Cohen that improved
  473 # other versions. Code should be under public domain.
  474 proc lshuffle {list} {
  475     set n [llength $list]
  476     while {$n>0} {
  477         set j [expr {int(rand()*$n)}]
  478         lappend slist [lindex $list $j]
  479         incr n -1
  480         set temp [lindex $list $n]
  481         set list [lreplace [K $list [set list {}]] $j $j $temp]
  482     }
  483     return $slist
  484 }
  485 
  486 # Execute a background process writing complex data for the specified number
  487 # of ops to the specified Redis instance.
  488 proc start_bg_complex_data {host port db ops} {
  489     set tclsh [info nameofexecutable]
  490     exec $tclsh tests/helpers/bg_complex_data.tcl $host $port $db $ops $::tls &
  491 }
  492 
  493 # Stop a process generating write load executed with start_bg_complex_data.
  494 proc stop_bg_complex_data {handle} {
  495     catch {exec /bin/kill -9 $handle}
  496 }
  497 
  498 proc populate {num prefix size} {
  499     set rd [redis_deferring_client]
  500     for {set j 0} {$j < $num} {incr j} {
  501         $rd set $prefix$j [string repeat A $size]
  502     }
  503     for {set j 0} {$j < $num} {incr j} {
  504         $rd read
  505     }
  506     $rd close
  507 }
  508 
  509 proc get_child_pid {idx} {
  510     set pid [srv $idx pid]
  511     if {[string match {*Darwin*} [exec uname -a]]} {
  512         set fd [open "|pgrep -P $pid" "r"]
  513         set child_pid [string trim [lindex [split [read $fd] \n] 0]]
  514     } else {
  515         set fd [open "|ps --ppid $pid -o pid" "r"]
  516         set child_pid [string trim [lindex [split [read $fd] \n] 1]]
  517     }
  518     close $fd
  519 
  520     return $child_pid
  521 }