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 # Test if TERM looks like to support colors
  48 proc color_term {} {
  49     expr {[info exists ::env(TERM)] && [string match *xterm* $::env(TERM)]}
  50 }
  51
  52 # This is called before starting the test
  53 proc announce_test {s} {
  54     if {[color_term]} {
  55         puts -nonewline "$s\033\[0K"
  56         flush stdout
  57         set ::backward_count [string length $s]
  58     }
  59 }
  60
  61 # This is called after the test finished
  62 proc colored_dot {tags passed} {
  63     if {[color_term]} {
  64         # Go backward and delete what announc_test function printed.
  65         puts -nonewline "\033\[${::backward_count}D\033\[0K\033\[J"
  66
  67         # Print a coloured char, accordingly to test outcome and tags.
  68         if {[lsearch $tags list] != -1} {
  69             set colorcode {31}
  70             set ch L
  71         } elseif {[lsearch $tags hash] != -1} {
  72             set colorcode {32}
  73             set ch H
  74         } elseif {[lsearch $tags set] != -1} {
  75             set colorcode {33}
  76             set ch S
  77         } elseif {[lsearch $tags zset] != -1} {
  78             set colorcode {34}
  79             set ch Z
  80         } elseif {[lsearch $tags basic] != -1} {
  81             set colorcode {35}
  82             set ch B
  83         } else {
  84             set colorcode {37}
  85             set ch .
  86         }
  87         if {$colorcode ne {}} {
  88             if {$passed} {
  89                 puts -nonewline "\033\[0;${colorcode};40m"
  90             } else {
  91                 puts -nonewline "\033\[7;${colorcode};40m"
  92             }
  93             puts -nonewline $ch
  94             puts -nonewline "\033\[0m"
  95             flush stdout
  96         }
  97     } else {
  98         if {$passed} {
  99             puts -nonewline .
 100         } else {
 101             puts -nonewline F
 102         }
 103     }
 104 }
 105
 106 proc test {name code {okpattern undefined}} {
 107     # abort if tagged with a tag to deny
 108     foreach tag $::denytags {
 109         if {[lsearch $::tags $tag] >= 0} {
 110             return
 111         }
 112     }
 113
 114     # check if tagged with at least 1 tag to allow when there *is* a list
 115     # of tags to allow, because default policy is to run everything
 116     if {[llength $::allowtags] > 0} {
 117         set matched 0
 118         foreach tag $::allowtags {
 119             if {[lsearch $::tags $tag] >= 0} {
 120                 incr matched
 121             }
 122         }
 123         if {$matched < 1} {
 124             return
 125         }
 126     }
 127
 128     incr ::num_tests
 129     set details {}
 130     lappend details $::curfile
 131     lappend details $::tags
 132     lappend details $name
 133
 134     if {$::verbose} {
 135         puts -nonewline [format "#%03d %-68s " $::num_tests $name]
 136         flush stdout
 137     } else {
 138         announce_test $name
 139     }
 140
 141     if {[catch {set retval [uplevel 1 $code]} error]} {
 142         if {[string match "assertion:*" $error]} {
 143             set msg [string range $error 10 end]
 144             lappend details $msg
 145             lappend ::tests_failed $details
 146
 147             incr ::num_failed
 148             if {$::verbose} {
 149                 puts "FAILED"
 150                 puts "$msg\n"
 151             } else {
 152                 colored_dot $::tags 0
 153             }
 154         } else {
 155             # Re-raise, let handler up the stack take care of this.
 156             error $error $::errorInfo
 157         }
 158     } else {
 159         if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
 160             incr ::num_passed
 161             if {$::verbose} {
 162                 puts "PASSED"
 163             } else {
 164                 colored_dot $::tags 1
 165             }
 166         } else {
 167             set msg "Expected '$okpattern' to equal or match '$retval'"
 168             lappend details $msg
 169             lappend ::tests_failed $details
 170
 171             incr ::num_failed
 172             if {$::verbose} {
 173                 puts "FAILED"
 174                 puts "$msg\n"
 175             } else {
 176                 colored_dot $::tags 0
 177             }
 178         }
 179     }
 180     flush stdout
 181
 182     if {$::traceleaks} {
 183         set output [exec leaks redis-server]
 184         if {![string match {*0 leaks*} $output]} {
 185             puts "--- Test \"$name\" leaked! ---"
 186             puts $output
 187             exit 1
 188         }
 189     }
 190 }