Ensure that destroying an object in a constructor doesn't crash. [Bug 2903011]

3 files changed, 92 insertions, 25 deletions

diff --git a/ChangeLog b/ChangeLog
index d5b9889..53c9f3e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,38 +1,48 @@
+2009-11-24  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.c (FinalizeAlloc, Tcl_NewObjectInstance):
+	[Bug 2903011]: Make it an error to destroy an object in a constructor,
+	and also make sure that an object is not deleted twice in the error
+	case.
+
 2009-11-24  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
-	* tests/fCmd.test:  [Bug 2893771] Teach [file stat] to handle locked
+	* tests/fCmd.test: [Bug 2893771]: Teach [file stat] to handle locked
 	* win/tclWinFile.c: files so that [file exists] no longer lies.
 
 2009-11-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* library/tclIndex  (regenerated) to reflect various changes
-	                    in safe.tcl and other files.
+	* library/tclIndex:	(regenerated) to reflect various changes in
+				safe.tcl and other files.
 
 2009-11-23  Kevin Kenny  <kennykb@acm.org>
 
-	* tests/fCmd.test (fCmd-30.1): Changed registry location of the
-	'My Documents' folder to the one that's correct for Windows 2000,
-	XP, Server 2003, Vista, Server 2008, and Windows 7.
-	(See http://support.microsoft.com/kb/310746)	
+	* tests/fCmd.test (fCmd-30.1): Changed registry location of the 'My
+	Documents' folder to the one that's correct for Windows 2000, XP,
+	Server 2003, Vista, Server 2008, and Windows 7. (See
+	http://support.microsoft.com/kb/310746)
 	
 2009-11-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinDde.c         #undef STATIC_BUILD, in order to make sure that
-	* win/tclWinReg.c         Xxxxx_Init is always exported even when Tcl is
-	* generic/tclTest.c       built static (otherwise we cannot create a DLL).
-	* generic/tclThreadTest.c Make all functions static, except TclThread_Init.
-	* tests/fCmd.test         Enable fCmd-30.1 when registry is available.
-	* win/tcl.m4              Fix ${SHLIB_LD_LIBS} definition, fix conflicts
-	* win/Makefile.in         Simplifications related to tcl.m4 changes.
-	* win/configure.in        between static libraries and import library on windows.
-	* win/configure           (regenerated)
-	* win/makefile.vc         Add stub library to necessary link lines
+	* win/tclWinDde.c:	#undef STATIC_BUILD, in order to make sure
+	* win/tclWinReg.c:	that Xxxxx_Init is always exported even when
+	* generic/tclTest.c:	Tcl is built static (otherwise we cannot
+				create a DLL).
+	* generic/tclThreadTest.c: Make all functions static, except
+				TclThread_Init.
+	* tests/fCmd.test:	Enable fCmd-30.1 when registry is available.
+	* win/tcl.m4:		Fix ${SHLIB_LD_LIBS} definition, fix conflicts
+	* win/Makefile.in:	Simplifications related to tcl.m4 changes.
+	* win/configure.in:	Between static libraries and import library on
+				windows.
+	* win/configure:	(regenerated)
+	* win/makefile.vc:	Add stub library to necessary link lines.
 
 2009-11-23  Kevin B. Kenny  <kennykb@acm.org>
 
-	* generic/tclThreadTest.c (NewTestThread): [Bug 2901803]
-	Further machinations to get NewTestThread actually to launch
-	the thread, not just compile.
+	* generic/tclThreadTest.c (NewTestThread): [Bug 2901803]: Further
+	machinations to get NewTestThread actually to launch the thread, not
+	just compile.
 	
 2009-11-22  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclOO.c b/generic/tclOO.c
index a4e8cce..242496f 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.25 2009/11/18 21:59:51 nijtmans Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.26 2009/11/24 12:00:08 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -1334,7 +1334,7 @@ Tcl_NewObjectInstance(
 		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
 
 	if (contextPtr != NULL) {
-	    int result;
+	    int result, flags;
 	    Tcl_InterpState state;
 
 	    AddRef(oPtr);
@@ -1343,11 +1343,32 @@ Tcl_NewObjectInstance(
 	    contextPtr->skip = skip;
 	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
 		    objc, objv);
+	    flags = oPtr->flags;
+
+	    /*
+	     * It's an error if the object was whacked in the constructor.
+	     * Force this if it isn't already an error (don't want to lose
+	     * errors by accident...) [Bug 2903011]
+	     */
+
+	    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+		Tcl_SetResult(interp, "object deleted in constructor",
+			TCL_STATIC);
+		result = TCL_ERROR;
+	    }
 	    TclOODeleteContext(contextPtr);
 	    DelRef(oPtr);
 	    if (result != TCL_OK) {
 		Tcl_DiscardInterpState(state);
-		Tcl_DeleteCommandFromToken(interp, oPtr->command);
+
+		/*
+		 * Take care to not delete a deleted object; that would be
+		 * bad. [Bug 2903011]
+		 */
+
+		if (!(flags & OBJECT_DELETED)) {
+		    Tcl_DeleteCommandFromToken(interp, oPtr->command);
+		}
 		return NULL;
 	    }
 	    Tcl_RestoreInterpState(interp, state);
@@ -1458,12 +1479,31 @@ FinalizeAlloc(
     Object *oPtr = data[1];
     Tcl_InterpState state = data[2];
     Tcl_Object *objectPtr = data[3];
+    int flags = oPtr->flags;
+
+    /*
+     * It's an error if the object was whacked in the constructor. Force this
+     * if it isn't already an error (don't want to lose errors by accident...)
+     * [Bug 2903011]
+     */
 
+    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+	Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
+	result = TCL_ERROR;
+    }
     TclOODeleteContext(contextPtr);
     DelRef(oPtr);
     if (result != TCL_OK) {
 	Tcl_DiscardInterpState(state);
-	Tcl_DeleteCommandFromToken(interp, oPtr->command);
+
+	/*
+	 * Take care to not delete a deleted object; that would be bad. [Bug
+	 * 2903011]
+	 */
+
+	if (!(flags & OBJECT_DELETED)) {
+	    Tcl_DeleteCommandFromToken(interp, oPtr->command);
+	}
 	return TCL_ERROR;
     }
     Tcl_RestoreInterpState(interp, state);
diff --git a/tests/oo.test b/tests/oo.test
index a976a7d..4c289ab 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.30 2009/10/22 15:39:58 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.31 2009/11/24 12:00:08 dkf Exp $
 
 package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -2332,6 +2332,23 @@ test oo-29.1 {self class with object-defined methods} -setup {
 } -returnCodes error -cleanup {
     obj destroy
 } -result {method not defined by a class}
+
+test oo-30.1 {Bug 2903011: deleting an object in a constructor} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {constructor {} {[self] destroy}}
+    cls new
+} -returnCodes error -cleanup {
+    cls destroy
+} -result {object deleted in constructor}
+test oo-30.2 {Bug 2903011: deleting an object in a constructor} -setup {
+    oo::class create cls
+} -body {
+    oo::define cls {constructor {} {my destroy}}
+    cls new
+} -returnCodes error -cleanup {
+    cls destroy
+} -result {object deleted in constructor}
 
 cleanupTests
 return