Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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

…ain of running servers
  • Loading branch information...
commit 8a58008b1bb7aa8a9ac791bea939295eae5c1603 1 parent 903b748
Pieter Noordhuis pietern authored
32 tests/support/server.tcl
View
@@ -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
}
11 tests/support/test.tcl
View
@@ -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"
10 tests/test_helper.tcl
View
@@ -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
+ }
+}
Please sign in to comment.
Something went wrong with that request. Please try again.