diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 176243be736..784f9b3b601 100644 --- 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 index 27674ace352..6894bb0b55f 100644 --- 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 index f79edd7ffc8..a24cb0634eb 100644 --- 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 index 8cc918263c5..e9c5759241b 100644 --- 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