summaryrefslogtreecommitdiffstats
path: root/tests/support/test.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tests/support/test.tcl')
-rw-r--r--tests/support/test.tcl267
1 files changed, 267 insertions, 0 deletions
diff --git a/tests/support/test.tcl b/tests/support/test.tcl
new file mode 100644
index 0000000..b7cd38b
--- /dev/null
+++ b/tests/support/test.tcl
@@ -0,0 +1,267 @@
+set ::num_tests 0
+set ::num_passed 0
+set ::num_failed 0
+set ::num_skipped 0
+set ::num_aborted 0
+set ::tests_failed {}
+set ::cur_test ""
+
+proc fail {msg} {
+ error "assertion:$msg"
+}
+
+proc assert {condition} {
+ if {![uplevel 1 [list expr $condition]]} {
+ set context "(context: [info frame -1])"
+ error "assertion:Expected [uplevel 1 [list subst -nocommands $condition]] $context"
+ }
+}
+
+proc assert_no_match {pattern value} {
+ if {[string match $pattern $value]} {
+ set context "(context: [info frame -1])"
+ error "assertion:Expected '$value' to not match '$pattern' $context"
+ }
+}
+
+proc assert_match {pattern value {detail ""} {context ""}} {
+ if {![string match $pattern $value]} {
+ if {$context eq ""} {
+ set context "(context: [info frame -1])"
+ }
+ error "assertion:Expected '$value' to match '$pattern' $context $detail"
+ }
+}
+
+proc assert_failed {expected_err detail} {
+ if {$detail ne ""} {
+ set detail "(detail: $detail)"
+ } else {
+ set detail "(context: [info frame -2])"
+ }
+ error "assertion:$expected_err $detail"
+}
+
+proc assert_not_equal {value expected {detail ""}} {
+ if {!($expected ne $value)} {
+ assert_failed "Expected '$value' not equal to '$expected'" $detail
+ }
+}
+
+proc assert_equal {value expected {detail ""}} {
+ if {$expected ne $value} {
+ assert_failed "Expected '$value' to be equal to '$expected'" $detail
+ }
+}
+
+proc assert_lessthan {value expected {detail ""}} {
+ if {!($value < $expected)} {
+ assert_failed "Expected '$value' to be less than '$expected'" $detail
+ }
+}
+
+proc assert_lessthan_equal {value expected {detail ""}} {
+ if {!($value <= $expected)} {
+ assert_failed "Expected '$value' to be less than or equal to '$expected'" $detail
+ }
+}
+
+proc assert_morethan {value expected {detail ""}} {
+ if {!($value > $expected)} {
+ assert_failed "Expected '$value' to be more than '$expected'" $detail
+ }
+}
+
+proc assert_morethan_equal {value expected {detail ""}} {
+ if {!($value >= $expected)} {
+ assert_failed "Expected '$value' to be more than or equal to '$expected'" $detail
+ }
+}
+
+proc assert_range {value min max {detail ""}} {
+ if {!($value <= $max && $value >= $min)} {
+ assert_failed "Expected '$value' to be between to '$min' and '$max'" $detail
+ }
+}
+
+proc assert_error {pattern code {detail ""}} {
+ if {[catch {uplevel 1 $code} error]} {
+ assert_match $pattern $error $detail
+ } else {
+ assert_failed "Expected an error matching '$pattern' but got '$error'" $detail
+ }
+}
+
+proc assert_encoding {enc key} {
+ if {$::ignoreencoding} {
+ return
+ }
+ set val [r object encoding $key]
+ assert_match $enc $val
+}
+
+proc assert_type {type key} {
+ assert_equal $type [r type $key]
+}
+
+proc assert_refcount {ref key} {
+ if {[lsearch $::denytags "needs:debug"] >= 0} {
+ return
+ }
+
+ set val [r object refcount $key]
+ assert_equal $ref $val
+}
+
+proc assert_refcount_morethan {key ref} {
+ if {[lsearch $::denytags "needs:debug"] >= 0} {
+ return
+ }
+
+ set val [r object refcount $key]
+ assert_morethan $val $ref
+}
+
+# Wait for the specified condition to be true, with the specified number of
+# max retries and delay between retries. Otherwise the 'elsescript' is
+# executed.
+proc wait_for_condition {maxtries delay e _else_ elsescript} {
+ while {[incr maxtries -1] >= 0} {
+ set errcode [catch {uplevel 1 [list expr $e]} result]
+ if {$errcode == 0} {
+ if {$result} break
+ } else {
+ return -code $errcode $result
+ }
+ after $delay
+ }
+ if {$maxtries == -1} {
+ set errcode [catch [uplevel 1 $elsescript] result]
+ return -code $errcode $result
+ }
+}
+
+# try to match a value to a list of patterns that are either regex (starts with "/") or plain string.
+# The caller can specify to use only glob-pattern match
+proc search_pattern_list {value pattern_list {glob_pattern false}} {
+ foreach el $pattern_list {
+ if {[string length $el] == 0} { continue }
+ if { $glob_pattern } {
+ if {[string match $el $value]} {
+ return 1
+ }
+ continue
+ }
+ if {[string equal / [string index $el 0]] && [regexp -- [string range $el 1 end] $value]} {
+ return 1
+ } elseif {[string equal $el $value]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+proc test {name code {okpattern undefined} {tags {}}} {
+ # abort if test name in skiptests
+ if {[search_pattern_list $name $::skiptests]} {
+ incr ::num_skipped
+ send_data_packet $::test_server_fd skip $name
+ return
+ }
+ if {$::verbose > 1} {
+ puts "starting test $name"
+ }
+ # abort if only_tests was set but test name is not included
+ if {[llength $::only_tests] > 0 && ![search_pattern_list $name $::only_tests]} {
+ incr ::num_skipped
+ send_data_packet $::test_server_fd skip $name
+ return
+ }
+
+ set tags [concat $::tags $tags]
+ if {![tags_acceptable $tags err]} {
+ incr ::num_aborted
+ send_data_packet $::test_server_fd ignore "$name: $err"
+ return
+ }
+
+ incr ::num_tests
+ set details {}
+ lappend details "$name in $::curfile"
+
+ # set a cur_test global to be logged into new servers that are spawn
+ # and log the test name in all existing servers
+ set prev_test $::cur_test
+ set ::cur_test "$name in $::curfile"
+ if {$::external} {
+ catch {
+ set r [redis [srv 0 host] [srv 0 port] 0 $::tls]
+ catch {
+ $r debug log "### Starting test $::cur_test"
+ }
+ $r close
+ }
+ } else {
+ set servers {}
+ foreach srv $::servers {
+ set stdout [dict get $srv stdout]
+ set fd [open $stdout "a+"]
+ puts $fd "### Starting test $::cur_test"
+ close $fd
+ lappend servers $stdout
+ }
+ if {$::verbose > 1} {
+ puts "### Starting test $::cur_test - with servers: $servers"
+ }
+ }
+
+ send_data_packet $::test_server_fd testing $name
+
+ set test_start_time [clock milliseconds]
+ if {[catch {set retval [uplevel 1 $code]} error]} {
+ set assertion [string match "assertion:*" $error]
+ if {$assertion || $::durable} {
+ # durable prevents the whole tcl test from exiting on an exception.
+ # an assertion is handled gracefully anyway.
+ set msg [string range $error 10 end]
+ lappend details $msg
+ if {!$assertion} {
+ lappend details $::errorInfo
+ }
+ lappend ::tests_failed $details
+
+ incr ::num_failed
+ send_data_packet $::test_server_fd err [join $details "\n"]
+
+ if {$::stop_on_failure} {
+ puts "Test error (last server port:[srv port], log:[srv stdout]), press enter to teardown the test."
+ flush stdout
+ gets stdin
+ }
+ } else {
+ # Re-raise, let handler up the stack take care of this.
+ error $error $::errorInfo
+ }
+ } else {
+ if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
+ incr ::num_passed
+ set elapsed [expr {[clock milliseconds]-$test_start_time}]
+ send_data_packet $::test_server_fd ok $name $elapsed
+ } else {
+ set msg "Expected '$okpattern' to equal or match '$retval'"
+ lappend details $msg
+ lappend ::tests_failed $details
+
+ incr ::num_failed
+ send_data_packet $::test_server_fd err [join $details "\n"]
+ }
+ }
+
+ if {$::traceleaks} {
+ set output [exec leaks redis-server]
+ if {![string match {*0 leaks*} $output]} {
+ send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
+ }
+ }
+ set ::cur_test $prev_test
+}