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 ::all_tests {
  13     unit/printver
  14     unit/auth
  15     unit/protocol
  16     unit/basic
  17     unit/type/list
  18     unit/type/set
  19     unit/type/zset
  20     unit/type/hash
  21     unit/sort
  22     unit/expire
  23     unit/other
  24     unit/cas
  25     unit/quit
  26     integration/replication
  27     integration/aof
  28     unit/pubsub
  29     unit/slowlog
  30 }
  31 # Index to the next test to run in the ::all_tests list.
  32 set ::next_test 0
  33
  34 set ::host 127.0.0.1
  35 set ::port 16379
  36 set ::traceleaks 0
  37 set ::valgrind 0
  38 set ::verbose 0
  39 set ::denytags {}
  40 set ::allowtags {}
  41 set ::external 0; # If "1" this means, we are running against external instance
  42 set ::file ""; # If set, runs only the tests in this comma separated list
  43 set ::curfile ""; # Hold the filename of the current suite
  44
  45 # Set to 1 when we are running in client mode. The Redis test uses a
  46 # server-client model to run tests simultaneously. The server instance
  47 # runs the specified number of client instances that will actually run tests.
  48 # The server is responsible of showing the result to the user, and exit with
  49 # the appropriate exit code depending on the test outcome.
  50 set ::client 0
  51 set ::numclients 16
  52
  53 proc execute_tests name {
  54     set path "tests/$name.tcl"
  55     set ::curfile $path
  56     source $path
  57     send_data_packet $::test_server_fd done "$name"
  58 }
  59
  60 # Setup a list to hold a stack of server configs. When calls to start_server
  61 # are nested, use "srv 0 pid" to get the pid of the inner server. To access
  62 # outer servers, use "srv -1 pid" etcetera.
  63 set ::servers {}
  64 proc srv {args} {
  65     set level 0
  66     if {[string is integer [lindex $args 0]]} {
  67         set level [lindex $args 0]
  68         set property [lindex $args 1]
  69     } else {
  70         set property [lindex $args 0]
  71     }
  72     set srv [lindex $::servers end+$level]
  73     dict get $srv $property
  74 }
  75
  76 # Provide easy access to the client for the inner server. It's possible to
  77 # prepend the argument list with a negative level to access clients for
  78 # servers running in outer blocks.
  79 proc r {args} {
  80     set level 0
  81     if {[string is integer [lindex $args 0]]} {
  82         set level [lindex $args 0]
  83         set args [lrange $args 1 end]
  84     }
  85     [srv $level "client"] {*}$args
  86 }
  87
  88 proc reconnect {args} {
  89     set level [lindex $args 0]
  90     if {[string length $level] == 0 || ![string is integer $level]} {
  91         set level 0
  92     }
  93
  94     set srv [lindex $::servers end+$level]
  95     set host [dict get $srv "host"]
  96     set port [dict get $srv "port"]
  97     set config [dict get $srv "config"]
  98     set client [redis $host $port]
  99     dict set srv "client" $client
 100
 101     # select the right db when we don't have to authenticate
 102     if {![dict exists $config "requirepass"]} {
 103         $client select 9
 104     }
 105
 106     # re-set $srv in the servers list
 107     set ::servers [lreplace $::servers end+$level 1 $srv]
 108 }
 109
 110 proc redis_deferring_client {args} {
 111     set level 0
 112     if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
 113         set level [lindex $args 0]
 114         set args [lrange $args 1 end]
 115     }
 116
 117     # create client that defers reading reply
 118     set client [redis [srv $level "host"] [srv $level "port"] 1]
 119
 120     # select the right db and read the response (OK)
 121     $client select 9
 122     $client read
 123     return $client
 124 }
 125
 126 # Provide easy access to INFO properties. Same semantic as "proc r".
 127 proc s {args} {
 128     set level 0
 129     if {[string is integer [lindex $args 0]]} {
 130         set level [lindex $args 0]
 131         set args [lrange $args 1 end]
 132     }
 133     status [srv $level "client"] [lindex $args 0]
 134 }
 135
 136 proc cleanup {} {
 137     puts -nonewline "Cleanup: warning may take some time... "
 138     flush stdout
 139     catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
 140     catch {exec rm -rf {*}[glob tests/tmp/server.*]}
 141     puts "OK"
 142 }
 143
 144 proc test_server_main {} {
 145     cleanup
 146     # Open a listening socket, trying different ports in order to find a
 147     # non busy one.
 148     set port 11111
 149     while 1 {
 150         puts "Starting test server at port $port"
 151         if {[catch {socket -server accept_test_clients $port} e]} {
 152             if {[string match {*address already in use*} $e]} {
 153                 if {$port == 20000} {
 154                     puts "Can't find an available TCP port for test server."
 155                     exit 1
 156                 } else {
 157                     incr port
 158                 }
 159             } else {
 160                 puts "Fatal error starting test server: $e"
 161                 exit 1
 162             }
 163         } else {
 164             break
 165         }
 166     }
 167
 168     # Start the client instances
 169     for {set j 0} {$j < $::numclients} {incr j} {
 170         exec tclsh8.5 [info script] {*}$::argv \
 171             --client $port --port [expr {$::port+($j*10)}] &
 172     }
 173
 174     # Setup global state for the test server
 175     set ::idle_clients {}
 176     set ::active_clients {}
 177     array set ::clients_start_time {}
 178     set ::clients_time_history {}
 179
 180     # Enter the event loop to handle clients I/O
 181     after 100 test_server_cron
 182     vwait forever
 183 }
 184
 185 # This function gets called 10 times per second, for now does nothing but
 186 # may be used in the future in order to detect test clients taking too much
 187 # time to execute the task.
 188 proc test_server_cron {} {
 189 }
 190
 191 proc accept_test_clients {fd addr port} {
 192     fileevent $fd readable [list read_from_test_client $fd]
 193 }
 194
 195 # This is the readable handler of our test server. Clients send us messages
 196 # in the form of a status code such and additional data. Supported
 197 # status types are:
 198 #
 199 # ready: the client is ready to execute the command. Only sent at client
 200 #        startup. The server will queue the client FD in the list of idle
 201 #        clients.
 202 # testing: just used to signal that a given test started.
 203 # ok: a test was executed with success.
 204 # err: a test was executed with an error.
 205 # exception: there was a runtime exception while executing the test.
 206 # done: all the specified test file was processed, this test client is
 207 #       ready to accept a new task.
 208 proc read_from_test_client fd {
 209     set bytes [gets $fd]
 210     set payload [read $fd $bytes]
 211     foreach {status data} $payload break
 212     if {$status eq {ready}} {
 213         puts "($fd) \[$status\]: $data"
 214         signal_idle_client $fd
 215     } elseif {$status eq {done}} {
 216         set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}]
 217         puts "($fd) \[[colorstr yellow $status]\]: $data ($elapsed seconds)"
 218         puts "+++ [llength $::active_clients] units still in execution."
 219         lappend ::clients_time_history $elapsed $data
 220         signal_idle_client $fd
 221     } elseif {$status eq {ok}} {
 222         puts "($fd) \[[colorstr green $status]\]: $data"
 223     } elseif {$status eq {err}} {
 224         puts "($fd) \[[colorstr red $status]\]: $data"
 225     } else {
 226         puts "($fd) \[$status\]: $data"
 227     }
 228 }
 229
 230 # A new client is idle. Remove it from the list of active clients and
 231 # if there are still test units to run, launch them.
 232 proc signal_idle_client fd {
 233     # Remove this fd from the list of active clients.
 234     set ::active_clients \
 235         [lsearch -all -inline -not -exact $::active_clients $fd]
 236     # New unit to process?
 237     if {$::next_test != [llength $::all_tests]} {
 238         puts "Spawing new test process for: [lindex $::all_tests $::next_test]"
 239         set ::clients_start_time($fd) [clock seconds]
 240         send_data_packet $fd run [lindex $::all_tests $::next_test]
 241         lappend ::active_clients $fd
 242         incr ::next_test
 243     } else {
 244         lappend ::idle_clients $fd
 245         if {[llength $::active_clients] == 0} {
 246             the_end
 247         }
 248     }
 249 }
 250
 251 # The the_end funciton gets called when all the test units were already
 252 # executed, so the test finished.
 253 proc the_end {} {
 254     # TODO: print the status, exit with the rigth exit code.
 255     puts "The End\n"
 256     puts "Execution time of different units:"
 257     foreach {time name} $::clients_time_history {
 258         puts "  $time seconds - $name"
 259     }
 260     exit 1
 261 }
 262
 263 # The client is not even driven (the test server is instead) as we just need
 264 # to read the command, execute, reply... all this in a loop.
 265 proc test_client_main server_port {
 266     set ::test_server_fd [socket localhost $server_port]
 267     send_data_packet $::test_server_fd ready [pid]
 268     while 1 {
 269         set bytes [gets $::test_server_fd]
 270         set payload [read $::test_server_fd $bytes]
 271         foreach {cmd data} $payload break
 272         if {$cmd eq {run}} {
 273             execute_tests $data
 274         } else {
 275             error "Unknown test client command: $cmd"
 276         }
 277     }
 278 }
 279
 280 proc send_data_packet {fd status data} {
 281     set payload [list $status $data]
 282     puts $fd [string length $payload]
 283     puts -nonewline $fd $payload
 284     flush $fd
 285 }
 286
 287 # parse arguments
 288 for {set j 0} {$j < [llength $argv]} {incr j} {
 289     set opt [lindex $argv $j]
 290     set arg [lindex $argv [expr $j+1]]
 291     if {$opt eq {--tags}} {
 292         foreach tag $arg {
 293             if {[string index $tag 0] eq "-"} {
 294                 lappend ::denytags [string range $tag 1 end]
 295             } else {
 296                 lappend ::allowtags $tag
 297             }
 298         }
 299         incr j
 300     } elseif {$opt eq {--valgrind}} {
 301         set ::valgrind 1
 302     } elseif {$opt eq {--file}} {
 303         set ::file $arg
 304         incr j
 305     } elseif {$opt eq {--host}} {
 306         set ::external 1
 307         set ::host $arg
 308         incr j
 309     } elseif {$opt eq {--port}} {
 310         set ::port $arg
 311         incr j
 312     } elseif {$opt eq {--verbose}} {
 313         set ::verbose 1
 314     } elseif {$opt eq {--client}} {
 315         set ::client 1
 316         set ::test_server_port $arg
 317         incr j
 318     } else {
 319         puts "Wrong argument: $opt"
 320         exit 1
 321     }
 322 }
 323
 324 if {$::client} {
 325     if {[catch { test_client_main $::test_server_port } err]} {
 326         set estr "Executing test client: $err.\n$::errorInfo"
 327         if {[catch {send_data_packet $::test_server_fd exception $estr}]} {
 328             puts $estr
 329         }
 330         exit 1
 331     }
 332 } else {
 333     if {[catch { test_server_main } err]} {
 334         if {[string length $err] > 0} {
 335             # only display error when not generated by the test suite
 336             if {$err ne "exception"} {
 337                 puts $::errorInfo
 338             }
 339             exit 1
 340         }
 341     }
 342 }