diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclOO.c | 4 | ||||
| -rw-r--r-- | tests/oo.test | 30 |
3 files changed, 42 insertions, 3 deletions
@@ -1,3 +1,14 @@ +2008-08-04 Don Porter <dgp@users.sourceforge.net>S + + * generic/tclOO.c: Revised TclOO's check for an interp + being deleted during handling of object command deletion. The + old code was relying on documented features of command delete + traces that do not in fact work. [Bug 2039178]. + + * tests/oo.test (oo-26.*): Added tests that demonstrate + failure of TclOO to check for various kinds of invalid bytecode + during method dispatch. [Bug 2037727]. + 2008-08-06 Miguel Sofer <msofer@users.sf.net> * generic/tclVar.c (TclLookupSimpleVar): fix bug that the core diff --git a/generic/tclOO.c b/generic/tclOO.c index 6f078e4..4db39c3 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOO.c,v 1.13 2008/07/18 23:29:44 msofer Exp $ + * RCS: @(#) $Id: tclOO.c,v 1.14 2008/08/06 21:23:14 dgp Exp $ */ #ifdef HAVE_CONFIG_H @@ -562,7 +562,7 @@ ObjectRenamedTrace( AddRef(oPtr); oPtr->flags |= OBJECT_DELETED; - if (!(flags & TCL_INTERP_DESTROYED)) { + if (!Tcl_InterpDeleted(interp)) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR); if (contextPtr != NULL) { diff --git a/tests/oo.test b/tests/oo.test index 8ff06e8..ea97bf2 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: oo.test,v 1.9 2008/07/25 22:11:21 andreas_kupries Exp $ +# RCS: @(#) $Id: oo.test,v 1.10 2008/08/06 21:23:15 dgp Exp $ package require TclOO 0.4 ;# Must match value in configure.in if {[lsearch [namespace children] ::tcltest] == -1} { @@ -1787,6 +1787,34 @@ test oo-25.1 {call chain caching} -setup { lappend result [foo $m1] [bar $m2] } -result {ok ok ok ok ok ok good ok} +test oo-26.1 {Bug 2037727} -setup { + proc succeed args {} + oo::object create example +} -body { + oo::objdefine example method foo {} {succeed} + example foo + proc succeed {} {return succeed} + example foo +} -cleanup { + example destroy + rename succeed {} +} -result succeed + +test oo-26.2 {Bug 2037727} -setup { + oo::class create example { + method namespace {} {self namespace} + method foo {} {succeed} + } + example create i1 + example create i2 + namespace eval [i1 namespace] {proc succeed args {}} + namespace eval [i2 namespace] {proc succeed args {return succeed}} +} -body { + list [i1 foo] [i2 foo] +} -cleanup { + example destroy +} -result {{} succeed} + cleanupTests return |