tests/support/test.tcl

   1 set ::passed 0
   2 set ::failed 0
   3 set ::testnum 0
   4
   5 proc test {name code okpattern} {
   6     # abort if tagged with a tag to deny
   7     foreach tag $::denytags {
   8         if {[lsearch $::tags $tag] >= 0} {
   9             return
  10         }
  11     }
  12
  13     # check if tagged with at least 1 tag to allow when there *is* a list
  14     # of tags to allow, because default policy is to run everything
  15     if {[llength $::allowtags] > 0} {
  16         set matched 0
  17         foreach tag $::allowtags {
  18             if {[lsearch $::tags $tag] >= 0} {
  19                 incr matched
  20             }
  21         }
  22         if {$matched < 1} {
  23             return
  24         }
  25     }
  26
  27     incr ::testnum
  28     puts -nonewline [format "#%03d %-68s " $::testnum $name]
  29     flush stdout
  30     if {[catch {set retval [uplevel 1 $code]} error]} {
  31         puts "EXCEPTION"
  32         puts "\nCaught error: $error"
  33         error "exception"
  34     }
  35     if {$okpattern eq $retval || [string match $okpattern $retval]} {
  36         puts "PASSED"
  37         incr ::passed
  38     } else {
  39         puts "!! ERROR expected\n'$okpattern'\nbut got\n'$retval'"
  40         incr ::failed
  41     }
  42     if {$::traceleaks} {
  43         if {![string match {*0 leaks*} [exec leaks redis-server]]} {
  44             puts "--------- Test $::testnum LEAKED! --------"
  45             exit 1
  46         }
  47     }
  48 }