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
+set ::diskstore 0; # Don't touch this by hand. The test itself will toggle it.
proc execute_tests name {
- set cur $::testnum
- source "tests/$name.tcl"
+ set path "tests/$name.tcl"
+ set ::curfile $path
+ source $path
}
-# setup a list to hold a stack of clients. the proc "r" provides easy
-# access to the client at the top of the stack
-set ::clients {}
+# 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 client [lindex $::clients end]
- $client {*}$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 main {} {
+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 {} {
+ puts "Cleanup: warning may take some time..."
+ catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
+ catch {exec rm -rf {*}[glob tests/tmp/server.*]}
+}
+
+proc execute_everything {} {
execute_tests "unit/auth"
execute_tests "unit/protocol"
execute_tests "unit/basic"
execute_tests "unit/sort"
execute_tests "unit/expire"
execute_tests "unit/other"
-
- puts "\n[expr $::passed+$::failed] tests, $::passed passed, $::failed failed"
- if {$::failed > 0} {
- puts "\n*** WARNING!!! $::failed FAILED TESTS ***\n"
+ 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 diskstore enabled
+ puts "\nRunning diskstore tests... this is slow, press Ctrl+C if not interested.."
+ set ::diskstore 1
+ lappend ::denytags nodiskstore
+ set ::global_overrides {diskstore-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
}
-
- # clean up tmp
- exec rm -rf {*}[glob tests/tmp/redis.conf.*]
- exec rm -rf {*}[glob tests/tmp/server.*]
}
-main
+# 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
+ }
+}
projects / redis.git / blobdiff