X-Git-Url: https://git.saurik.com/redis.git/blobdiff_plain/13566085cf67f7417e60c10cc272c68ec8608b81..03116904c399cf21db3fe4228af3a795ce20fc46:/tests/test_helper.tcl diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl index f72d9712..4954b79e 100644 --- a/tests/test_helper.tcl +++ b/tests/test_helper.tcl @@ -15,6 +15,8 @@ set ::all_tests { unit/protocol unit/basic unit/type/list + unit/type/list-2 + unit/type/list-3 unit/type/set unit/type/zset unit/type/hash @@ -23,24 +25,35 @@ set ::all_tests { unit/other unit/cas unit/quit + unit/aofrw integration/replication + integration/replication-2 + integration/replication-3 integration/aof + integration/rdb unit/pubsub unit/slowlog + unit/scripting + unit/maxmemory + unit/introspection + unit/obuf-limits } # Index to the next test to run in the ::all_tests list. set ::next_test 0 set ::host 127.0.0.1 -set ::port 16379 +set ::port 21111 set ::traceleaks 0 set ::valgrind 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 to 1 when we are running in client mode. The Redis test uses a # server-client model to run tests simultaneously. The server instance @@ -54,7 +67,7 @@ proc execute_tests name { set path "tests/$name.tcl" set ::curfile $path source $path - send_data_packet $::test_server_fd done "$name finished" + send_data_packet $::test_server_fd done "$name" } # Setup a list to hold a stack of server configs. When calls to start_server @@ -104,7 +117,7 @@ proc reconnect {args} { } # re-set $srv in the servers list - set ::servers [lreplace $::servers end+$level 1 $srv] + lset ::servers end+$level $srv } proc redis_deferring_client {args} { @@ -134,46 +147,55 @@ proc s {args} { } proc cleanup {} { - puts -nonewline "Cleanup: warning may take some time... " + 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.*]} - puts "OK" + if {!$::quiet} {puts "OK"} +} + +proc find_available_port start { + for {set j $start} {$j < $start+1024} {incr j} { + if {[catch { + set fd [socket 127.0.0.1 $j] + }]} { + return $j + } else { + close $fd + } + } + if {$j == $start+1024} { + error "Can't find a non busy port in the $start-[expr {$start+1023}] range." + } } proc test_server_main {} { cleanup # Open a listening socket, trying different ports in order to find a # non busy one. - set port 11111 - while 1 { + set port [find_available_port 11111] + if {!$::quiet} { puts "Starting test server at port $port" - if {[catch {socket -server accept_test_clients $port} e]} { - if {[string match {*address already in use*} $e]} { - if {$port == 20000} { - puts "Can't find an available TCP port for test server." - exit 1 - } else { - incr port - } - } else { - puts "Fatal error starting test server: $e" - exit 1 - } - } else { - break - } } + socket -server accept_test_clients $port # Start the client instances + set ::clients_pids {} + set start_port [expr {$::port+100}] for {set j 0} {$j < $::numclients} {incr j} { - exec tclsh8.5 [info script] {*}$::argv \ - --client $port --port [expr {$::port+($j*10)}] & + set start_port [find_available_port $start_port] + set p [exec tclsh8.5 [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 ::clients_start_time {} + set ::clients_time_history {} + set ::failed_tests {} # Enter the event loop to handle clients I/O after 100 test_server_cron @@ -207,12 +229,39 @@ proc read_from_test_client fd { set bytes [gets $fd] set payload [read $fd $bytes] foreach {status data} $payload break - puts "($fd) \[$status\]: $data" 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 - puts "+++ [llength $::active_clients] units still in execution." + } elseif {$status eq {ok}} { + if {!$::quiet} { + puts "\[[colorstr green $status]\]: $data" + } + } elseif {$status eq {err}} { + set err "\[[colorstr red $status]\]: $data" + puts $err + lappend ::failed_tests $err + } elseif {$status eq {exception}} { + puts "\[[colorstr red $status]\]: $data" + foreach p $::clients_pids { + catch {exec kill -9 $p} + } + exit 1 + } elseif {$status eq {testing}} { + # No op + } else { + if {!$::quiet} { + puts "\[$status\]: $data" + } } } @@ -224,7 +273,10 @@ proc signal_idle_client fd { [lsearch -all -inline -not -exact $::active_clients $fd] # New unit to process? if {$::next_test != [llength $::all_tests]} { - puts "Spawing new test process for: [lindex $::all_tests $::next_test]" + if {!$::quiet} { + puts [colorstr bold-white "Testing [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 @@ -240,8 +292,23 @@ proc signal_idle_client fd { # executed, so the test finished. proc the_end {} { # TODO: print the status, exit with the rigth exit code. - puts "The End" - exit 1 + 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 @@ -268,6 +335,18 @@ proc send_data_packet {fd status data} { flush $fd } +proc print_help_screen {} { + puts [join { + "--valgrind Run the test over valgrind." + "--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." + "--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] @@ -283,9 +362,8 @@ for {set j 0} {$j < [llength $argv]} {incr j} { incr j } elseif {$opt eq {--valgrind}} { set ::valgrind 1 - } elseif {$opt eq {--file}} { - set ::file $arg - incr j + } elseif {$opt eq {--quiet}} { + set ::quiet 1 } elseif {$opt eq {--host}} { set ::external 1 set ::host $arg @@ -293,12 +371,25 @@ for {set j 0} {$j < [llength $argv]} {incr j} { } elseif {$opt eq {--port}} { set ::port $arg incr j - } elseif {$opt eq {--verbose}} { - set ::verbose 1 + } 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 {--help}} { + print_help_screen + exit 0 } else { puts "Wrong argument: $opt" exit 1