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 proc colorstr {color str} {
  53     if {[color_term]} {
  54         switch $color {
  55             red {set colorcode {31}}
  56             green {set colorcode {32}}
  57             yellow {set colorcode {33}}
  58             blue {set colorcode {34}}
  59             magenta {set colorcode {35}}
  60             cyan {set colorcode {36}}
  61             else {set colorcode {37}}
  62         }
  63         if {$colorcode ne {}} {
  64             return "\033\[0;${colorcode};40m$str\033\[0m"
  65         }
  66     } else {
  67         return $str
  68     }
  69 }
  70
  71 proc test {name code {okpattern undefined}} {
  72     # abort if tagged with a tag to deny
  73     foreach tag $::denytags {
  74         if {[lsearch $::tags $tag] >= 0} {
  75             return
  76         }
  77     }
  78
  79     # check if tagged with at least 1 tag to allow when there *is* a list
  80     # of tags to allow, because default policy is to run everything
  81     if {[llength $::allowtags] > 0} {
  82         set matched 0
  83         foreach tag $::allowtags {
  84             if {[lsearch $::tags $tag] >= 0} {
  85                 incr matched
  86             }
  87         }
  88         if {$matched < 1} {
  89             return
  90         }
  91     }
  92
  93     incr ::num_tests
  94     set details {}
  95     lappend details $::curfile
  96     lappend details $::tags
  97     lappend details $name
  98
  99     send_data_packet $::test_server_fd testing $name
 100
 101     if {[catch {set retval [uplevel 1 $code]} error]} {
 102         if {[string match "assertion:*" $error]} {
 103             set msg [string range $error 10 end]
 104             lappend details $msg
 105             lappend ::tests_failed $details
 106
 107             incr ::num_failed
 108             send_data_packet $::test_server_fd err $name
 109         } else {
 110             # Re-raise, let handler up the stack take care of this.
 111             error $error $::errorInfo
 112         }
 113     } else {
 114         if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
 115             incr ::num_passed
 116             send_data_packet $::test_server_fd ok $name
 117         } else {
 118             set msg "Expected '$okpattern' to equal or match '$retval'"
 119             lappend details $msg
 120             lappend ::tests_failed $details
 121
 122             incr ::num_failed
 123             send_data_packet $::test_server_fd err $name
 124         }
 125     }
 126
 127     if {$::traceleaks} {
 128         set output [exec leaks redis-server]
 129         if {![string match {*0 leaks*} $output]} {
 130             send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
 131         }
 132     }
 133 }