tests/support/test.tcl

   1 set ::num_tests 0
   2 set ::num_passed 0
   3 set ::num_failed 0
   4 set ::tests_failed {}
   5
   6 proc assert {condition} {
   7     if {![uplevel 1 expr $condition]} {
   8         error "assertion:Expected '$value' to be true"
   9     }
  10 }
  11
  12 proc assert_match {pattern value} {
  13     if {![string match $pattern $value]} {
  14         error "assertion:Expected '$value' to match '$pattern'"
  15     }
  16 }
  17
  18 proc assert_equal {expected value} {
  19     if {$expected ne $value} {
  20         error "assertion:Expected '$value' to be equal to '$expected'"
  21     }
  22 }
  23
  24 proc assert_error {pattern code} {
  25     if {[catch {uplevel 1 $code} error]} {
  26         assert_match $pattern $error
  27     } else {
  28         error "assertion:Expected an error but nothing was catched"
  29     }
  30 }
  31
  32 proc assert_encoding {enc key} {
  33     # Swapped out values don't have an encoding, so make sure that
  34     # the value is swapped in before checking the encoding.
  35     set dbg [r debug object $key]
  36     while {[string match "* swapped at:*" $dbg]} {
  37         r debug swapin $key
  38         set dbg [r debug object $key]
  39     }
  40     assert_match "* encoding:$enc *" $dbg
  41 }
  42
  43 proc assert_type {type key} {
  44     assert_equal $type [r type $key]
  45 }
  46
  47 proc colored_dot {tags passed} {
  48     if {[info exists ::env(TERM)] && [string match $::env(TERM) xterm]} {
  49         if {[lsearch $tags list] != -1} {
  50             set colorcode {31}
  51             set ch L
  52         } elseif {[lsearch $tags hash] != -1} {
  53             set colorcode {32}
  54             set ch H
  55         } elseif {[lsearch $tags set] != -1} {
  56             set colorcode {33}
  57             set ch S
  58         } elseif {[lsearch $tags zset] != -1} {
  59             set colorcode {34}
  60             set ch Z
  61         } elseif {[lsearch $tags basic] != -1} {
  62             set colorcode {35}
  63             set ch B
  64         } else {
  65             set colorcode {37}
  66             set ch .
  67         }
  68         if {$colorcode ne {}} {
  69             if {$passed} {
  70                 puts -nonewline "\033\[0;${colorcode};40m"
  71             } else {
  72                 puts -nonewline "\033\[0;40;${colorcode}m"
  73             }
  74             puts -nonewline $ch
  75             puts -nonewline "\033\[0m"
  76             flush stdout
  77         }
  78     } else {
  79         if {$passed} {
  80             puts -nonewline .
  81         } else {
  82             puts -nonewline F
  83         }
  84     }
  85 }
  86
  87 proc test {name code {okpattern undefined}} {
  88     # abort if tagged with a tag to deny
  89     foreach tag $::denytags {
  90         if {[lsearch $::tags $tag] >= 0} {
  91             return
  92         }
  93     }
  94
  95     # check if tagged with at least 1 tag to allow when there *is* a list
  96     # of tags to allow, because default policy is to run everything
  97     if {[llength $::allowtags] > 0} {
  98         set matched 0
  99         foreach tag $::allowtags {
 100             if {[lsearch $::tags $tag] >= 0} {
 101                 incr matched
 102             }
 103         }
 104         if {$matched < 1} {
 105             return
 106         }
 107     }
 108
 109     incr ::num_tests
 110     set details {}
 111     lappend details $::curfile
 112     lappend details $::tags
 113     lappend details $name
 114
 115     if {$::verbose} {
 116         puts -nonewline [format "#%03d %-68s " $::num_tests $name]
 117         flush stdout
 118     }
 119
 120     if {[catch {set retval [uplevel 1 $code]} error]} {
 121         if {[string match "assertion:*" $error]} {
 122             set msg [string range $error 10 end]
 123             lappend details $msg
 124             lappend ::tests_failed $details
 125
 126             incr ::num_failed
 127             if {$::verbose} {
 128                 puts "FAILED"
 129                 puts "$msg\n"
 130             } else {
 131                 colored_dot $::tags 0
 132             }
 133         } else {
 134             # Re-raise, let handler up the stack take care of this.
 135             error $error $::errorInfo
 136         }
 137     } else {
 138         if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
 139             incr ::num_passed
 140             if {$::verbose} {
 141                 puts "PASSED"
 142             } else {
 143                 colored_dot $::tags 1
 144             }
 145         } else {
 146             set msg "Expected '$okpattern' to equal or match '$retval'"
 147             lappend details $msg
 148             lappend ::tests_failed $details
 149
 150             incr ::num_failed
 151             if {$::verbose} {
 152                 puts "FAILED"
 153                 puts "$msg\n"
 154             } else {
 155                 colored_dot $::tags 0
 156             }
 157         }
 158     }
 159     flush stdout
 160
 161     if {$::traceleaks} {
 162         set output [exec leaks redis-server]
 163         if {![string match {*0 leaks*} $output]} {
 164             puts "--- Test \"$name\" leaked! ---"
 165             puts $output
 166             exit 1
 167         }
 168     }
 169 }