merge 8.6

tcltk · Nov 1, 2024 · f00ce52 · f00ce52
2 parents f8fc146 + 0771118
commit f00ce52
Show file tree

Hide file tree

Showing 4 changed files with 78 additions and 20 deletions.
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
@@ -908,9 +908,8 @@ Tcl_DeleteNamespace(
     Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
 {
     Namespace *nsPtr = (Namespace *) namespacePtr;
-    Interp *iPtr = (Interp *) nsPtr->interp;
-    Namespace *globalNsPtr = (Namespace *)
-	    TclGetGlobalNamespace((Tcl_Interp *) iPtr);
+    Tcl_Interp *interp = nsPtr->interp;
+    Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
     Tcl_HashEntry *entryPtr;
     Tcl_HashSearch search;
     Command *cmdPtr;
@@ -954,8 +953,7 @@ Tcl_DeleteNamespace(
 	    entryPtr != NULL;) {
 	cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
 	if (cmdPtr->nreProc == TclNRInterpCoroutine) {
-	    Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
-		    (Tcl_Command) cmdPtr);
+	    Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
 	    entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
 	} else {
 	    entryPtr = Tcl_NextHashEntry(&search);
@@ -978,7 +976,7 @@ Tcl_DeleteNamespace(
 
 	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
 	ensemblePtr->next = ensemblePtr;
-	Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
+	Tcl_DeleteCommandFromToken(interp, ensemblePtr->token);
     }
 
     /*
@@ -1033,7 +1031,7 @@ Tcl_DeleteNamespace(
 
 	TclTeardownNamespace(nsPtr);
 
-	if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
+	if ((nsPtr != globalNsPtr) || (((Interp *) interp)->flags & DELETED)) {
 	    /*
 	     * If this is the global namespace, then it may have residual
 	     * "errorInfo" and "errorCode" variables for errors that occurred
@@ -1059,8 +1057,8 @@ Tcl_DeleteNamespace(
 	     * Restore the ::errorInfo and ::errorCode traces.
 	     */
 
-	    EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
-	    EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
+	    EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
+	    EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
 
 	    /*
 	     * We didn't really kill it, so remove the KILLED marks, so it can

diff --git a/generic/tclOO.c b/generic/tclOO.c
@@ -832,7 +832,7 @@ MyClassDeleted(
 static void
 ObjectRenamedTrace(
     void *clientData,	/* The object being deleted. */
-    TCL_UNUSED(Tcl_Interp *),
+    Tcl_Interp *interp,
     TCL_UNUSED(const char *) /*oldName*/,
     TCL_UNUSED(const char *) /*newName*/,
     int flags)			/* Why was the object deleted? */
@@ -855,10 +855,44 @@ ObjectRenamedTrace(
      */
 
     if (!Destructing(oPtr)) {
-	Tcl_DeleteNamespace(oPtr->namespacePtr);
+	/*
+	 * Ensure that we don't recurse very deeply and blow out the C stack.
+	 * [Bug 02977e0004]
+	 */
+	ThreadLocalData *tsdPtr = GetFoundation(interp)->tsdPtr;
+	if (oPtr->classPtr) {
+	    /*
+	     * Classes currently need the recursion to get destructor calling
+	     * right. This is a bug, but it requires a major rewrite of things
+	     * to fix. 
+	     */
+	    Tcl_DeleteNamespace(oPtr->namespacePtr);
+	    oPtr->command = NULL;
+	    TclOODecrRefCount(oPtr);
+	} else if (!tsdPtr->delQueueTail) {
+	    /*
+	     * Process a queue of objects to delete.
+	     */
+	    Object *currPtr, *tmp;
+	    tsdPtr->delQueueTail = oPtr;
+	    for (currPtr = oPtr; currPtr; currPtr = tmp) {
+		Tcl_DeleteNamespace(currPtr->namespacePtr);
+		currPtr->command = NULL;
+		tmp = currPtr->delNext;
+		TclOODecrRefCount(currPtr);
+	    }
+	    tsdPtr->delQueueTail = NULL;
+	} else {
+	    /*
+	     * Enqueue the object.
+	     */
+	    tsdPtr->delQueueTail->delNext = oPtr;
+	    tsdPtr->delQueueTail = oPtr;
+	}
+    } else {
+	oPtr->command = NULL;
+	TclOODecrRefCount(oPtr);
     }
-    oPtr->command = NULL;
-    TclOODecrRefCount(oPtr);
     return;
 }
 
@@ -1154,7 +1188,7 @@ ObjectNamespaceDeleted(
     Method *mPtr;
     Tcl_Obj *filterObj, *variableObj, *propertyObj;
     PrivateVariableMapping *privateVariable;
-    Tcl_Interp *interp = oPtr->fPtr->interp;
+    Tcl_Interp *interp = fPtr->interp;
     Tcl_Size i;
 
     if (Destructing(oPtr)) {
@@ -1192,12 +1226,12 @@ ObjectNamespaceDeleted(
     if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
 	CallContext *contextPtr =
 		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
-	int result;
-	Tcl_InterpState state;
 
 	oPtr->flags |= DESTRUCTOR_CALLED;
-
 	if (contextPtr != NULL) {
+	    int result;
+	    Tcl_InterpState state;
+
 	    contextPtr->callPtr->flags |= DESTRUCTOR;
 	    contextPtr->skip = 0;
 	    state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -1229,14 +1263,14 @@ ObjectNamespaceDeleted(
 	 * as well.
 	 */
 
-	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
+	Tcl_DeleteCommandFromToken(interp, oPtr->command);
     }
 
     if (oPtr->myclassCommand) {
 	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
     }
     if (oPtr->myCommand) {
-	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
+	Tcl_DeleteCommandFromToken(interp, oPtr->myCommand);
     }
 
     /*

diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
@@ -244,6 +244,8 @@ typedef struct Object {
     PropertyStorage properties;	/* Information relating to the lists of
 				 * properties that this object *claims* to
 				 * support. */
+    struct Object *delNext;	/* If non-NULL, the next object to have its
+				 * namespace deleted. */
 } Object;
 
 #define OBJECT_DESTRUCTING 1	/* Indicates that an object is being or has
@@ -371,6 +373,8 @@ typedef struct ThreadLocalData {
 				 * because Tcl_Objs can cross interpreter
 				 * boundaries within a thread (objects don't
 				 * generally cross threads). */
+    Object *delQueueTail;	/* The tail object in the deletion queue. If
+				 * NULL, there is no deletion queue. */
 } ThreadLocalData;
 
 typedef struct Foundation {

diff --git a/tests/oo.test b/tests/oo.test
@@ -417,7 +417,7 @@ test oo-1.22 {basic test of OO functionality: nested ownership destruction order
 } -result {1 2 3 4 0}
 test oo-1.23 {basic test of OO functionality: deep nested ownership} -setup {
     oo::class create parent
-} -constraints knownBug -body {
+} -body {
     oo::class create abc {
 	superclass parent
 	method make {} {[self class] create xyz}
@@ -437,6 +437,28 @@ test oo-1.23 {basic test of OO functionality: deep nested ownership} -setup {
 } -cleanup {
     parent destroy
 } -result 0
+test oo-1.24 {basic test of OO functionality: deep nested ownership} -setup {
+    oo::class create parent
+} -constraints knownBug -body {
+    oo::class create abc {
+	superclass parent
+	self method make {} {oo::copy [self] xyz}
+	destructor {incr ::count}
+    }
+    apply {n {
+	set ::count 0
+	# Make a lot of "nested" objects
+	set base abc
+	for {set i 1; set obj $base} {$i < $n} {incr i} {
+	     set obj [$obj make]
+	}
+	# Kill them all in one go; should not crash!
+	$base destroy
+	return [expr {$n - $::count}]
+    }} 10000
+} -cleanup {
+    parent destroy
+} -result 0
 
 test oo-2.1 {basic test of OO functionality: constructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as