mirror of
https://codeberg.org/redict/redict.git
synced 2025-01-23 00:28:26 -05:00
a0cfd519e3
sometimes we have several assertions with the same condition in the same test at different stages, and when these fail (the ones that print the condition text) you don't know which one it was. other assertions didn't print the condition text (variable names), just the expected and unexpected values. So now, all assertions print context line, and conditin text. besides, one of the major differences between 'assert' and 'assert_equal', is that the later is able to print the value that doesn't match the expected. if there is a rare non-reproducible failure, it is helpful to know what was the value the test encountered and how far it was from the threshold. So now, adding assert_lessthan and assert_range that can be used in some places. were we used just 'assert { a > b }' so far.
181 lines
5.2 KiB
Tcl
181 lines
5.2 KiB
Tcl
set ::num_tests 0
|
|
set ::num_passed 0
|
|
set ::num_failed 0
|
|
set ::num_skipped 0
|
|
set ::num_aborted 0
|
|
set ::tests_failed {}
|
|
|
|
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} {
|
|
if {![string match $pattern $value]} {
|
|
set context "(context: [info frame -1])"
|
|
error "assertion:Expected '$value' to match '$pattern' $context"
|
|
}
|
|
}
|
|
|
|
proc assert_equal {value expected {detail ""}} {
|
|
if {$expected ne $value} {
|
|
if {$detail ne ""} {
|
|
set detail "(detail: $detail)"
|
|
} else {
|
|
set detail "(context: [info frame -1])"
|
|
}
|
|
error "assertion:Expected '$value' to be equal to '$expected' $detail"
|
|
}
|
|
}
|
|
|
|
proc assert_lessthan {value expected {detail ""}} {
|
|
if {!($value < $expected)} {
|
|
if {$detail ne ""} {
|
|
set detail "(detail: $detail)"
|
|
} else {
|
|
set detail "(context: [info frame -1])"
|
|
}
|
|
error "assertion:Expected '$value' to be lessthan to '$expected' $detail"
|
|
}
|
|
}
|
|
|
|
proc assert_range {value min max {detail ""}} {
|
|
if {!($value <= $max && $value >= $min)} {
|
|
if {$detail ne ""} {
|
|
set detail "(detail: $detail)"
|
|
} else {
|
|
set detail "(context: [info frame -1])"
|
|
}
|
|
error "assertion:Expected '$value' to be between to '$min' and '$max' $detail"
|
|
}
|
|
}
|
|
|
|
proc assert_error {pattern code} {
|
|
if {[catch {uplevel 1 $code} error]} {
|
|
assert_match $pattern $error
|
|
} else {
|
|
error "assertion:Expected an error but nothing was caught"
|
|
}
|
|
}
|
|
|
|
proc assert_encoding {enc key} {
|
|
set dbg [r debug object $key]
|
|
assert_match "* encoding:$enc *" $dbg
|
|
}
|
|
|
|
proc assert_type {type key} {
|
|
assert_equal $type [r type $key]
|
|
}
|
|
|
|
# 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
|
|
}
|
|
}
|
|
|
|
proc test {name code {okpattern undefined}} {
|
|
# abort if tagged with a tag to deny
|
|
foreach tag $::denytags {
|
|
if {[lsearch $::tags $tag] >= 0} {
|
|
incr ::num_aborted
|
|
send_data_packet $::test_server_fd ignore $name
|
|
return
|
|
}
|
|
}
|
|
|
|
# abort if test name in skiptests
|
|
if {[lsearch $::skiptests $name] >= 0} {
|
|
incr ::num_skipped
|
|
send_data_packet $::test_server_fd skip $name
|
|
return
|
|
}
|
|
|
|
# abort if test name in skiptests
|
|
if {[llength $::only_tests] > 0 && [lsearch $::only_tests $name] < 0} {
|
|
incr ::num_skipped
|
|
send_data_packet $::test_server_fd skip $name
|
|
return
|
|
}
|
|
|
|
# check if tagged with at least 1 tag to allow when there *is* a list
|
|
# of tags to allow, because default policy is to run everything
|
|
if {[llength $::allowtags] > 0} {
|
|
set matched 0
|
|
foreach tag $::allowtags {
|
|
if {[lsearch $::tags $tag] >= 0} {
|
|
incr matched
|
|
}
|
|
}
|
|
if {$matched < 1} {
|
|
incr ::num_aborted
|
|
send_data_packet $::test_server_fd ignore $name
|
|
return
|
|
}
|
|
}
|
|
|
|
incr ::num_tests
|
|
set details {}
|
|
lappend details "$name in $::curfile"
|
|
|
|
send_data_packet $::test_server_fd testing $name
|
|
|
|
if {[catch {set retval [uplevel 1 $code]} error]} {
|
|
if {[string match "assertion:*" $error]} {
|
|
set msg [string range $error 10 end]
|
|
lappend details $msg
|
|
lappend ::tests_failed $details
|
|
|
|
incr ::num_failed
|
|
send_data_packet $::test_server_fd err [join $details "\n"]
|
|
} 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
|
|
send_data_packet $::test_server_fd ok $name
|
|
} 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"
|
|
}
|
|
}
|
|
}
|