catch exceptions in the server proc, to be able to kill the entire chain of running...

diff --git a/tests/support/server.tcl b/tests/support/server.tcl
index 9bec2bc7f5a0b905c8212f10acce1d876a933d38..750d799ab811ad43ea165204c1e3e6fa3b60a464 100644 (file)
--- a/tests/support/server.tcl
+++ b/tests/support/server.tcl
@@ -27,11 +27,13 @@ proc kill_server config {
     set pid [dict get $config pid]
 
     # check for leaks
     set pid [dict get $config pid]
 
     # check for leaks

-    catch {
-        if {[string match {*Darwin*} [exec uname -a]]} {
-            test "Check for memory leaks (pid $pid)" {
-                exec leaks $pid
-            } {*0 leaks*}
+    if {![dict exists $config "skipleaks"]} {
+        catch {
+            if {[string match {*Darwin*} [exec uname -a]]} {
+                test "Check for memory leaks (pid $pid)" {
+                    exec leaks $pid
+                } {*0 leaks*}
+            }

         }
     }
 
         }
     }
 


@@ -182,13 +184,27 @@ proc start_server {filename overrides {code undefined}} {
         # pop the server object
         set ::servers [lrange $::servers 0 end-1]
         
         # pop the server object
         set ::servers [lrange $::servers 0 end-1]
         

-        kill_server $srv
-
-        if {[string length $err] > 0} {
+        # 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 {$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
+            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
         }
             puts "Error executing the suite, aborting..."
             puts $err
             exit 1
         }

+
+        kill_server $srv

     } else {
         set _ $srv
     }
     } else {
         set _ $srv
     }

diff --git a/tests/support/test.tcl b/tests/support/test.tcl
index 6d5634ea0da09d6ebdf9666b0a82913e326ec51b..1fdeb1e9a49777353696fe0115b6f6e4b6668415 100644 (file)
--- a/tests/support/test.tcl
+++ b/tests/support/test.tcl
@@ -8,15 +8,9 @@ proc test {name code okpattern} {
     puts -nonewline [format "#%03d %-68s " $::testnum $name]
     flush stdout
     if {[catch {set retval [uplevel 1 $code]} error]} {
     puts -nonewline [format "#%03d %-68s " $::testnum $name]
     flush stdout
     if {[catch {set retval [uplevel 1 $code]} error]} {

-        puts "ERROR\n\nLogged warnings:"
-        foreach file [glob tests/tmp/server.[pid].*/stdout] {
-            set warnings [warnings_from_file $file]
-            if {[string length $warnings] > 0} {
-                puts $warnings
-            }
-        }
-        puts "Script died with $error"
-        exit 1
+        puts "EXCEPTION"
+        puts "\nCaught error: $error"
+        error "exception"

     }
     if {$okpattern eq $retval || [string match $okpattern $retval]} {
         puts "PASSED"
     }
     if {$okpattern eq $retval || [string match $okpattern $retval]} {
         puts "PASSED"

diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl
index 035f013b5d299fd6a75341fb93ccb6122c64712c..49239a3a96242e691025d628323b19b3564f2a7d 100644 (file)
--- a/tests/test_helper.tcl
+++ b/tests/test_helper.tcl
@@ -92,4 +92,12 @@ proc main {} {
     cleanup
 }
 
     cleanup
 }
 

-main
+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
+        }
+        exit 1
+    }
+}