Prevent leak of interps when using the [testthread exit] command.

6 files changed, 49 insertions, 8 deletions

diff --git a/ChangeLog b/ChangeLog
index 746955a..3b1fa30 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-08-30  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclBasic.c:		Prevent leak of interps when
+	* generic/tclExecute.c:		using the [testthread exit] command.
+	* generic/tclIORChan.c:
+	* generic/tclIORTrans.c:
+	* generic/tclThreadtest.c:
+
 2011-08-30  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclInterp.c (SlaveCommandLimitCmd, SlaveTimeLimitCmd):
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9758449..950b2de 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1359,7 +1359,7 @@ DeleteInterpProc(
 	 * unless we are exiting.
      */
 
-    if ((iPtr->numLevels > 0) && !TclInExit()) {
+    if ((iPtr->numLevels > 0) && !TclInExit() && !TclInThreadExit()) {
 	Tcl_Panic("DeleteInterpProc called with active evals");
     }
 
@@ -1482,7 +1482,8 @@ DeleteInterpProc(
      * namespace. The order is important [Bug 1658572].
      */
 
-    if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {
+    if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()
+	    && !TclInThreadExit()) {
 	Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
     }
     Tcl_PopCallFrame(interp);
@@ -1607,7 +1608,7 @@ DeleteInterpProc(
      * know which arguments will be used as scripts and which will not.
      */
 
-    if (iPtr->lineLAPtr->numEntries && !TclInExit()) {
+    if (iPtr->lineLAPtr->numEntries && !TclInExit() && !TclInThreadExit()) {
 	/*
 	 * When the interp goes away we have nothing on the stack, so there
 	 * are no arguments, so this table has to be empty.
@@ -1620,7 +1621,7 @@ DeleteInterpProc(
     ckfree((char *) iPtr->lineLAPtr);
     iPtr->lineLAPtr = NULL;
 
-    if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
+    if (iPtr->lineLABCPtr->numEntries && !TclInExit() && !TclInThreadExit()) {
 	/*
 	 * When the interp goes away we have nothing on the stack, so there
 	 * are no arguments, so this table has to be empty.
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 691c8d7..f244a1c 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -898,7 +898,7 @@ static void
 DeleteExecStack(
     ExecStack *esPtr)
 {
-    if (esPtr->markerPtr && !cachedInExit) {
+    if (esPtr->markerPtr && !cachedInExit && !TclInThreadExit()) {
 	Tcl_Panic("freeing an execStack which is still in use");
     }
 
@@ -934,10 +934,10 @@ TclDeleteExecEnv(
 
     TclDecrRefCount(eePtr->constants[0]);
     TclDecrRefCount(eePtr->constants[1]);
-    if (eePtr->callbackPtr && !cachedInExit) {
+    if (eePtr->callbackPtr && !cachedInExit && !TclInThreadExit()) {
 	Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
     }
-    if (eePtr->corPtr && !cachedInExit) {
+    if (eePtr->corPtr && !cachedInExit &&!TclInThreadExit()) {
 	Tcl_Panic("Deleting execEnv with existing coroutine");
     }
     ckfree(eePtr);
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 846618c..8ab36d0 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -2525,6 +2525,9 @@ DeleteReflectedChannelMap(
      * interpreter. They have already been marked as dead.
      */
 
+    if (TclInThreadExit()) {
+	return;
+    }
     rcmPtr = GetThreadReflectedChannelMap();
     for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
 	    hPtr != NULL;
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index fa973c7..949d42d 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -2200,6 +2200,9 @@ DeleteReflectedTransformMap(
      * interpreter. They have already been marked as dead.
      */
 
+    if (TclInThreadExit()) {
+	return;
+    }
     rtmPtr = GetThreadReflectedTransformMap();
     for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
 	    hPtr != NULL;
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 71d5a66..425c8a9 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -139,6 +139,7 @@ static void		ThreadFreeProc(ClientData clientData);
 static int		ThreadDeleteEvent(Tcl_Event *eventPtr,
 			    ClientData clientData);
 static void		ThreadExitProc(ClientData clientData);
+static void		ReleaseInterp(ClientData clientData);
 extern int		Tcltest_Init(Tcl_Interp *interp);
 
 /*
@@ -326,8 +327,9 @@ ThreadObjCmd(
 	    return TCL_ERROR;
 	}
 	ListRemove(NULL);
+	Tcl_DeleteInterp(interp);
 	Tcl_ExitThread(0);
-	return TCL_OK;
+	return TCL_ERROR;
     case THREAD_ID:
 	if (objc == 2 || objc == 3) {
 	    Tcl_Obj *idObj;
@@ -564,6 +566,7 @@ NewTestThread(
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
     int result;
     char *threadEvalScript;
+    int fullFinal = TclFullFinalizationRequested();
 
     /*
      * Initialize the interpreter. This should be more general.
@@ -614,7 +617,13 @@ NewTestThread(
      */
 
     Tcl_Preserve(tsdPtr->interp);
+    if (fullFinal) {
+	Tcl_CreateThreadExitHandler(ReleaseInterp, tsdPtr->interp);
+    }
     result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
+    if (fullFinal) {
+	Tcl_DeleteThreadExitHandler(ReleaseInterp, tsdPtr->interp);
+    }
     if (result != TCL_OK) {
 	ThreadErrorProc(tsdPtr->interp);
     }
@@ -631,6 +640,15 @@ NewTestThread(
     TCL_THREAD_CREATE_RETURN;
 }
 
+static void
+ReleaseInterp(
+    ClientData clientData)
+{
+    Tcl_Interp *interp = (Tcl_Interp *) clientData;
+
+    Tcl_Release(interp);
+}
+
 /*
  *------------------------------------------------------------------------
  *
@@ -1024,11 +1042,19 @@ ThreadEventProc(
 	errorCode = "THREAD";
 	errorInfo = "";
     } else {
+	int fullFinal = TclFullFinalizationRequested();
+
 	Tcl_Preserve(interp);
 	Tcl_ResetResult(interp);
+	if (fullFinal) {
+	    Tcl_CreateThreadExitHandler(ReleaseInterp, tsdPtr->interp);
+	}
 	Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
 	code = Tcl_GlobalEval(interp, threadEventPtr->script);
 	Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
+	if (fullFinal) {
+	    Tcl_DeleteThreadExitHandler(ReleaseInterp, tsdPtr->interp);
+	}
 	if (code != TCL_OK) {
 	    errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
 	    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);