From 436f18b618d3820ee3c99b2ae78cf29bf36b2994 Mon Sep 17 00:00:00 2001
From: Pieter Noordhuis <pcnoordhuis@gmail.com>
Date: Wed, 2 Jun 2010 21:20:29 +0200
Subject: [PATCH] catch exceptions in the server proc, to be able to kill the
 entire chain of running servers

---
 tests/support/server.tcl | 32 ++++++++++++++++++++++++--------
 tests/support/test.tcl   | 12 +++---------
 tests/test_helper.tcl    | 10 +++++++++-
 3 files changed, 36 insertions(+), 18 deletions(-)

diff --git a/tests/support/server.tcl b/tests/support/server.tcl
index 9bec2bc7..750d799a 100644
--- 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
-    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]
         
-        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
         }
+
+        kill_server $srv
     } else {
         set _ $srv
     }
diff --git a/tests/support/test.tcl b/tests/support/test.tcl
index 6d5634ea..1fdeb1e9 100644
--- 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 "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"
diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl
index 035f013b..49239a3a 100644
--- a/tests/test_helper.tcl
+++ b/tests/test_helper.tcl
@@ -92,4 +92,12 @@ proc main {} {
     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
+    }
+}
-- 
2.47.2