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