Back to home page

Redis cross reference

 
 

    


0001 # Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com
0002 # This softare is released under the BSD License. See the COPYING file for
0003 # more information.
0004 
0005 package require Tcl 8.5
0006 
0007 set tcl_precision 17
0008 source tests/support/redis.tcl
0009 source tests/support/server.tcl
0010 source tests/support/tmpfile.tcl
0011 source tests/support/test.tcl
0012 source tests/support/util.tcl
0013 
0014 set ::all_tests {
0015     unit/printver
0016     unit/auth
0017     unit/protocol
0018     unit/basic
0019     unit/type/list
0020     unit/type/list-2
0021     unit/type/list-3
0022     unit/type/set
0023     unit/type/zset
0024     unit/type/hash
0025     unit/sort
0026     unit/expire
0027     unit/other
0028     unit/multi
0029     unit/quit
0030     unit/aofrw
0031     integration/replication
0032     integration/replication-2
0033     integration/replication-3
0034     integration/replication-4
0035     integration/aof
0036     integration/rdb
0037     integration/convert-zipmap-hash-on-load
0038     unit/pubsub
0039     unit/slowlog
0040     unit/scripting
0041     unit/maxmemory
0042     unit/introspection
0043     unit/limits
0044     unit/obuf-limits
0045     unit/dump
0046     unit/bitops
0047 }
0048 # Index to the next test to run in the ::all_tests list.
0049 set ::next_test 0
0050 
0051 set ::host 127.0.0.1
0052 set ::port 21111
0053 set ::traceleaks 0
0054 set ::valgrind 0
0055 set ::verbose 0
0056 set ::quiet 0
0057 set ::denytags {}
0058 set ::allowtags {}
0059 set ::external 0; # If "1" this means, we are running against external instance
0060 set ::file ""; # If set, runs only the tests in this comma separated list
0061 set ::curfile ""; # Hold the filename of the current suite
0062 set ::accurate 0; # If true runs fuzz tests with more iterations
0063 set ::force_failure 0
0064 
0065 # Set to 1 when we are running in client mode. The Redis test uses a
0066 # server-client model to run tests simultaneously. The server instance
0067 # runs the specified number of client instances that will actually run tests.
0068 # The server is responsible of showing the result to the user, and exit with
0069 # the appropriate exit code depending on the test outcome.
0070 set ::client 0
0071 set ::numclients 16
0072 
0073 proc execute_tests name {
0074     set path "tests/$name.tcl"
0075     set ::curfile $path
0076     source $path
0077     send_data_packet $::test_server_fd done "$name"
0078 }
0079 
0080 # Setup a list to hold a stack of server configs. When calls to start_server
0081 # are nested, use "srv 0 pid" to get the pid of the inner server. To access
0082 # outer servers, use "srv -1 pid" etcetera.
0083 set ::servers {}
0084 proc srv {args} {
0085     set level 0
0086     if {[string is integer [lindex $args 0]]} {
0087         set level [lindex $args 0]
0088         set property [lindex $args 1]
0089     } else {
0090         set property [lindex $args 0]
0091     }
0092     set srv [lindex $::servers end+$level]
0093     dict get $srv $property
0094 }
0095 
0096 # Provide easy access to the client for the inner server. It's possible to
0097 # prepend the argument list with a negative level to access clients for
0098 # servers running in outer blocks.
0099 proc r {args} {
0100     set level 0
0101     if {[string is integer [lindex $args 0]]} {
0102         set level [lindex $args 0]
0103         set args [lrange $args 1 end]
0104     }
0105     [srv $level "client"] {*}$args
0106 }
0107 
0108 proc reconnect {args} {
0109     set level [lindex $args 0]
0110     if {[string length $level] == 0 || ![string is integer $level]} {
0111         set level 0
0112     }
0113 
0114     set srv [lindex $::servers end+$level]
0115     set host [dict get $srv "host"]
0116     set port [dict get $srv "port"]
0117     set config [dict get $srv "config"]
0118     set client [redis $host $port]
0119     dict set srv "client" $client
0120 
0121     # select the right db when we don't have to authenticate
0122     if {![dict exists $config "requirepass"]} {
0123         $client select 9
0124     }
0125 
0126     # re-set $srv in the servers list
0127     lset ::servers end+$level $srv
0128 }
0129 
0130 proc redis_deferring_client {args} {
0131     set level 0
0132     if {[llength $args] > 0 && [string is integer [lindex $args 0]]} {
0133         set level [lindex $args 0]
0134         set args [lrange $args 1 end]
0135     }
0136 
0137     # create client that defers reading reply
0138     set client [redis [srv $level "host"] [srv $level "port"] 1]
0139 
0140     # select the right db and read the response (OK)
0141     $client select 9
0142     $client read
0143     return $client
0144 }
0145 
0146 # Provide easy access to INFO properties. Same semantic as "proc r".
0147 proc s {args} {
0148     set level 0
0149     if {[string is integer [lindex $args 0]]} {
0150         set level [lindex $args 0]
0151         set args [lrange $args 1 end]
0152     }
0153     status [srv $level "client"] [lindex $args 0]
0154 }
0155 
0156 proc cleanup {} {
0157     if {!$::quiet} {puts -nonewline "Cleanup: may take some time... "}
0158     flush stdout
0159     catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]}
0160     catch {exec rm -rf {*}[glob tests/tmp/server.*]}
0161     if {!$::quiet} {puts "OK"}
0162 }
0163 
0164 proc find_available_port start {
0165     for {set j $start} {$j < $start+1024} {incr j} {
0166         if {[catch {
0167             set fd [socket 127.0.0.1 $j]
0168         }]} {
0169             return $j
0170         } else {
0171             close $fd
0172         }
0173     }
0174     if {$j == $start+1024} {
0175         error "Can't find a non busy port in the $start-[expr {$start+1023}] range."
0176     }
0177 }
0178 
0179 proc test_server_main {} {
0180     cleanup
0181     set tclsh [info nameofexecutable]
0182     # Open a listening socket, trying different ports in order to find a
0183     # non busy one.
0184     set port [find_available_port 11111]
0185     if {!$::quiet} {
0186         puts "Starting test server at port $port"
0187     }
0188     socket -server accept_test_clients $port
0189 
0190     # Start the client instances
0191     set ::clients_pids {}
0192     set start_port [expr {$::port+100}]
0193     for {set j 0} {$j < $::numclients} {incr j} {
0194         set start_port [find_available_port $start_port]
0195         set p [exec $tclsh [info script] {*}$::argv \
0196             --client $port --port $start_port &]
0197         lappend ::clients_pids $p
0198         incr start_port 10
0199     }
0200 
0201     # Setup global state for the test server
0202     set ::idle_clients {}
0203     set ::active_clients {}
0204     array set ::clients_start_time {}
0205     set ::clients_time_history {}
0206     set ::failed_tests {}
0207 
0208     # Enter the event loop to handle clients I/O
0209     after 100 test_server_cron
0210     vwait forever
0211 }
0212 
0213 # This function gets called 10 times per second, for now does nothing but
0214 # may be used in the future in order to detect test clients taking too much
0215 # time to execute the task.
0216 proc test_server_cron {} {
0217 }
0218 
0219 proc accept_test_clients {fd addr port} {
0220     fileevent $fd readable [list read_from_test_client $fd]
0221 }
0222 
0223 # This is the readable handler of our test server. Clients send us messages
0224 # in the form of a status code such and additional data. Supported
0225 # status types are:
0226 #
0227 # ready: the client is ready to execute the command. Only sent at client
0228 #        startup. The server will queue the client FD in the list of idle
0229 #        clients.
0230 # testing: just used to signal that a given test started.
0231 # ok: a test was executed with success.
0232 # err: a test was executed with an error.
0233 # exception: there was a runtime exception while executing the test.
0234 # done: all the specified test file was processed, this test client is
0235 #       ready to accept a new task.
0236 proc read_from_test_client fd {
0237     set bytes [gets $fd]
0238     set payload [read $fd $bytes]
0239     foreach {status data} $payload break
0240     if {$status eq {ready}} {
0241         if {!$::quiet} {
0242             puts "\[$status\]: $data"
0243         }
0244         signal_idle_client $fd
0245     } elseif {$status eq {done}} {
0246         set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}]
0247         set all_tests_count [llength $::all_tests]
0248         set running_tests_count [expr {[llength $::active_clients]-1}]
0249         set completed_tests_count [expr {$::next_test-$running_tests_count}]
0250         puts "\[$completed_tests_count/$all_tests_count [colorstr yellow $status]\]: $data ($elapsed seconds)"
0251         lappend ::clients_time_history $elapsed $data
0252         signal_idle_client $fd
0253     } elseif {$status eq {ok}} {
0254         if {!$::quiet} {
0255             puts "\[[colorstr green $status]\]: $data"
0256         }
0257     } elseif {$status eq {err}} {
0258         set err "\[[colorstr red $status]\]: $data"
0259         puts $err
0260         lappend ::failed_tests $err
0261     } elseif {$status eq {exception}} {
0262         puts "\[[colorstr red $status]\]: $data"
0263         foreach p $::clients_pids {
0264             catch {exec kill -9 $p}
0265         }
0266         exit 1
0267     } elseif {$status eq {testing}} {
0268         # No op
0269     } else {
0270         if {!$::quiet} {
0271             puts "\[$status\]: $data"
0272         }
0273     }
0274 }
0275 
0276 # A new client is idle. Remove it from the list of active clients and
0277 # if there are still test units to run, launch them.
0278 proc signal_idle_client fd {
0279     # Remove this fd from the list of active clients.
0280     set ::active_clients \
0281         [lsearch -all -inline -not -exact $::active_clients $fd]
0282     # New unit to process?
0283     if {$::next_test != [llength $::all_tests]} {
0284         if {!$::quiet} {
0285             puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"]
0286         }
0287         set ::clients_start_time($fd) [clock seconds]
0288         send_data_packet $fd run [lindex $::all_tests $::next_test]
0289         lappend ::active_clients $fd
0290         incr ::next_test
0291     } else {
0292         lappend ::idle_clients $fd
0293         if {[llength $::active_clients] == 0} {
0294             the_end
0295         }
0296     }
0297 }
0298 
0299 # The the_end funciton gets called when all the test units were already
0300 # executed, so the test finished.
0301 proc the_end {} {
0302     # TODO: print the status, exit with the rigth exit code.
0303     puts "\n                   The End\n"
0304     puts "Execution time of different units:"
0305     foreach {time name} $::clients_time_history {
0306         puts "  $time seconds - $name"
0307     }
0308     if {[llength $::failed_tests]} {
0309         puts "\n[colorstr bold-red {!!! WARNING}] The following tests failed:\n"
0310         foreach failed $::failed_tests {
0311             puts "*** $failed"
0312         }
0313         cleanup
0314         exit 1
0315     } else {
0316         puts "\n[colorstr bold-white {\o/}] [colorstr bold-green {All tests passed without errors!}]\n"
0317         cleanup
0318         exit 0
0319     }
0320 }
0321 
0322 # The client is not even driven (the test server is instead) as we just need
0323 # to read the command, execute, reply... all this in a loop.
0324 proc test_client_main server_port {
0325     set ::test_server_fd [socket localhost $server_port]
0326     send_data_packet $::test_server_fd ready [pid]
0327     while 1 {
0328         set bytes [gets $::test_server_fd]
0329         set payload [read $::test_server_fd $bytes]
0330         foreach {cmd data} $payload break
0331         if {$cmd eq {run}} {
0332             execute_tests $data
0333         } else {
0334             error "Unknown test client command: $cmd"
0335         }
0336     }
0337 }
0338 
0339 proc send_data_packet {fd status data} {
0340     set payload [list $status $data]
0341     puts $fd [string length $payload]
0342     puts -nonewline $fd $payload
0343     flush $fd
0344 }
0345 
0346 proc print_help_screen {} {
0347     puts [join {
0348         "--valgrind         Run the test over valgrind."
0349         "--accurate         Run slow randomized tests for more iterations."
0350         "--quiet            Don't show individual tests."
0351         "--single <unit>    Just execute the specified unit (see next option)."
0352         "--list-tests       List all the available test units."
0353         "--clients <num>    Number of test clients (16)."
0354         "--force-failure    Force the execution of a test that always fails."
0355         "--help             Print this help screen."
0356     } "\n"]
0357 }
0358 
0359 # parse arguments
0360 for {set j 0} {$j < [llength $argv]} {incr j} {
0361     set opt [lindex $argv $j]
0362     set arg [lindex $argv [expr $j+1]]
0363     if {$opt eq {--tags}} {
0364         foreach tag $arg {
0365             if {[string index $tag 0] eq "-"} {
0366                 lappend ::denytags [string range $tag 1 end]
0367             } else {
0368                 lappend ::allowtags $tag
0369             }
0370         }
0371         incr j
0372     } elseif {$opt eq {--valgrind}} {
0373         set ::valgrind 1
0374     } elseif {$opt eq {--quiet}} {
0375         set ::quiet 1
0376     } elseif {$opt eq {--host}} {
0377         set ::external 1
0378         set ::host $arg
0379         incr j
0380     } elseif {$opt eq {--port}} {
0381         set ::port $arg
0382         incr j
0383     } elseif {$opt eq {--accurate}} {
0384         set ::accurate 1
0385     } elseif {$opt eq {--force-failure}} {
0386         set ::force_failure 1
0387     } elseif {$opt eq {--single}} {
0388         set ::all_tests $arg
0389         incr j
0390     } elseif {$opt eq {--list-tests}} {
0391         foreach t $::all_tests {
0392             puts $t
0393         }
0394         exit 0
0395     } elseif {$opt eq {--client}} {
0396         set ::client 1
0397         set ::test_server_port $arg
0398         incr j
0399     } elseif {$opt eq {--clients}} {
0400         set ::numclients $arg
0401         incr j
0402     } elseif {$opt eq {--help}} {
0403         print_help_screen
0404         exit 0
0405     } else {
0406         puts "Wrong argument: $opt"
0407         exit 1
0408     }
0409 }
0410 
0411 proc attach_to_replication_stream {} {
0412     set s [socket [srv 0 "host"] [srv 0 "port"]]
0413     fconfigure $s -translation binary
0414     puts -nonewline $s "SYNC\r\n"
0415     flush $s
0416 
0417     # Get the count
0418     set count [gets $s]
0419     set prefix [string range $count 0 0]
0420     if {$prefix ne {$}} {
0421         error "attach_to_replication_stream error. Received '$count' as count."
0422     }
0423     set count [string range $count 1 end]
0424 
0425     # Consume the bulk payload
0426     while {$count} {
0427         set buf [read $s $count]
0428         set count [expr {$count-[string length $buf]}]
0429     }
0430     return $s
0431 }
0432 
0433 proc read_from_replication_stream {s} {
0434     fconfigure $s -blocking 0
0435     set attempt 0
0436     while {[gets $s count] == -1} {
0437         if {[incr attempt] == 10} return ""
0438         after 100
0439     }
0440     fconfigure $s -blocking 1
0441 
0442     # Workaround for Redis 2.6, not always using the new protocol in the
0443     # replication channel (this was fixed in >= 2.8).
0444     if {[string tolower [lindex [split $count] 0]] eq {select}} {
0445         return $count
0446     }
0447 
0448     # Return a list of arguments for the command.
0449     set count [string range $count 1 end]
0450     set res {}
0451     for {set j 0} {$j < $count} {incr j} {
0452         read $s 1
0453         set arg [::redis::redis_bulk_read $s]
0454         if {$j == 0} {set arg [string tolower $arg]}
0455         lappend res $arg
0456     }
0457     return $res
0458 }
0459 
0460 proc assert_replication_stream {s patterns} {
0461     for {set j 0} {$j < [llength $patterns]} {incr j} {
0462         assert_match [lindex $patterns $j] [read_from_replication_stream $s]
0463     }
0464 }
0465 
0466 proc close_replication_stream {s} {
0467     close $s
0468 }
0469 
0470 # With the parallel test running multiple Redis instances at the same time
0471 # we need a fast enough computer, otherwise a lot of tests may generate
0472 # false positives.
0473 # If the computer is too slow we revert the sequetial test without any
0474 # parallelism, that is, clients == 1.
0475 proc is_a_slow_computer {} {
0476     set start [clock milliseconds]
0477     for {set j 0} {$j < 1000000} {incr j} {}
0478     set elapsed [expr [clock milliseconds]-$start]
0479     expr {$elapsed > 200}
0480 }
0481 
0482 if {$::client} {
0483     if {[catch { test_client_main $::test_server_port } err]} {
0484         set estr "Executing test client: $err.\n$::errorInfo"
0485         if {[catch {send_data_packet $::test_server_fd exception $estr}]} {
0486             puts $estr
0487         }
0488         exit 1
0489     }
0490 } else {
0491     if {[is_a_slow_computer]} {
0492         puts "** SLOW COMPUTER ** Using a single client to avoid false positives."
0493         set ::numclients 1
0494     }
0495 
0496     if {[catch { test_server_main } err]} {
0497         if {[string length $err] > 0} {
0498             # only display error when not generated by the test suite
0499             if {$err ne "exception"} {
0500                 puts $::errorInfo
0501             }
0502             exit 1
0503         }
0504     }
0505 }