From dfbab38ae547e10b74c8c13190efc5015aa52b43 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 2 Feb 2010 09:13:45 +0000
Subject: [Bug 2944404] Be careful in case an object deletes itself in its
 destructor.

---
 ChangeLog            |  6 ++++++
 generic/tclOOBasic.c |  9 ++++++---
 tests/oo.test        | 18 +++++++++++++++++-
 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]
-- 
cgit v0.12