redis-server 0.0.1

data/redis/redis-2.2.11/tests/support/tmpfile.tcl

@@ -0,0 +1,15 @@
+set ::tmpcounter 0
+set ::tmproot "./tests/tmp"
+file mkdir $::tmproot
+
+# returns a dirname unique to this process to write to
+proc tmpdir {basename} {
+    set dir [file join $::tmproot $basename.[pid].[incr ::tmpcounter]]
+    file mkdir $dir
+    set _ $dir
+}
+
+# return a filename unique to this process to write to
+proc tmpfile {basename} {
+    file join $::tmproot $basename.[pid].[incr ::tmpcounter]
+}

data/redis/redis-2.2.11/tests/support/util.tcl

@@ -0,0 +1,296 @@
+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 result {}
+    foreach line $lines {
+        if {[regexp {^\[\d+\]\s+\d+\s+\w+\s+\d{2}:\d{2}:\d{2} \#} $line]} {
+            set matched 1
+        }
+        if {$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 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 bgrewriteaof_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 randomInt {max} {
+    expr {int(rand()*$max)}
+}
+
+proc randpath args {
+    set path [expr {int(rand()*[llength $args])}]
+    uplevel 1 [lindex $args $path]
+}
+
+proc randomValue {} {
+    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 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 {}
+    foreach k [lsort [{*}$r keys *]] {
+        set type [{*}$r type $k]
+        append o [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"
+            }
+        }
+    }
+    return $o
+}
+
+proc csvstring s {
+    return "\"$s\""
+}

data/redis/redis-2.2.11/tests/test_helper.tcl

@@ -0,0 +1,221 @@
+# Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com
+# This softare is released under the BSD License. See the COPYING file for
+# more information.
+
+set tcl_precision 17
+source tests/support/redis.tcl
+source tests/support/server.tcl
+source tests/support/tmpfile.tcl
+source tests/support/test.tcl
+source tests/support/util.tcl
+
+set ::host 127.0.0.1
+set ::port 16379
+set ::traceleaks 0
+set ::valgrind 0
+set ::verbose 0
+set ::denytags {}
+set ::allowtags {}
+set ::external 0; # If "1" this means, we are running against external instance
+set ::file ""; # If set, runs only the tests in this comma separated list
+set ::curfile ""; # Hold the filename of the current suite
+
+proc execute_tests name {
+    set path "tests/$name.tcl"
+    set ::curfile $path
+    source $path
+}
+
+# Setup a list to hold a stack of server configs. When calls to start_server
+# are nested, use "srv 0 pid" to get the pid of the inner server. To access
+# outer servers, use "srv -1 pid" etcetera.
+set ::servers {}
+proc srv {args} {
+    set level 0
+    if {[string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set property [lindex $args 1]
+    } else {
+        set property [lindex $args 0]
+    }
+    set srv [lindex $::servers end+$level]
+    dict get $srv $property
+}
+
+# Provide easy access to the client for the inner server. It's possible to
+# prepend the argument list with a negative level to access clients for
+# servers running in outer blocks.
+proc r {args} {
+    set level 0
+    if {[string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set args [lrange $args 1 end]
+    }
+    [srv $level "client"] {*}$args
+}
+
+proc reconnect {args} {
+    set level [lindex $args 0]
+    if {[string length $level] == 0 || ![string is integer $level]} {
+        set level 0
+    }
+
+    set srv [lindex $::servers end+$level]
+    set host [dict get $srv "host"]
+    set port [dict get $srv "port"]
+    set config [dict get $srv "config"]
+    set client [redis $host $port]
+    dict set srv "client" $client
+
+    # select the right db when we don't have to authenticate
+    if {![dict exists $config "requirepass"]} {
+        $client select 9
+    }
+
+    # re-set $srv in the servers list
+    set ::servers [lreplace $::servers end+$level 1 $srv]
+}
+
+proc redis_deferring_client {args} {
+    set level 0
+    if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set args [lrange $args 1 end]
+    }
+
+    # create client that defers reading reply
+    set client [redis [srv $level "host"] [srv $level "port"] 1]
+
+    # select the right db and read the response (OK)
+    $client select 9
+    $client read
+    return $client
+}
+
+# Provide easy access to INFO properties. Same semantic as "proc r".
+proc s {args} {
+    set level 0
+    if {[string is integer [lindex $args 0]]} {
+        set level [lindex $args 0]
+        set args [lrange $args 1 end]
+    }
+    status [srv $level "client"] [lindex $args 0]
+}
+
+proc cleanup {} {
+    catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
+    catch {exec rm -rf {*}[glob tests/tmp/server.*]}
+}
+
+proc execute_everything {} {
+    execute_tests "unit/printver"
+    execute_tests "unit/auth"
+    execute_tests "unit/protocol"
+    execute_tests "unit/basic"
+    execute_tests "unit/type/list"
+    execute_tests "unit/type/set"
+    execute_tests "unit/type/zset"
+    execute_tests "unit/type/hash"
+    execute_tests "unit/sort"
+    execute_tests "unit/expire"
+    execute_tests "unit/other"
+    execute_tests "unit/cas"
+    execute_tests "unit/quit"
+    execute_tests "integration/replication"
+    execute_tests "integration/aof"
+#    execute_tests "integration/redis-cli"
+    execute_tests "unit/pubsub"
+
+    # run tests with VM enabled
+    set ::global_overrides {vm-enabled yes}
+    execute_tests "unit/protocol"
+    execute_tests "unit/basic"
+    execute_tests "unit/type/list"
+    execute_tests "unit/type/set"
+    execute_tests "unit/type/zset"
+    execute_tests "unit/type/hash"
+    execute_tests "unit/sort"
+    execute_tests "unit/expire"
+    execute_tests "unit/other"
+    execute_tests "unit/cas"
+}
+
+proc main {} {
+    cleanup
+
+    if {[string length $::file] > 0} {
+        foreach {file} [split $::file ,] {
+            execute_tests $file
+        }
+    } else {
+        execute_everything
+    }
+
+    cleanup
+    puts "\n[expr $::num_tests] tests, $::num_passed passed, $::num_failed failed\n"
+    if {$::num_failed > 0} {
+        set curheader ""
+        puts "Failures:"
+        foreach {test} $::tests_failed {
+            set header [lindex $test 0]
+            append header " ("
+            append header [join [lindex $test 1] ","]
+            append header ")"
+
+            if {$curheader ne $header} {
+                set curheader $header
+                puts "\n$curheader:"
+            }
+
+            set name [lindex $test 2]
+            set msg [lindex $test 3]
+            puts "- $name: $msg"
+        }
+
+        puts ""
+        exit 1
+    }
+}
+
+# parse arguments
+for {set j 0} {$j < [llength $argv]} {incr j} {
+    set opt [lindex $argv $j]
+    set arg [lindex $argv [expr $j+1]]
+    if {$opt eq {--tags}} {
+        foreach tag $arg {
+            if {[string index $tag 0] eq "-"} {
+                lappend ::denytags [string range $tag 1 end]
+            } else {
+                lappend ::allowtags $tag
+            }
+        }
+        incr j
+    } elseif {$opt eq {--valgrind}} {
+        set ::valgrind 1
+    } elseif {$opt eq {--file}} {
+        set ::file $arg
+        incr j
+    } elseif {$opt eq {--host}} {
+        set ::external 1
+        set ::host $arg
+        incr j
+    } elseif {$opt eq {--port}} {
+        set ::port $arg
+        incr j
+    } elseif {$opt eq {--verbose}} {
+        set ::verbose 1
+    } else {
+        puts "Wrong argument: $opt"
+        exit 1
+    }
+}
+
+if {[catch { main } err]} {
+    if {[string length $err] > 0} {
+        # only display error when not generated by the test suite
+        if {$err ne "exception"} {
+            puts $::errorInfo
+        }
+        exit 1
+    }
+}