summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclOOBasic.c9
-rw-r--r--tests/oo.test18
3 files changed, 29 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index eea0ae9..2c95529 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2010-02-02 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOOBasic.c (TclOO_Object_Destroy): [Bug 2944404]: Do not
+ crash when a destructor deletes the object that is executing that
+ destructor.
+
2010-02-01 Donal K. Fellows <dkf@users.sf.net>
* generic/tclVar.c (Tcl_ArrayObjCmd): [Bug 2939073]: Stop the [array
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 193ca93..2c42fe9 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOBasic.c,v 1.22 2010/01/28 13:57:48 dkf Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.23 2010/02/02 09:13:45 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -267,6 +267,7 @@ TclOO_Object_Destroy(
NULL);
return TCL_ERROR;
}
+ AddRef(oPtr);
if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
@@ -280,8 +281,10 @@ TclOO_Object_Destroy(
TclOODeleteContext(contextPtr);
}
}
- Tcl_DeleteCommandFromToken(interp,
- Tcl_GetObjectCommand(Tcl_ObjectContextObject(context)));
+ if (oPtr->command) {
+ Tcl_DeleteCommandFromToken(interp, oPtr->command);
+ }
+ DelRef(oPtr);
return result;
}
diff --git a/tests/oo.test b/tests/oo.test
index 6fdc344..d831b3d 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.35 2010/01/28 10:25:05 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.36 2010/02/02 09:13:45 dkf Exp $
package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -440,6 +440,22 @@ test oo-3.8 {basic test of OO functionality: errors in destructor} -setup {
list [namespace delete [info object namespace [cls create obj]]] \
[update idletasks] $result [info commands obj]
} -result {{} {} foo {}}
+test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup {
+ oo::class create cls
+ set result {}
+} -body {
+ oo::define cls {
+ destructor {
+ lappend ::result in destructor
+ [self] destroy
+ }
+ }
+ # This used to crash
+ [cls new] destroy
+ return $result
+} -cleanup {
+ cls destroy
+} -result {in destructor}
test oo-4.1 {basic test of OO functionality: export} {
set o [oo::object new]