X-Git-Url: https://git.saurik.com/redis.git/blobdiff_plain/ab72b4833d2054231437acccec36f32f07290075..afbf59145aa50d50631c860b73374a0438708b1f:/tests/support/test.tcl

diff --git a/tests/support/test.tcl b/tests/support/test.tcl
index c695c82f..d2674da1 100644
--- a/tests/support/test.tcl
+++ b/tests/support/test.tcl
@@ -3,11 +3,35 @@ set ::failed 0
 set ::testnum 0
 
 proc test {name code okpattern} {
+    # 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
-    # if {$::testnum < $::first || $::testnum > $::last} return
     puts -nonewline [format "#%03d %-68s " $::testnum $name]
     flush stdout
-    set retval [uplevel 1 $code]
+    if {[catch {set retval [uplevel 1 $code]} error]} {
+        puts "EXCEPTION"
+        puts "\nCaught error: $error"
+        error "exception"
+    }
     if {$okpattern eq $retval || [string match $okpattern $retval]} {
         puts "PASSED"
         incr ::passed