diff options
Diffstat (limited to 'examples/redis-unstable/tests/support/test.tcl')
| -rw-r--r-- | examples/redis-unstable/tests/support/test.tcl | 280 |
1 files changed, 0 insertions, 280 deletions
diff --git a/examples/redis-unstable/tests/support/test.tcl b/examples/redis-unstable/tests/support/test.tcl deleted file mode 100644 index 60fd0a9..0000000 --- a/examples/redis-unstable/tests/support/test.tcl +++ /dev/null @@ -1,280 +0,0 @@ -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} { - if {$_else_ ne "else"} { - error "$_else_ must be equal to \"else\"" - } - - 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 failed false - 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 - set failed true - 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 - set failed true - send_data_packet $::test_server_fd err [join $details "\n"] - } - } - - if {$::dump_logs && $failed} { - foreach srv $::servers { - dump_server_log $srv - } - } - - 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 -} |