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