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