Use the Thread package instead of the [testthread] command to do

thread-enabled testing of the http package.

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):

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.

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);

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;

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;

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);

tests/http.test

@@ -51,14 +51,13 @@ if {![file exists $httpdFile]} {
     set removeHttpd 1
 }
 
-if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
-    set httpthread [testthread create "
-	source [list $httpdFile]
-	testthread wait
-    "]
-    testthread send $httpthread [list set port $port]
-    testthread send $httpthread [list set bindata $bindata]
-    testthread send $httpthread {httpd_init $port}
+catch {package require Thread 2.6}
+if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
+    set httpthread [thread::create -preserved]
+    thread::send $httpthread [list source $httpdFile]
+    thread::send $httpthread [list set port $port]
+    thread::send $httpthread [list set bindata $bindata]
+    thread::send $httpthread {httpd_init $port}
     puts "Running httpd in thread $httpthread"
 } else {
     if {![file exists $httpdFile]} {
@@ -590,9 +589,7 @@ catch {unset badurl}
 catch {unset port}
 catch {unset data}
 if {[info exists httpthread]} {
-    testthread send -async $httpthread {
-	testthread exit
-    }
+    thread::release $httpthread
 } else {
     close $listen
 }