Permalink
Browse files

catch exceptions in the server proc, to be able to kill the entire ch…

…ain of running servers
  • Loading branch information...
1 parent 903b748 commit 8a58008b1bb7aa8a9ac791bea939295eae5c1603 @pietern pietern committed Jun 2, 2010
Showing with 36 additions and 17 deletions.
  1. +24 −8 tests/support/server.tcl
  2. +3 −8 tests/support/test.tcl
  3. +9 −1 tests/test_helper.tcl
View
32 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
}
View
11 tests/support/test.tcl
@@ -8,14 +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
- }
- }
- exit 1
+ puts "EXCEPTION"
+ puts "\nCaught error: $error"
+ error "exception"
}
if {$okpattern eq $retval || [string match $okpattern $retval]} {
puts "PASSED"
View
10 tests/test_helper.tcl
@@ -90,4 +90,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
+ }
+}

0 comments on commit 8a58008

Please sign in to comment.