tests/support/test.tcl

   1 set ::passed 0
   2 set ::failed 0
   3 set ::testnum 0
   4
   5 proc assert {condition} {
   6     if {![uplevel 1 expr $condition]} {
   7         puts "!! ERROR\nExpected '$value' to evaluate to true"
   8         error "assertion"
   9     }
  10 }
  11
  12 proc assert_match {pattern value} {
  13     if {![string match $pattern $value]} {
  14         puts "!! ERROR\nExpected '$value' to match '$pattern'"
  15         error "assertion"
  16     }
  17 }
  18
  19 proc assert_equal {expected value} {
  20     if {$expected ne $value} {
  21         puts "!! ERROR\nExpected '$value' to be equal to '$expected'"
  22         error "assertion"
  23     }
  24 }
  25
  26 proc assert_error {pattern code} {
  27     if {[catch {uplevel 1 $code} error]} {
  28         assert_match $pattern $error
  29     } else {
  30         puts "!! ERROR\nExpected an error but nothing was catched"
  31         error "assertion"
  32     }
  33 }
  34
  35 proc assert_encoding {enc key} {
  36     # Swapped out values don't have an encoding, so make sure that
  37     # the value is swapped in before checking the encoding.
  38     set dbg [r debug object $key]
  39     while {[string match "* swapped at:*" $dbg]} {
  40         r debug swapin $key
  41         set dbg [r debug object $key]
  42     }
  43     assert_match "* encoding:$enc *" $dbg
  44 }
  45
  46 proc assert_type {type key} {
  47     assert_equal $type [r type $key]
  48 }
  49
  50 proc test {name code {okpattern notspecified}} {
  51     # abort if tagged with a tag to deny
  52     foreach tag $::denytags {
  53         if {[lsearch $::tags $tag] >= 0} {
  54             return
  55         }
  56     }
  57
  58     # check if tagged with at least 1 tag to allow when there *is* a list
  59     # of tags to allow, because default policy is to run everything
  60     if {[llength $::allowtags] > 0} {
  61         set matched 0
  62         foreach tag $::allowtags {
  63             if {[lsearch $::tags $tag] >= 0} {
  64                 incr matched
  65             }
  66         }
  67         if {$matched < 1} {
  68             return
  69         }
  70     }
  71
  72     incr ::testnum
  73     puts -nonewline [format "#%03d %-68s " $::testnum $name]
  74     flush stdout
  75     if {[catch {set retval [uplevel 1 $code]} error]} {
  76         if {$error eq "assertion"} {
  77             incr ::failed
  78         } else {
  79             puts "EXCEPTION"
  80             puts "\nCaught error: $error"
  81             error "exception"
  82         }
  83     } else {
  84         if {$okpattern eq "notspecified" || $okpattern eq $retval || [string match $okpattern $retval]} {
  85             puts "PASSED"
  86             incr ::passed
  87         } else {
  88             puts "!! ERROR expected\n'$okpattern'\nbut got\n'$retval'"
  89             incr ::failed
  90         }
  91     }
  92     if {$::traceleaks} {
  93         if {![string match {*0 leaks*} [exec leaks redis-server]]} {
  94             puts "--------- Test $::testnum LEAKED! --------"
  95             exit 1
  96         }
  97     }
  98 }