Merge remote branch 'pietern/testverbosity'

tests/support/server.tcl

@@ -83,10 +83,14 @@ proc ping_server {host port} {
         }
         close $fd
     } e]} {
+        if {$::verbose} {
             puts -nonewline "."
+        }
     } else {
+        if {$::verbose} {
             puts -nonewline "ok"
         }
+    }
     return $retval
 }
 
@@ -181,7 +185,10 @@ proc start_server {options {code undefined}} {
     set retrynum 20
     set serverisup 0
 
+    if {$::verbose} {
         puts -nonewline "=== ($tags) Starting server ${::host}:${::port} "
+    }
+
     after 10
     if {$code ne "undefined"} {
         while {[incr retrynum -1]} {
@@ -196,7 +203,10 @@ proc start_server {options {code undefined}} {
     } else {
         set serverisup 1
     }
-    puts {}
+
+    if {$::verbose} {
+        puts ""
+    }
 
     if {!$serverisup} {
         error_and_quit $config_file [exec cat $stderr]
@@ -246,42 +256,35 @@ proc start_server {options {code undefined}} {
         reconnect
 
         # execute provided block
-        set curnum $::testnum
+        set num_tests $::num_tests
-        if {![catch { uplevel 1 $code } err]} {
+        if {[catch { uplevel 1 $code } error]} {
-            # zero exit status is good
+            set backtrace $::errorInfo
-            unset err
-        }
 
-        if {$curnum == $::testnum} {
+            # Kill the server without checking for leaks
-            # don't check for leaks when no tests were executed
             dict set srv "skipleaks" 1
-        }
+            kill_server $srv
 
-        # pop the server object
+            # Print warnings from log
-        set ::servers [lrange $::servers 0 end-1]
+            puts [format "\nLogged warnings (pid %d):" [dict get $srv "pid"]]
-        
-        # allow an exception to bubble up the call chain but still kill this
-        # server, because we want to reuse the ports when the tests are re-run
-        if {[info exists err]} {
-            if {$err eq "exception"} {
-                puts [format "Logged warnings (pid %d):" [dict get $srv "pid"]]
             set warnings [warnings_from_file [dict get $srv "stdout"]]
             if {[string length $warnings] > 0} {
                 puts "$warnings"
             } else {
                 puts "(none)"
             }
-                # kill this server without checking for leaks
+            puts ""
+
+            error $error $backtrace
+        }
+
+        # Don't do the leak check when no tests were run
+        if {$num_tests == $::num_tests} {
             dict set srv "skipleaks" 1
-                kill_server $srv
-                error "exception"
-            } elseif {[string length $err] > 0} {
-                puts "Error executing the suite, aborting..."
-                puts $err
-                exit 1
-            }
         }
 
+        # pop the server object
+        set ::servers [lrange $::servers 0 end-1]
+
         set ::tags [lrange $::tags 0 end-[llength $tags]]
         kill_server $srv
     } else {

tests/support/test.tcl

@@ -1,25 +1,23 @@
-set ::passed 0
+set ::num_tests 0
-set ::failed 0
+set ::num_passed 0
-set ::testnum 0
+set ::num_failed 0
+set ::tests_failed {}
 
 proc assert {condition} {
     if {![uplevel 1 expr $condition]} {
-        puts "!! ERROR\nExpected '$value' to evaluate to true"
+        error "assertion:Expected '$value' to be true"
-        error "assertion"
     }
 }
 
 proc assert_match {pattern value} {
     if {![string match $pattern $value]} {
-        puts "!! ERROR\nExpected '$value' to match '$pattern'"
+        error "assertion:Expected '$value' to match '$pattern'"
-        error "assertion"
     }
 }
 
 proc assert_equal {expected value} {
     if {$expected ne $value} {
-        puts "!! ERROR\nExpected '$value' to be equal to '$expected'"
+        error "assertion:Expected '$value' to be equal to '$expected'"
-        error "assertion"
     }
 }
 
@@ -27,8 +25,7 @@ proc assert_error {pattern code} {
     if {[catch {uplevel 1 $code} error]} {
         assert_match $pattern $error
     } else {
-        puts "!! ERROR\nExpected an error but nothing was catched"
+        error "assertion:Expected an error but nothing was catched"
-        error "assertion"
     }
 }
 
@@ -47,7 +44,7 @@ proc assert_type {type key} {
     assert_equal $type [r type $key]
 }
 
-proc test {name code {okpattern notspecified}} {
+proc test {name code {okpattern undefined}} {
     # abort if tagged with a tag to deny
     foreach tag $::denytags {
         if {[lsearch $::tags $tag] >= 0} {
@@ -69,30 +66,62 @@ proc test {name code {okpattern notspecified}} {
         }
     }
 
-    incr ::testnum
+    incr ::num_tests
-    puts -nonewline [format "#%03d %-68s " $::testnum $name]
+    set details {}
+    lappend details $::curfile
+    lappend details $::tags
+    lappend details $name
+
+    if {$::verbose} {
+        puts -nonewline [format "#%03d %-68s " $::num_tests $name]
         flush stdout
+    }
+
     if {[catch {set retval [uplevel 1 $code]} error]} {
-        if {$error eq "assertion"} {
+        if {[string match "assertion:*" $error]} {
-            incr ::failed
+            set msg [string range $error 10 end]
+            lappend details $msg
+            lappend ::tests_failed $details
+
+            incr ::num_failed
+            if {$::verbose} {
+                puts "FAILED"
+                puts "$msg\n"
             } else {
-            puts "EXCEPTION"
+                puts -nonewline "F"
-            puts "\nCaught error: $error"
-            error "exception"
             }
         } else {
-        if {$okpattern eq "notspecified" || $okpattern eq $retval || [string match $okpattern $retval]} {
+            # Re-raise, let handler up the stack take care of this.
+            error $error $::errorInfo
+        }
+    } else {
+        if {$okpattern eq "undefined" || $okpattern eq $retval || [string match $okpattern $retval]} {
+            incr ::num_passed
+            if {$::verbose} {
                 puts "PASSED"
-            incr ::passed
             } else {
-            puts "!! ERROR expected\n'$okpattern'\nbut got\n'$retval'"
+                puts -nonewline "."
-            incr ::failed
+            }
+        } else {
+            set msg "Expected '$okpattern' to equal or match '$retval'"
+            lappend details $msg
+            lappend ::tests_failed $details
+
+            incr ::num_failed
+            if {$::verbose} {
+                puts "FAILED"
+                puts "$msg\n"
+            } else {
+                puts -nonewline "F"
             }
         }
+    }
+    flush stdout
+
     if {$::traceleaks} {
         set output [exec leaks redis-server]
         if {![string match {*0 leaks*} $output]} {
-            puts "--------- Test $::testnum LEAKED! --------"
+            puts "--- Test \"$name\" leaked! ---"
             puts $output
             exit 1
         }

tests/support/util.tcl

@@ -52,8 +52,10 @@ proc status {r property} {
 proc waitForBgsave r {
     while 1 {
         if {[status r bgsave_in_progress] eq 1} {
+            if {$::verbose} {
                 puts -nonewline "\nWaiting for background save to finish... "
                 flush stdout
+            }
             after 1000
         } else {
             break
@@ -64,8 +66,10 @@ proc waitForBgsave r {
 proc waitForBgrewriteaof r {
     while 1 {
         if {[status r bgrewriteaof_in_progress] eq 1} {
+            if {$::verbose} {
                 puts -nonewline "\nWaiting for background AOF rewrite to finish... "
                 flush stdout
+            }
             after 1000
         } else {
             break

tests/test_helper.tcl

@@ -13,13 +13,17 @@ set ::host 127.0.0.1
 set ::port 16379
 set ::traceleaks 0
 set ::valgrind 0
+set ::verbose 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
 
 proc execute_tests name {
-    source "tests/$name.tcl"
+    set path "tests/$name.tcl"
+    set ::curfile $path
+    source $path
 }
 
 # Setup a list to hold a stack of server configs. When calls to start_server
@@ -147,9 +151,27 @@ proc main {} {
     }
 
     cleanup
-    puts "\n[expr $::passed+$::failed] tests, $::passed passed, $::failed failed"
+    puts "\n[expr $::num_tests] tests, $::num_passed passed, $::num_failed failed\n"
-    if {$::failed > 0} {
+    if {$::num_failed > 0} {
-        puts "\n*** WARNING!!! $::failed FAILED TESTS ***\n"
+        set curheader ""
+        puts "Failures:"
+        foreach {test} $::tests_failed {
+            set header [lindex $test 0]
+            append header " ("
+            append header [join [lindex $test 1] ","]
+            append header ")"
+
+            if {$curheader ne $header} {
+                set curheader $header
+                puts "\n$curheader:"
+            }
+
+            set name [lindex $test 2]
+            set msg [lindex $test 3]
+            puts "- $name: $msg"
+        }
+
+        puts ""
         exit 1
     }
 }
@@ -179,6 +201,8 @@ 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
     } else {
         puts "Wrong argument: $opt"
         exit 1
@@ -189,7 +213,7 @@ if {[catch { main } err]} {
     if {[string length $err] > 0} {
         # only display error when not generated by the test suite
         if {$err ne "exception"} {
-            puts $err
+            puts $::errorInfo
         }
         exit 1
     }

tests/unit/sort.tcl

@@ -144,9 +144,11 @@ start_server {
                 set sorted [r sort tosort BY weight_* LIMIT 0 10]
             }
             set elapsed [expr [clock clicks -milliseconds]-$start]
+            if {$::verbose} {
                 puts -nonewline "\n  Average time to sort: [expr double($elapsed)/100] milliseconds "
                 flush stdout
             }
+        }
 
         test "SORT speed, $num element list BY hash field, 100 times" {
             set start [clock clicks -milliseconds]
@@ -154,9 +156,11 @@ start_server {
                 set sorted [r sort tosort BY wobj_*->weight LIMIT 0 10]
             }
             set elapsed [expr [clock clicks -milliseconds]-$start]
+            if {$::verbose} {
                 puts -nonewline "\n  Average time to sort: [expr double($elapsed)/100] milliseconds "
                 flush stdout
             }
+        }
 
         test "SORT speed, $num element list directly, 100 times" {
             set start [clock clicks -milliseconds]
@@ -164,9 +168,11 @@ start_server {
                 set sorted [r sort tosort LIMIT 0 10]
             }
             set elapsed [expr [clock clicks -milliseconds]-$start]
+            if {$::verbose} {
                 puts -nonewline "\n  Average time to sort: [expr double($elapsed)/100] milliseconds "
                 flush stdout
             }
+        }
 
         test "SORT speed, $num element list BY <const>, 100 times" {
             set start [clock clicks -milliseconds]
@@ -174,8 +180,10 @@ start_server {
                 set sorted [r sort tosort BY nokey LIMIT 0 10]
             }
             set elapsed [expr [clock clicks -milliseconds]-$start]
+            if {$::verbose} {
                 puts -nonewline "\n  Average time to sort: [expr double($elapsed)/100] milliseconds "
                 flush stdout
             }
         }
+    }
 }