diff options
| -rw-r--r-- | tests/oo.test | 85 |
1 files changed, 62 insertions, 23 deletions
diff --git a/tests/oo.test b/tests/oo.test index f3413e1..bae93e7 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 # this test suite, interp creation and interp deletion are often used in @@ -667,28 +681,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 {} @@ -4541,13 +4557,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 { @@ -4575,13 +4598,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 { @@ -4616,13 +4647,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" + test oo-36.1 {TIP #470: introspection within oo::define} { oo::define oo::object self } ::oo::object @@ -5724,6 +5762,7 @@ test oo-43.13 {TIP 524: definition namespace control: user-level introspection} namespace delete foodef } -result {{} {} ::foodef {} {}} +rename bgerrorIntercept {} cleanupTests return |