"Fossies" - the Fresh Open Source Software Archive

Member "redis-6.0.8/tests/support/test.tcl" (10 Sep 2020, 5937 Bytes) of package /linux/misc/redis-6.0.8.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "test.tcl": 6.0.7_vs_6.0.8.

    1 set ::num_tests 0
    2 set ::num_passed 0
    3 set ::num_failed 0
    4 set ::num_skipped 0
    5 set ::num_aborted 0
    6 set ::tests_failed {}
    7 set ::cur_test ""
    8 
    9 proc fail {msg} {
   10     error "assertion:$msg"
   11 }
   12 
   13 proc assert {condition} {
   14     if {![uplevel 1 [list expr $condition]]} {
   15         set context "(context: [info frame -1])"
   16         error "assertion:Expected [uplevel 1 [list subst -nocommands $condition]] $context"
   17     }
   18 }
   19 
   20 proc assert_no_match {pattern value} {
   21     if {[string match $pattern $value]} {
   22         set context "(context: [info frame -1])"
   23         error "assertion:Expected '$value' to not match '$pattern' $context"
   24     }
   25 }
   26 
   27 proc assert_match {pattern value} {
   28     if {![string match $pattern $value]} {
   29         set context "(context: [info frame -1])"
   30         error "assertion:Expected '$value' to match '$pattern' $context"
   31     }
   32 }
   33 
   34 proc assert_equal {value expected {detail ""}} {
   35     if {$expected ne $value} {
   36         if {$detail ne ""} {
   37             set detail "(detail: $detail)"
   38         } else {
   39             set detail "(context: [info frame -1])"
   40         }
   41         error "assertion:Expected '$value' to be equal to '$expected' $detail"
   42     }
   43 }
   44 
   45 proc assert_lessthan {value expected {detail ""}} {
   46     if {!($value < $expected)} {
   47         if {$detail ne ""} {
   48             set detail "(detail: $detail)"
   49         } else {
   50             set detail "(context: [info frame -1])"
   51         }
   52         error "assertion:Expected '$value' to be lessthan to '$expected' $detail"
   53     }
   54 }
   55 
   56 proc assert_range {value min max {detail ""}} {
   57     if {!($value <= $max && $value >= $min)} {
   58         if {$detail ne ""} {
   59             set detail "(detail: $detail)"
   60         } else {
   61             set detail "(context: [info frame -1])"
   62         }
   63         error "assertion:Expected '$value' to be between to '$min' and '$max' $detail"
   64     }
   65 }
   66 
   67 proc assert_error {pattern code} {
   68     if {[catch {uplevel 1 $code} error]} {
   69         assert_match $pattern $error
   70     } else {
   71         error "assertion:Expected an error but nothing was caught"
   72     }
   73 }
   74 
   75 proc assert_encoding {enc key} {
   76     set dbg [r debug object $key]
   77     assert_match "* encoding:$enc *" $dbg
   78 }
   79 
   80 proc assert_type {type key} {
   81     assert_equal $type [r type $key]
   82 }
   83 
   84 # Wait for the specified condition to be true, with the specified number of
   85 # max retries and delay between retries. Otherwise the 'elsescript' is
   86 # executed.
   87 proc wait_for_condition {maxtries delay e _else_ elsescript} {
   88     while {[incr maxtries -1] >= 0} {
   89         set errcode [catch {uplevel 1 [list expr $e]} result]
   90         if {$errcode == 0} {
   91             if {$result} break
   92         } else {
   93             return -code $errcode $result
   94         }
   95         after $delay
   96     }
   97     if {$maxtries == -1} {
   98         set errcode [catch [uplevel 1 $elsescript] result]
   99         return -code $errcode $result
  100     }
  101 }
  102 
  103 proc test {name code {okpattern undefined} {options undefined}} {
  104     # abort if test name in skiptests
  105     if {[lsearch $::skiptests $name] >= 0} {
  106         incr ::num_skipped
  107         send_data_packet $::test_server_fd skip $name
  108         return
  109     }
  110 
  111     # abort if test name in skiptests
  112     if {[llength $::only_tests] > 0 && [lsearch $::only_tests $name] < 0} {
  113         incr ::num_skipped
  114         send_data_packet $::test_server_fd skip $name
  115         return
  116     }
  117 
  118     # check if tagged with at least 1 tag to allow when there *is* a list
  119     # of tags to allow, because default policy is to run everything
  120     if {[llength $::allowtags] > 0} {
  121         set matched 0
  122         foreach tag $::allowtags {
  123             if {[lsearch $::tags $tag] >= 0} {
  124                 incr matched
  125             }
  126         }
  127         if {$matched < 1} {
  128             incr ::num_aborted
  129             send_data_packet $::test_server_fd ignore $name
  130             return
  131         }
  132     }
  133 
  134     incr ::num_tests
  135     set details {}
  136     lappend details "$name in $::curfile"
  137 
  138     # set a cur_test global to be logged into new servers that are spown
  139     # and log the test name in all existing servers
  140     set prev_test $::cur_test
  141     set ::cur_test "$name in $::curfile"
  142     if {!$::external} {
  143         foreach srv $::servers {
  144             set stdout [dict get $srv stdout]
  145             set fd [open $stdout "a+"]
  146             puts $fd "### Starting test $::cur_test"
  147             close $fd
  148         }
  149     }
  150 
  151     send_data_packet $::test_server_fd testing $name
  152 
  153     if {[catch {set retval [uplevel 1 $code]} error]} {
  154         set assertion [string match "assertion:*" $error]
  155         if {$assertion || $::durable} {
  156             set msg [string range $error 10 end]
  157             lappend details $msg
  158             if {!$assertion} {
  159                 lappend details $::errorInfo
  160             }
  161             lappend ::tests_failed $details
  162 
  163             incr ::num_failed
  164             send_data_packet $::test_server_fd err [join $details "\n"]
  165 
  166             if {$::stop_on_failure} {
  167                 puts "Test error (last server port:[srv port], log:[srv stdout]), press enter to teardown the test."
  168                 flush stdout
  169                 gets stdin
  170             }
  171         } else {
  172             # Re-raise, let handler up the stack take care of this.
  173             error $error $::errorInfo
  174         }
  175     } else {
  176         if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
  177             incr ::num_passed
  178             send_data_packet $::test_server_fd ok $name
  179         } else {
  180             set msg "Expected '$okpattern' to equal or match '$retval'"
  181             lappend details $msg
  182             lappend ::tests_failed $details
  183 
  184             incr ::num_failed
  185             send_data_packet $::test_server_fd err [join $details "\n"]
  186         }
  187     }
  188 
  189     if {$::traceleaks} {
  190         set output [exec leaks redis-server]
  191         if {![string match {*0 leaks*} $output]} {
  192             send_data_packet $::test_server_fd err "Detected a memory leak in test '$name': $output"
  193         }
  194     }
  195     set ::cur_test $prev_test
  196 }