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 after the test finished
  53 proc colored_dot {tags passed} {
  54     if {[color_term]} {
  55         # Go backward and delete what announc_test function printed.
  56         puts -nonewline "\033\[${::backward_count}D\033\[0K\033\[J"
  57
  58         # Print a coloured char, accordingly to test outcome and tags.
  59         if {[lsearch $tags list] != -1} {
  60             set colorcode {31}
  61             set ch L
  62         } elseif {[lsearch $tags hash] != -1} {
  63             set colorcode {32}
  64             set ch H
  65         } elseif {[lsearch $tags set] != -1} {
  66             set colorcode {33}
  67             set ch S
  68         } elseif {[lsearch $tags zset] != -1} {
  69             set colorcode {34}
  70             set ch Z
  71         } elseif {[lsearch $tags basic] != -1} {
  72             set colorcode {35}
  73             set ch B
  74         } else {
  75             set colorcode {37}
  76             set ch .
  77         }
  78         if {$colorcode ne {}} {
  79             if {$passed} {
  80                 puts -nonewline "\033\[0;${colorcode};40m"
  81             } else {
  82                 puts -nonewline "\033\[7;${colorcode};40m"
  83             }
  84             puts -nonewline $ch
  85             puts -nonewline "\033\[0m"
  86             flush stdout
  87         }
  88     } else {
  89         if {$passed} {
  90             puts -nonewline .
  91         } else {
  92             puts -nonewline F
  93         }
  94     }
  95 }
  96
  97 proc test {name code {okpattern undefined}} {
  98     # abort if tagged with a tag to deny
  99     foreach tag $::denytags {
 100         if {[lsearch $::tags $tag] >= 0} {
 101             return
 102         }
 103     }
 104
 105     # check if tagged with at least 1 tag to allow when there *is* a list
 106     # of tags to allow, because default policy is to run everything
 107     if {[llength $::allowtags] > 0} {
 108         set matched 0
 109         foreach tag $::allowtags {
 110             if {[lsearch $::tags $tag] >= 0} {
 111                 incr matched
 112             }
 113         }
 114         if {$matched < 1} {
 115             return
 116         }
 117     }
 118
 119     incr ::num_tests
 120     set details {}
 121     lappend details $::curfile
 122     lappend details $::tags
 123     lappend details $name
 124
 125     send_data_packet $::test_server_fd testing $name
 126
 127     if {[catch {set retval [uplevel 1 $code]} error]} {
 128         if {[string match "assertion:*" $error]} {
 129             set msg [string range $error 10 end]
 130             lappend details $msg
 131             lappend ::tests_failed $details
 132
 133             incr ::num_failed
 134             send_data_packet $::test_server_fd err $name
 135         } else {
 136             # Re-raise, let handler up the stack take care of this.
 137             error $error $::errorInfo
 138         }
 139     } else {
 140         if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
 141             incr ::num_passed
 142             send_data_packet $::test_server_fd ok $name
 143         } else {
 144             set msg "Expected '$okpattern' to equal or match '$retval'"
 145             lappend details $msg
 146             lappend ::tests_failed $details
 147
 148             incr ::num_failed
 149             send_data_packet $::test_server_fd err $name
 150         }
 151     }
 152
 153     if {$::traceleaks} {
 154         set output [exec leaks redis-server]
 155         if {![string match {*0 leaks*} $output]} {
 156             send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
 157         }
 158     }
 159 }