From 09b3695d8834c46d7b646c10f8ccdf6107149e55 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 31 May 2024 08:58:03 +0000 Subject: [7c934f4a3d] Make sure to also trap background errors --- tests/oo.test | 55 +++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 43 insertions(+), 12 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 2662ed1..3201394 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -4204,6 +4204,16 @@ test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} +proc ::bgerrorIntercept {varName body} { + catch {rename bgerror ___old_bgerror} + interp alias {} ::bgerror {} ::lappend $varName + try { + uplevel 1 $body + } finally { + rename ::bgerror "" + catch {rename ___old_bgerror bgerror} + } +} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { method eat {} {} @@ -4319,13 +4329,20 @@ test oo-35.7.1 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } set ::result {} } -body { - set FH [RpcClient new] - $FH create_bug - $FH destroy + # In this case, sub-objects are deleted during major object NS cleanup and + # are trying to call back into the major object (which is mostky gone at + # this point). Things are messy; error is reported via bgerror as the + # avenue most likely to reach a user. + bgerrorIntercept ::result { + set FH [RpcClient new] + $FH create_bug + $FH destroy + update + } join $result \n } -cleanup { base destroy -} -result {} +} -result {impossible to invoke method "write": no defined method or unknown method} test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { oo::class create base oo::class create RpcClient { @@ -4353,13 +4370,21 @@ test oo-35.7.2 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } set ::result {} } -body { - set FH [RpcClient new] - $FH create_bug - $FH destroy + # In this case, sub-objects are deleted during major object NS cleanup, and + # we've a destructor on the major class to monitor when it happens. Things + # are still messy, but the order is clear; error is reported via bgerror as + # the avenue most likely to reach a user. + bgerrorIntercept ::result { + set FH [RpcClient new] + $FH create_bug + $FH destroy + update + } join $result \n } -cleanup { base destroy -} -result {Destroyed} +} -result {Destroyed +impossible to invoke method "write": no defined method or unknown method} test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { oo::class create base oo::class create RpcClient { @@ -4394,14 +4419,20 @@ test oo-35.7.3 {Bug 7842f33a5c: destructor cascading in stereotypes} -setup { } set ::result {} } -body { - set FH [RpcClient new] - $FH create_bug - $FH destroy + # In this case, sub-objects are deleted while the destructor is running and + # the destroy is neat, so things work sanely. Error follows standard Tcl + # error flow route; bgerror is not used. + bgerrorIntercept ::result { + set FH [RpcClient new] + $FH create_bug + $FH destroy + update + } join $result \n } -cleanup { base destroy } -result "Destroyed\nRpcClient -> otto-111" - +rename bgerrorIntercept {} cleanupTests return -- cgit v0.12 From 6d40bcd6760a0c4588871c83a35c3dc6b0845188 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 31 May 2024 10:56:00 +0000 Subject: More elegant background error interception, used more widely in oo.test --- tests/oo.test | 50 ++++++++++++++++++++++++++++---------------------- 1 file changed, 28 insertions(+), 22 deletions(-) diff --git a/tests/oo.test b/tests/oo.test index 3201394..41520a7 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,6 +13,20 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +# A helper for intercepting background errors +proc ::bgerrorIntercept {varName body} { + set old [interp bgerror {}] + interp bgerror {} [list apply {{var msg args} { + upvar #0 $var v + lappend v $msg + }} $varName] + try { + uplevel 1 $body + } finally { + interp bgerror {} $old + } +} + # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in @@ -668,28 +682,30 @@ test oo-3.6 {basic test of OO functionality: errors in destructor} -setup { } -result {1 foo {}} test oo-3.7 {basic test of OO functionality: errors in destructor} -setup { oo::class create cls - set result {} - proc bgerror msg {lappend ::result $msg} } -cleanup { cls destroy - rename bgerror {} } -body { oo::define cls destructor {error foo} - list [rename [cls create obj] {}] \ - [update idletasks] $result [info commands obj] -} -result {{} {} foo {}} + bgerrorIntercept result { + set result [cls create obj] + lappend result [rename obj {}] + update idletasks + lappend result [info commands obj] + } +} -result {::obj {} foo {}} test oo-3.8 {basic test of OO functionality: errors in destructor} -setup { oo::class create cls - set result {} - proc bgerror msg {lappend ::result $msg} } -cleanup { cls destroy - rename bgerror {} } -body { oo::define cls destructor {error foo} - list [namespace delete [info object namespace [cls create obj]]] \ - [update idletasks] $result [info commands obj] -} -result {{} {} foo {}} + bgerrorIntercept result { + set result [cls create obj] + lappend result [namespace delete [info object namespace obj]] + update idletasks + lappend result [info commands obj] + } +} -result {::obj {} foo {}} test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup { oo::class create cls set result {} @@ -4204,16 +4220,6 @@ test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} -proc ::bgerrorIntercept {varName body} { - catch {rename bgerror ___old_bgerror} - interp alias {} ::bgerror {} ::lappend $varName - try { - uplevel 1 $body - } finally { - rename ::bgerror "" - catch {rename ___old_bgerror bgerror} - } -} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { method eat {} {} -- cgit v0.12