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