merge 8.7

tcltk · Nov 1, 2024 · a8d9541 · a8d9541
2 parents a18a9d2 + f00ce52
commit a8d9541
Show file tree

Hide file tree

Showing 4 changed files with 72 additions and 12 deletions.
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
@@ -1083,7 +1083,7 @@ Tcl_DeleteNamespace(
 
 	nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
 	ensemblePtr->next = ensemblePtr;
-	Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
+	Tcl_DeleteCommandFromToken(interp, ensemblePtr->token);
     }
 
     /*
@@ -1162,8 +1162,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
@@ -870,7 +870,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? */
@@ -893,10 +893,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;
 }
 
@@ -1175,7 +1209,7 @@ ObjectNamespaceDeleted(
     Method *mPtr;
     Tcl_Obj *filterObj, *variableObj;
     PrivateVariableMapping *privateVariable;
-    Tcl_Interp *interp = oPtr->fPtr->interp;
+    Tcl_Interp *interp = fPtr->interp;
     Tcl_Size i;
 
     if (Destructing(oPtr)) {
@@ -1213,12 +1247,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);

diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
@@ -255,6 +255,8 @@ struct Object {
     PropertyStorage properties;	/* Information relating to the lists of
 				 * properties that this object *claims* to
 				 * support. */
+    Object *delNext;		/* If non-NULL, the next object to have its
+				 * namespace deleted. */
 };
 
 enum ObjectFlags {
@@ -374,6 +376,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;
 
 /*

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