gitignore now includes a few more files

[redis.git] / tests / support / test.tcl

diff --git a/tests/support/test.tcl b/tests/support/test.tcl
index c695c82fa30cb4e1f232ba51b679ae5c6e153186..e801e1f228ea91946dd8d68ae4bfd722bcdcf52a 100644 (file)
--- a/tests/support/test.tcl
+++ b/tests/support/test.tcl
@@ -2,22 +2,98 @@ set ::passed 0
 set ::failed 0
 set ::testnum 0
 
 set ::failed 0
 set ::testnum 0
 

-proc test {name code okpattern} {
+proc assert {condition} {
+    if {![uplevel 1 expr $condition]} {
+        puts "!! ERROR\nExpected '$value' to evaluate to true"
+        error "assertion"
+    }
+}
+
+proc assert_match {pattern value} {
+    if {![string match $pattern $value]} {
+        puts "!! ERROR\nExpected '$value' to match '$pattern'"
+        error "assertion"
+    }
+}
+
+proc assert_equal {expected value} {
+    if {$expected ne $value} {
+        puts "!! ERROR\nExpected '$value' to be equal to '$expected'"
+        error "assertion"
+    }
+}
+
+proc assert_error {pattern code} {
+    if {[catch {uplevel 1 $code} error]} {
+        assert_match $pattern $error
+    } else {
+        puts "!! ERROR\nExpected an error but nothing was catched"
+        error "assertion"
+    }
+}
+
+proc assert_encoding {enc key} {
+    # Swapped out values don't have an encoding, so make sure that
+    # the value is swapped in before checking the encoding.
+    set dbg [r debug object $key]
+    while {[string match "* swapped at:*" $dbg]} {
+        r debug swapin $key
+        set dbg [r debug object $key]
+    }
+    assert_match "* encoding:$enc *" $dbg
+}
+
+proc assert_type {type key} {
+    assert_equal $type [r type $key]
+}
+
+proc test {name code {okpattern notspecified}} {
+    # abort if tagged with a tag to deny
+    foreach tag $::denytags {
+        if {[lsearch $::tags $tag] >= 0} {
+            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} {
+            return
+        }
+    }
+

     incr ::testnum
     incr ::testnum

-    # if {$::testnum < $::first || $::testnum > $::last} return

     puts -nonewline [format "#%03d %-68s " $::testnum $name]
     flush stdout
     puts -nonewline [format "#%03d %-68s " $::testnum $name]
     flush stdout

-    set retval [uplevel 1 $code]
-    if {$okpattern eq $retval || [string match $okpattern $retval]} {
-        puts "PASSED"
-        incr ::passed
+    if {[catch {set retval [uplevel 1 $code]} error]} {
+        if {$error eq "assertion"} {
+            incr ::failed
+        } else {
+            puts "EXCEPTION"
+            puts "\nCaught error: $error"
+            error "exception"
+        }

     } else {
     } else {

-        puts "!! ERROR expected\n'$okpattern'\nbut got\n'$retval'"
-        incr ::failed
+        if {$okpattern eq "notspecified" || $okpattern eq $retval || [string match $okpattern $retval]} {
+            puts "PASSED"
+            incr ::passed
+        } else {
+            puts "!! ERROR expected\n'$okpattern'\nbut got\n'$retval'"
+            incr ::failed
+        }

     }
     if {$::traceleaks} {
     }
     if {$::traceleaks} {

-        if {![string match {*0 leaks*} [exec leaks redis-server]]} {
+        set output [exec leaks redis-server]
+        if {![string match {*0 leaks*} $output]} {

             puts "--------- Test $::testnum LEAKED! --------"
             puts "--------- Test $::testnum LEAKED! --------"

+            puts $output

             exit 1
         }
     }
             exit 1
         }
     }