# Redis test suite. Copyright (C) 2009 Salvatore Sanfilippo antirez@gmail.com # This software is released under the BSD License. See the COPYING file for # more information. package require Tcl 8.5 set tcl_precision 17 source tests/support/redis.tcl source tests/support/server.tcl source tests/support/tmpfile.tcl source tests/support/test.tcl source tests/support/util.tcl set ::all_tests { unit/printver unit/dump unit/auth unit/protocol unit/keyspace unit/scan unit/type/string unit/type/incr unit/type/list unit/type/list-2 unit/type/list-3 unit/type/set unit/type/zset unit/type/hash unit/type/stream unit/sort unit/expire unit/other unit/multi unit/quit unit/aofrw integration/replication integration/replication-2 integration/replication-3 integration/replication-4 integration/replication-psync integration/aof integration/rdb integration/convert-zipmap-hash-on-load integration/logging integration/psync2 integration/psync2-reg unit/pubsub unit/slowlog unit/scripting unit/maxmemory unit/introspection unit/introspection-2 unit/limits unit/obuf-limits unit/bitops unit/bitfield unit/geo unit/memefficiency unit/hyperloglog unit/lazyfree unit/wait } # Index to the next test to run in the ::all_tests list. set ::next_test 0 set ::host 127.0.0.1 set ::port 21111 set ::traceleaks 0 set ::valgrind 0 set ::stack_logging 0 set ::verbose 0 set ::quiet 0 set ::denytags {} set ::allowtags {} set ::external 0; # If "1" this means, we are running against external instance set ::file ""; # If set, runs only the tests in this comma separated list set ::curfile ""; # Hold the filename of the current suite set ::accurate 0; # If true runs fuzz tests with more iterations set ::force_failure 0 set ::timeout 600; # 10 minutes without progresses will quit the test. set ::last_progress [clock seconds] set ::active_servers {} ; # Pids of active Redis instances. # Set to 1 when we are running in client mode. The Redis test uses a # server-client model to run tests simultaneously. The server instance # runs the specified number of client instances that will actually run tests. # The server is responsible of showing the result to the user, and exit with # the appropriate exit code depending on the test outcome. set ::client 0 set ::numclients 16 proc execute_tests name { set path "tests/$name.tcl" set ::curfile $path source $path send_data_packet $::test_server_fd done "$name" } # Setup a list to hold a stack of server configs. When calls to start_server # are nested, use "srv 0 pid" to get the pid of the inner server. To access # outer servers, use "srv -1 pid" etcetera. set ::servers {} proc srv {args} { set level 0 if {[string is integer [lindex $args 0]]} { set level [lindex $args 0] set property [lindex $args 1] } else { set property [lindex $args 0] } set srv [lindex $::servers end+$level] dict get $srv $property } # Provide easy access to the client for the inner server. It's possible to # prepend the argument list with a negative level to access clients for # servers running in outer blocks. proc r {args} { set level 0 if {[string is integer [lindex $args 0]]} { set level [lindex $args 0] set args [lrange $args 1 end] } [srv $level "client"] {*}$args } proc reconnect {args} { set level [lindex $args 0] if {[string length $level] == 0 || ![string is integer $level]} { set level 0 } set srv [lindex $::servers end+$level] set host [dict get $srv "host"] set port [dict get $srv "port"] set config [dict get $srv "config"] set client [redis $host $port] dict set srv "client" $client # select the right db when we don't have to authenticate if {![dict exists $config "requirepass"]} { $client select 9 } # re-set $srv in the servers list lset ::servers end+$level $srv } proc redis_deferring_client {args} { set level 0 if {[llength $args] > 0 && [string is integer [lindex $args 0]]} { set level [lindex $args 0] set args [lrange $args 1 end] } # create client that defers reading reply set client [redis [srv $level "host"] [srv $level "port"] 1] # select the right db and read the response (OK) $client select 9 $client read return $client } # Provide easy access to INFO properties. Same semantic as "proc r". proc s {args} { set level 0 if {[string is integer [lindex $args 0]]} { set level [lindex $args 0] set args [lrange $args 1 end] } status [srv $level "client"] [lindex $args 0] } proc cleanup {} { if {!$::quiet} {puts -nonewline "Cleanup: may take some time... "} flush stdout catch {exec rm -rf {*}[glob tests/tmp/redis.conf.*]} catch {exec rm -rf {*}[glob tests/tmp/server.*]} if {!$::quiet} {puts "OK"} } proc test_server_main {} { cleanup set tclsh [info nameofexecutable] # Open a listening socket, trying different ports in order to find a # non busy one. set port [find_available_port 11111] if {!$::quiet} { puts "Starting test server at port $port" } socket -server accept_test_clients -myaddr 127.0.0.1 $port # Start the client instances set ::clients_pids {} set start_port [expr {$::port+100}] for {set j 0} {$j < $::numclients} {incr j} { set start_port [find_available_port $start_port] set p [exec $tclsh [info script] {*}$::argv \ --client $port --port $start_port &] lappend ::clients_pids $p incr start_port 10 } # Setup global state for the test server set ::idle_clients {} set ::active_clients {} array set ::active_clients_task {} array set ::clients_start_time {} set ::clients_time_history {} set ::failed_tests {} # Enter the event loop to handle clients I/O after 100 test_server_cron vwait forever } # This function gets called 10 times per second. proc test_server_cron {} { set elapsed [expr {[clock seconds]-$::last_progress}] if {$elapsed > $::timeout} { set err "\[[colorstr red TIMEOUT]\]: clients state report follows." puts $err show_clients_state kill_clients force_kill_all_servers the_end } after 100 test_server_cron } proc accept_test_clients {fd addr port} { fconfigure $fd -encoding binary fileevent $fd readable [list read_from_test_client $fd] } # This is the readable handler of our test server. Clients send us messages # in the form of a status code such and additional data. Supported # status types are: # # ready: the client is ready to execute the command. Only sent at client # startup. The server will queue the client FD in the list of idle # clients. # testing: just used to signal that a given test started. # ok: a test was executed with success. # err: a test was executed with an error. # exception: there was a runtime exception while executing the test. # done: all the specified test file was processed, this test client is # ready to accept a new task. proc read_from_test_client fd { set bytes [gets $fd] set payload [read $fd $bytes] foreach {status data} $payload break set ::last_progress [clock seconds] if {$status eq {ready}} { if {!$::quiet} { puts "\[$status\]: $data" } signal_idle_client $fd } elseif {$status eq {done}} { set elapsed [expr {[clock seconds]-$::clients_start_time($fd)}] set all_tests_count [llength $::all_tests] set running_tests_count [expr {[llength $::active_clients]-1}] set completed_tests_count [expr {$::next_test-$running_tests_count}] puts "\[$completed_tests_count/$all_tests_count [colorstr yellow $status]\]: $data ($elapsed seconds)" lappend ::clients_time_history $elapsed $data signal_idle_client $fd set ::active_clients_task($fd) DONE } elseif {$status eq {ok}} { if {!$::quiet} { puts "\[[colorstr green $status]\]: $data" } set ::active_clients_task($fd) "(OK) $data" } elseif {$status eq {err}} { set err "\[[colorstr red $status]\]: $data" puts $err lappend ::failed_tests $err set ::active_clients_task($fd) "(ERR) $data" } elseif {$status eq {exception}} { puts "\[[colorstr red $status]\]: $data" kill_clients force_kill_all_servers exit 1 } elseif {$status eq {testing}} { set ::active_clients_task($fd) "(IN PROGRESS) $data" } elseif {$status eq {server-spawned}} { lappend ::active_servers $data } elseif {$status eq {server-killed}} { set ::active_servers [lsearch -all -inline -not -exact $::active_servers $data] } else { if {!$::quiet} { puts "\[$status\]: $data" } } } proc show_clients_state {} { # The following loop is only useful for debugging tests that may # enter an infinite loop. Commented out normally. foreach x $::active_clients { if {[info exist ::active_clients_task($x)]} { puts "$x => $::active_clients_task($x)" } else { puts "$x => ???" } } } proc kill_clients {} { foreach p $::clients_pids { catch {exec kill $p} } } proc force_kill_all_servers {} { foreach p $::active_servers { puts "Killing still running Redis server $p" catch {exec kill -9 $p} } } # A new client is idle. Remove it from the list of active clients and # if there are still test units to run, launch them. proc signal_idle_client fd { # Remove this fd from the list of active clients. set ::active_clients \ [lsearch -all -inline -not -exact $::active_clients $fd] if 0 {show_clients_state} # New unit to process? if {$::next_test != [llength $::all_tests]} { if {!$::quiet} { puts [colorstr bold-white "Testing [lindex $::all_tests $::next_test]"] set ::active_clients_task($fd) "ASSIGNED: $fd ([lindex $::all_tests $::next_test])" } set ::clients_start_time($fd) [clock seconds] send_data_packet $fd run [lindex $::all_tests $::next_test] lappend ::active_clients $fd incr ::next_test } else { lappend ::idle_clients $fd if {[llength $::active_clients] == 0} { the_end } } } # The the_end function gets called when all the test units were already # executed, so the test finished. proc the_end {} { # TODO: print the status, exit with the rigth exit code. puts "\n The End\n" puts "Execution time of different units:" foreach {time name} $::clients_time_history { puts " $time seconds - $name" } if {[llength $::failed_tests]} { puts "\n[colorstr bold-red {!!! WARNING}] The following tests failed:\n" foreach failed $::failed_tests { puts "*** $failed" } cleanup exit 1 } else { puts "\n[colorstr bold-white {\o/}] [colorstr bold-green {All tests passed without errors!}]\n" cleanup exit 0 } } # The client is not even driven (the test server is instead) as we just need # to read the command, execute, reply... all this in a loop. proc test_client_main server_port { set ::test_server_fd [socket localhost $server_port] fconfigure $::test_server_fd -encoding binary send_data_packet $::test_server_fd ready [pid] while 1 { set bytes [gets $::test_server_fd] set payload [read $::test_server_fd $bytes] foreach {cmd data} $payload break if {$cmd eq {run}} { execute_tests $data } else { error "Unknown test client command: $cmd" } } } proc send_data_packet {fd status data} { set payload [list $status $data] puts $fd [string length $payload] puts -nonewline $fd $payload flush $fd } proc print_help_screen {} { puts [join { "--valgrind Run the test over valgrind." "--stack-logging Enable OSX leaks/malloc stack logging." "--accurate Run slow randomized tests for more iterations." "--quiet Don't show individual tests." "--single Just execute the specified unit (see next option)." "--list-tests List all the available test units." "--clients Number of test clients (default 16)." "--timeout Test timeout in seconds (default 10 min)." "--force-failure Force the execution of a test that always fails." "--help Print this help screen." } "\n"] } # parse arguments for {set j 0} {$j < [llength $argv]} {incr j} { set opt [lindex $argv $j] set arg [lindex $argv [expr $j+1]] if {$opt eq {--tags}} { foreach tag $arg { if {[string index $tag 0] eq "-"} { lappend ::denytags [string range $tag 1 end] } else { lappend ::allowtags $tag } } incr j } elseif {$opt eq {--valgrind}} { set ::valgrind 1 } elseif {$opt eq {--stack-logging}} { if {[string match {*Darwin*} [exec uname -a]]} { set ::stack_logging 1 } } elseif {$opt eq {--quiet}} { set ::quiet 1 } elseif {$opt eq {--host}} { set ::external 1 set ::host $arg incr j } elseif {$opt eq {--port}} { set ::port $arg incr j } elseif {$opt eq {--accurate}} { set ::accurate 1 } elseif {$opt eq {--force-failure}} { set ::force_failure 1 } elseif {$opt eq {--single}} { set ::all_tests $arg incr j } elseif {$opt eq {--list-tests}} { foreach t $::all_tests { puts $t } exit 0 } elseif {$opt eq {--client}} { set ::client 1 set ::test_server_port $arg incr j } elseif {$opt eq {--clients}} { set ::numclients $arg incr j } elseif {$opt eq {--timeout}} { set ::timeout $arg incr j } elseif {$opt eq {--help}} { print_help_screen exit 0 } else { puts "Wrong argument: $opt" exit 1 } } proc attach_to_replication_stream {} { set s [socket [srv 0 "host"] [srv 0 "port"]] fconfigure $s -translation binary puts -nonewline $s "SYNC\r\n" flush $s # Get the count while 1 { set count [gets $s] set prefix [string range $count 0 0] if {$prefix ne {}} break; # Newlines are allowed as PINGs. } if {$prefix ne {$}} { error "attach_to_replication_stream error. Received '$count' as count." } set count [string range $count 1 end] # Consume the bulk payload while {$count} { set buf [read $s $count] set count [expr {$count-[string length $buf]}] } return $s } proc read_from_replication_stream {s} { fconfigure $s -blocking 0 set attempt 0 while {[gets $s count] == -1} { if {[incr attempt] == 10} return "" after 100 } fconfigure $s -blocking 1 set count [string range $count 1 end] # Return a list of arguments for the command. set res {} for {set j 0} {$j < $count} {incr j} { read $s 1 set arg [::redis::redis_bulk_read $s] if {$j == 0} {set arg [string tolower $arg]} lappend res $arg } return $res } proc assert_replication_stream {s patterns} { for {set j 0} {$j < [llength $patterns]} {incr j} { assert_match [lindex $patterns $j] [read_from_replication_stream $s] } } proc close_replication_stream {s} { close $s } # With the parallel test running multiple Redis instances at the same time # we need a fast enough computer, otherwise a lot of tests may generate # false positives. # If the computer is too slow we revert the sequential test without any # parallelism, that is, clients == 1. proc is_a_slow_computer {} { set start [clock milliseconds] for {set j 0} {$j < 1000000} {incr j} {} set elapsed [expr [clock milliseconds]-$start] expr {$elapsed > 200} } if {$::client} { if {[catch { test_client_main $::test_server_port } err]} { set estr "Executing test client: $err.\n$::errorInfo" if {[catch {send_data_packet $::test_server_fd exception $estr}]} { puts $estr } exit 1 } } else { if {[is_a_slow_computer]} { puts "** SLOW COMPUTER ** Using a single client to avoid false positives." set ::numclients 1 } if {[catch { test_server_main } err]} { if {[string length $err] > 0} { # only display error when not generated by the test suite if {$err ne "exception"} { puts $::errorInfo } exit 1 } } }