tests/test_helper.tcl

   1 # Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com
   2 # This softare is released under the BSD License. See the COPYING file for
   3 # more information.
   4
   5 set tcl_precision 17
   6 source tests/support/redis.tcl
   7 source tests/support/server.tcl
   8 source tests/support/tmpfile.tcl
   9 source tests/support/test.tcl
  10 source tests/support/util.tcl
  11
  12 set ::host 127.0.0.1
  13 set ::port 16379
  14 set ::traceleaks 0
  15 set ::valgrind 0
  16 set ::verbose 0
  17 set ::denytags {}
  18 set ::allowtags {}
  19 set ::external 0; # If "1" this means, we are running against external instance
  20 set ::file ""; # If set, runs only the tests in this comma separated list
  21 set ::curfile ""; # Hold the filename of the current suite
  22
  23 proc execute_tests name {
  24     set path "tests/$name.tcl"
  25     set ::curfile $path
  26     source $path
  27 }
  28
  29 # Setup a list to hold a stack of server configs. When calls to start_server
  30 # are nested, use "srv 0 pid" to get the pid of the inner server. To access
  31 # outer servers, use "srv -1 pid" etcetera.
  32 set ::servers {}
  33 proc srv {args} {
  34     set level 0
  35     if {[string is integer [lindex $args 0]]} {
  36         set level [lindex $args 0]
  37         set property [lindex $args 1]
  38     } else {
  39         set property [lindex $args 0]
  40     }
  41     set srv [lindex $::servers end+$level]
  42     dict get $srv $property
  43 }
  44
  45 # Provide easy access to the client for the inner server. It's possible to
  46 # prepend the argument list with a negative level to access clients for
  47 # servers running in outer blocks.
  48 proc r {args} {
  49     set level 0
  50     if {[string is integer [lindex $args 0]]} {
  51         set level [lindex $args 0]
  52         set args [lrange $args 1 end]
  53     }
  54     [srv $level "client"] {*}$args
  55 }
  56
  57 proc reconnect {args} {
  58     set level [lindex $args 0]
  59     if {[string length $level] == 0 || ![string is integer $level]} {
  60         set level 0
  61     }
  62
  63     set srv [lindex $::servers end+$level]
  64     set host [dict get $srv "host"]
  65     set port [dict get $srv "port"]
  66     set config [dict get $srv "config"]
  67     set client [redis $host $port]
  68     dict set srv "client" $client
  69
  70     # select the right db when we don't have to authenticate
  71     if {![dict exists $config "requirepass"]} {
  72         $client select 9
  73     }
  74
  75     # re-set $srv in the servers list
  76     set ::servers [lreplace $::servers end+$level 1 $srv]
  77 }
  78
  79 proc redis_deferring_client {args} {
  80     set level 0
  81     if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
  82         set level [lindex $args 0]
  83         set args [lrange $args 1 end]
  84     }
  85
  86     # create client that defers reading reply
  87     set client [redis [srv $level "host"] [srv $level "port"] 1]
  88
  89     # select the right db and read the response (OK)
  90     $client select 9
  91     $client read
  92     return $client
  93 }
  94
  95 # Provide easy access to INFO properties. Same semantic as "proc r".
  96 proc s {args} {
  97     set level 0
  98     if {[string is integer [lindex $args 0]]} {
  99         set level [lindex $args 0]
 100         set args [lrange $args 1 end]
 101     }
 102     status [srv $level "client"] [lindex $args 0]
 103 }
 104
 105 proc cleanup {} {
 106     catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
 107     catch {exec rm -rf {*}[glob tests/tmp/server.*]}
 108 }
 109
 110 proc execute_everything {} {
 111     execute_tests "unit/auth"
 112     execute_tests "unit/protocol"
 113     execute_tests "unit/basic"
 114     execute_tests "unit/type/list"
 115     execute_tests "unit/type/set"
 116     execute_tests "unit/type/zset"
 117     execute_tests "unit/type/hash"
 118     execute_tests "unit/sort"
 119     execute_tests "unit/expire"
 120     execute_tests "unit/other"
 121     execute_tests "unit/cas"
 122     execute_tests "unit/quit"
 123     execute_tests "integration/replication"
 124     execute_tests "integration/aof"
 125 #    execute_tests "integration/redis-cli"
 126     execute_tests "unit/pubsub"
 127
 128     # run tests with VM enabled
 129     set ::global_overrides {vm-enabled yes}
 130     execute_tests "unit/protocol"
 131     execute_tests "unit/basic"
 132     execute_tests "unit/type/list"
 133     execute_tests "unit/type/set"
 134     execute_tests "unit/type/zset"
 135     execute_tests "unit/type/hash"
 136     execute_tests "unit/sort"
 137     execute_tests "unit/expire"
 138     execute_tests "unit/other"
 139     execute_tests "unit/cas"
 140 }
 141
 142 proc main {} {
 143     cleanup
 144
 145     if {[string length $::file] > 0} {
 146         foreach {file} [split $::file ,] {
 147             execute_tests $file
 148         }
 149     } else {
 150         execute_everything
 151     }
 152
 153     cleanup
 154     puts "\n[expr $::num_tests] tests, $::num_passed passed, $::num_failed failed\n"
 155     if {$::num_failed > 0} {
 156         set curheader ""
 157         puts "Failures:"
 158         foreach {test} $::tests_failed {
 159             set header [lindex $test 0]
 160             append header " ("
 161             append header [join [lindex $test 1] ","]
 162             append header ")"
 163
 164             if {$curheader ne $header} {
 165                 set curheader $header
 166                 puts "\n$curheader:"
 167             }
 168
 169             set name [lindex $test 2]
 170             set msg [lindex $test 3]
 171             puts "- $name: $msg"
 172         }
 173
 174         puts ""
 175         exit 1
 176     }
 177 }
 178
 179 # parse arguments
 180 for {set j 0} {$j < [llength $argv]} {incr j} {
 181     set opt [lindex $argv $j]
 182     set arg [lindex $argv [expr $j+1]]
 183     if {$opt eq {--tags}} {
 184         foreach tag $arg {
 185             if {[string index $tag 0] eq "-"} {
 186                 lappend ::denytags [string range $tag 1 end]
 187             } else {
 188                 lappend ::allowtags $tag
 189             }
 190         }
 191         incr j
 192     } elseif {$opt eq {--valgrind}} {
 193         set ::valgrind 1
 194     } elseif {$opt eq {--file}} {
 195         set ::file $arg
 196         incr j
 197     } elseif {$opt eq {--host}} {
 198         set ::external 1
 199         set ::host $arg
 200         incr j
 201     } elseif {$opt eq {--port}} {
 202         set ::port $arg
 203         incr j
 204     } elseif {$opt eq {--verbose}} {
 205         set ::verbose 1
 206     } else {
 207         puts "Wrong argument: $opt"
 208         exit 1
 209     }
 210 }
 211
 212 if {[catch { main } err]} {
 213     if {[string length $err] > 0} {
 214         # only display error when not generated by the test suite
 215         if {$err ne "exception"} {
 216             puts $::errorInfo
 217         }
 218         exit 1
 219     }
 220 }