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