* tests/ioCmd.test: Extended testsuite for reflected channel

	implementation. Added test cases about how it handles if the rug
	is pulled out from under a channel (= killing threads,
	interpreters containing the tcl command for a channel, and channel
	sitting in a different interpreter/thread.)

	* generic/tclIORChan.c: Fixed the bugs exposed by the new
	testcases, redone most of the cleanup and exit handling.

3 files changed, 523 insertions, 49 deletions

diff --git a/ChangeLog b/ChangeLog
index cc7b769..d1f6a7b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2008-04-24  Andreas Kupries  <andreask@activestate.com>
+
+	* tests/ioCmd.test: Extended testsuite for reflected channel
+	implementation. Added test cases about how it handles if the rug
+	is pulled out from under a channel (= killing threads,
+	interpreters containing the tcl command for a channel, and channel
+	sitting in a different interpreter/thread.)
+
+	* generic/tclIORChan.c: Fixed the bugs exposed by the new
+	testcases, redone most of the cleanup and exit handling.
+
 2008-04-21  Don Porter	<dgp@users.sourceforge.net>
 
 	* generic/tclIOUtil.c:		Removed all code delimited by
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index b57d157..0c9c96b 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIORChan.c,v 1.30 2008/04/04 17:18:31 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIORChan.c,v 1.31 2008/04/24 18:51:01 andreas_kupries Exp $
  */
 
 #include <tclInt.h>
@@ -85,7 +85,11 @@ typedef struct {
     Tcl_Channel chan;		/* Back reference to generic channel
 				 * structure. */
     Tcl_Interp *interp;		/* Reference to the interpreter containing the
-				 * Tcl level part of the channel. */
+				 * Tcl level part of the channel. NULL here
+				 * signals the channel is dead because the
+				 * interpreter/thread containing its Tcl
+				 * command is gone.
+				 */
 #ifdef TCL_THREADS
     Tcl_ThreadId thread;	/* Thread the 'interp' belongs to. */
 #endif
@@ -338,6 +342,13 @@ typedef struct ForwardingEvent {
 struct ForwardingResult {
     Tcl_ThreadId src;		/* Originating thread. */
     Tcl_ThreadId dst;		/* Thread the op was forwarded to. */
+    Tcl_Interp*  dsti;          /* Interpreter in the thread the op was forwarded to. */
+    /*
+     * Note regarding 'dsti' above: Its information is also available via the
+     * chain evPtr->rcPtr->interp, however, as can be seen, two more
+     * indirections are needed to retrieve it. And the evPtr may be gone,
+     * breaking the chain.
+     */
     Tcl_Condition done;		/* Condition variable the forwarder blocks
 				 * on. */
     int result;			/* TCL_OK or TCL_ERROR */
@@ -347,6 +358,17 @@ struct ForwardingResult {
 				 * results. */
 };
 
+typedef struct ThreadSpecificData {
+    /*
+     * Table of all reflected channels owned by this thread. This is the
+     * per-thread version of the per-interpreter map.
+     */
+
+    ReflectedChannelMap* rcmPtr;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
 /*
  * List of forwarded operations which have not completed yet, plus the mutex
  * to protect the access to this process global list.
@@ -361,16 +383,15 @@ TCL_DECLARE_MUTEX(rcForwardMutex)
  * the event function executed by the thread receiving a forwarding event
  * (which executes the appropriate function and collects the result, if any).
  *
- * The two ExitProcs are handlers so that things do not deadlock when either
- * thread involved in the forwarding exits. They also clean things up so that
- * we don't leak resources when threads go away.
+ * The ExitProc ensures that things do not deadlock when the sending thread
+ * involved in the forwarding exits. It also clean things up so that we don't
+ * leak resources when threads go away.
  */
 
 static void		ForwardOpToOwnerThread(ReflectedChannel *rcPtr,
 			    ForwardedOperation op, const VOID *param);
 static int		ForwardProc(Tcl_Event *evPtr, int mask);
 static void		SrcExitProc(ClientData clientData);
-static void		DstExitProc(ClientData clientData);
 
 #define FreeReceivedError(p) \
 	if ((p)->base.mustFree) { \
@@ -395,6 +416,10 @@ static void		DstExitProc(ClientData clientData);
 	(p)->base.msgStr = (char *) (emsg)
 
 static void		ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr);
+
+static ReflectedChannelMap *	GetThreadReflectedChannelMap(void);
+static void		DeleteThreadReflectedChannelMap(ClientData clientData);
+
 #endif /* TCL_THREADS */
 
 #define SetChannelErrorStr(c,msgStr) \
@@ -437,9 +462,10 @@ static const char *msg_write_toomuch = "{write wrote more than requested}";
 static const char *msg_write_nothing = "{write wrote nothing}";
 static const char *msg_seek_beforestart = "{Tried to seek before origin}";
 #ifdef TCL_THREADS
-static const char *msg_send_originlost = "{Origin thread lost}";
-static const char *msg_send_dstlost = "{Destination thread lost}";
+static const char *msg_send_originlost = "{Channel thread lost}";
+static const char *msg_send_dstlost    = "{Owner lost}";
 #endif /* TCL_THREADS */
+static const char *msg_dstlost    = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}";
 
 /*
  * Main methods to plug into the 'chan' ensemble'. ==================
@@ -696,6 +722,12 @@ TclChanCreateObjCmd(
 	}
     }
     Tcl_SetHashValue(hPtr, chan);
+#ifdef TCL_THREADS
+    rcmPtr = GetThreadReflectedChannelMap();
+    hPtr   = Tcl_CreateHashEntry(&rcmPtr->map,
+				 chanPtr->state->channelName, &isNew);
+    Tcl_SetHashValue(hPtr, chan);
+#endif
 
     /*
      * Return handle as result of command.
@@ -1026,8 +1058,8 @@ ReflectClose(
 	/*
 	 * THREADED => Forward this to the origin thread
 	 *
-	 * Note: Have a thread delete handler for the origin thread. Use this
-	 * to clean up the structure!
+	 * Note: DeleteThreadReflectedChannelMap() is the thread exit handler for the origin
+	 * thread. Use this to clean up the structure? Except if lost?
 	 */
 
 #ifdef TCL_THREADS
@@ -1098,12 +1130,26 @@ ReflectClose(
 	 * Remove the channel from the map before releasing the memory, to
 	 * prevent future accesses (like by 'postevent') from finding and
 	 * dereferencing a dangling pointer.
+	 *
+	 * NOTE: The channel may not be in the map. This is ok, that happens
+	 * when the channel was created in a different interpreter and/or
+	 * thread and then was moved here.
 	 */
 
 	rcmPtr = GetReflectedChannelMap (interp);
 	hPtr = Tcl_FindHashEntry (&rcmPtr->map, 
 				  Tcl_GetChannelName (rcPtr->chan));
-	Tcl_DeleteHashEntry (hPtr);
+	if (hPtr) {
+	    Tcl_DeleteHashEntry (hPtr);
+	}
+#ifdef TCL_THREADS
+        rcmPtr = GetThreadReflectedChannelMap();
+	hPtr = Tcl_FindHashEntry (&rcmPtr->map, 
+				  Tcl_GetChannelName (rcPtr->chan));
+	if (hPtr) {
+	    Tcl_DeleteHashEntry (hPtr);
+	}
+#endif
 
 	FreeReflectedChannel(rcPtr);
 #ifdef TCL_THREADS
@@ -1169,6 +1215,7 @@ ReflectInput(
 	if (p.base.code != TCL_OK) {
 	    PassReceivedError(rcPtr->chan, &p);
 	    *errorCodePtr = EINVAL;
+	    p.input.toRead = -1;
 	} else {
 	    *errorCodePtr = EOK;
 	}
@@ -1263,6 +1310,7 @@ ReflectOutput(
 	if (p.base.code != TCL_OK) {
 	    PassReceivedError(rcPtr->chan, &p);
 	    *errorCodePtr = EINVAL;
+	    p.output.toWrite = -1;
 	} else {
 	    *errorCodePtr = EOK;
 	}
@@ -1361,6 +1409,7 @@ ReflectSeekWide(
 	if (p.base.code != TCL_OK) {
 	    PassReceivedError(rcPtr->chan, &p);
 	    *errorCodePtr = EINVAL;
+	    p.seek.offset = -1;
 	} else {
 	    *errorCodePtr = EOK;
 	}
@@ -2066,9 +2115,24 @@ InvokeTclMethod(
     int result;			/* Result code of method invokation */
     Tcl_Obj *resObj = NULL;	/* Result of method invokation. */
 
+    if (!rcPtr->interp) {
+	/*
+	 * The channel is marked as dead. Bail out immediately, with an
+	 * appropriate error.
+	 */
+
+	if (resultObjPtr != NULL) {
+	    resObj = Tcl_NewStringObj(msg_dstlost,-1);
+	    *resultObjPtr = resObj;
+	    Tcl_IncrRefCount(resObj);
+	}
+	return TCL_ERROR;
+    }
+
     /*
      * NOTE (5): Decide impl. issue: Cache objects with method names? Needs
      * TSD data as reflections can be created in many different threads.
+     * NO: Caching of command resolutions means storage per channel.
      */
 
     /*
@@ -2242,11 +2306,25 @@ DeleteReflectedChannelMap(
     ReflectedChannelMap* rcmPtr; /* The map */
     Tcl_HashSearch hSearch;	 /* Search variable. */
     Tcl_HashEntry *hPtr;	 /* Search variable. */
+    ReflectedChannel* rcPtr;
+    Tcl_Channel chan;
+
+#ifdef TCL_THREADS
+    ForwardingResult *resultPtr;
+    ForwardingEvent *evPtr;
+    ForwardParam *paramPtr;
+#endif
 
     /*
-     * Delete all entries. The channels may have been closed alreay, or will
+     * Delete all entries. The channels may have been closed already, or will
      * be closed later, by the standard IO finalization of an interpreter
-     * under destruction.
+     * under destruction.  Except for the channels which were moved to a
+     * different interpreter and/or thread. They do not exist from the IO
+     * systems point of view and will not get closed. Therefore mark all as
+     * dead so that any future access will cause a proper error. For channels
+     * in a different thread we actually do the same as
+     * DeleteThreadReflectedChannelMap(), just restricted to the channels of
+     * this interp.
      */
 
     rcmPtr = clientData;
@@ -2254,13 +2332,208 @@ DeleteReflectedChannelMap(
 	 hPtr != NULL;
 	 hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
 
+	chan  = (Tcl_Channel) Tcl_GetHashValue (hPtr);
+	rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+	rcPtr->interp = NULL;
+
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(&rcmPtr->map);
     ckfree((char *) &rcmPtr->map);
+
+#ifdef TCL_THREADS
+    /*
+     * The origin interpreter for one or more reflected channels is gone.
+     */
+
+    /*
+     * Go through the list of pending results and cancel all whose events were
+     * destined for this interpreter. While this is in progress we block any
+     * other access to the list of pending results.
+     */
+
+    Tcl_MutexLock(&rcForwardMutex);
+
+    for (resultPtr = forwardList;
+	 resultPtr != NULL;
+	 resultPtr = resultPtr->nextPtr) {
+	if (resultPtr->dsti != interp) {
+	    /* Ignore results/events for other interpreters. */
+	    continue;
+	}
+
+	/*
+	 * The receiver for the event exited, before processing the event. We
+	 * detach the result now, wake the originator up and signal failure.
+	 */
+
+	evPtr = resultPtr->evPtr;
+	paramPtr = evPtr->param;
+
+	evPtr->resultPtr = NULL;
+	resultPtr->evPtr = NULL;
+	resultPtr->result = TCL_ERROR;
+
+	ForwardSetStaticError(paramPtr, msg_send_dstlost);
+
+	Tcl_ConditionNotify(&resultPtr->done);
+    }
+
+    /*
+     * Get the map of all channels handled by the current thread. This is a
+     * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
+     * through the channels and remove all which were handled by this
+     * interpreter. They have already been marked as dead.
+     */
+
+    rcmPtr = GetThreadReflectedChannelMap();
+    for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
+	 hPtr != NULL;
+	 hPtr = Tcl_NextHashEntry(&hSearch)) {
+
+	chan  = (Tcl_Channel) Tcl_GetHashValue (hPtr);
+	rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+	if (rcPtr->interp != interp) {
+	    /* Ignore entries for other interpreters */
+	    continue;
+	}
+
+	Tcl_DeleteHashEntry(hPtr);
+    }
+
+    Tcl_MutexUnlock(&rcForwardMutex);
+#endif
 }
 
 #ifdef TCL_THREADS
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetThreadReflectedChannelMap --
+ *
+ *	Gets and potentially initializes the reflected channel map for a
+ *	thread.
+ *
+ * Results:
+ *	A pointer to the map created, for use by the caller.
+ *
+ * Side effects:
+ *	Initializes the reflected channel map for a thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ReflectedChannelMap *
+GetThreadReflectedChannelMap()
+{
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    if (!tsdPtr->rcmPtr) {
+	tsdPtr->rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap));
+	Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
+	Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
+    }
+
+    return tsdPtr->rcmPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteThreadReflectedChannelMap --
+ *
+ *	Deletes the channel table for a thread. This procedure is invoked when
+ *	a thread is deleted. The channels have already been marked as dead, in
+ *      DeleteReflectedChannelMap().
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Deletes the hash table of channels.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteThreadReflectedChannelMap(
+    ClientData clientData)	/* The per-thread data structure. */
+{
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+    Tcl_HashSearch hSearch;	 /* Search variable. */
+    Tcl_HashEntry *hPtr;	 /* Search variable. */
+    Tcl_ThreadId self = Tcl_GetCurrentThread();
+
+    ReflectedChannelMap* rcmPtr; /* The map */
+    Tcl_Channel chan;
+    ReflectedChannel* rcPtr;
+    ForwardingResult *resultPtr;
+    ForwardingEvent *evPtr;
+    ForwardParam *paramPtr;
+
+    /*
+     * The origin thread for one or more reflected channels is gone.
+     * NOTE: If this function is called due to a thread getting killed the
+     *       per-interp DeleteReflectedChannelMap is apparently not called.
+     */
+
+    /*
+     * Go through the list of pending results and cancel all whose events were
+     * destined for this thread. While this is in progress we block any
+     * other access to the list of pending results.
+     */
+
+    Tcl_MutexLock(&rcForwardMutex);
+
+    for (resultPtr = forwardList;
+	 resultPtr != NULL;
+	 resultPtr = resultPtr->nextPtr) {
+	if (resultPtr->dst != self) {
+	    /* Ignore results/events for other threads. */
+	    continue;
+	}
+
+	/*
+	 * The receiver for the event exited, before processing the event. We
+	 * detach the result now, wake the originator up and signal failure.
+	 */
+
+	evPtr = resultPtr->evPtr;
+	paramPtr = evPtr->param;
+
+	evPtr->resultPtr = NULL;
+	resultPtr->evPtr = NULL;
+	resultPtr->result = TCL_ERROR;
+
+	ForwardSetStaticError(paramPtr, msg_send_dstlost);
+
+	Tcl_ConditionNotify(&resultPtr->done);
+    }
+
+    /*
+     * Get the map of all channels handled by the current thread. This is a
+     * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
+     * through the channels, remove all, mark them as dead.
+     */
+
+    rcmPtr = GetThreadReflectedChannelMap();
+    for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
+	 hPtr != NULL;
+	 hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
+
+	chan  = (Tcl_Channel) Tcl_GetHashValue (hPtr);
+	rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+	rcPtr->interp = NULL;
+
+	Tcl_DeleteHashEntry(hPtr);
+    }
+
+    Tcl_MutexUnlock(&rcForwardMutex);
+}
+
 static void
 ForwardOpToOwnerThread(
     ReflectedChannel *rcPtr,	/* Channel instance */
@@ -2273,6 +2546,24 @@ ForwardOpToOwnerThread(
     int result;
 
     /*
+     * We gather the lock early. This allows us to check the liveness of the
+     * channel without interference from DeleteThreadReflectedChannelMap().
+     */
+
+    Tcl_MutexLock(&rcForwardMutex);
+
+    if (rcPtr->interp == NULL) {
+	/*
+	 * The channel is marked as dead. Bail out immediately, with an
+	 * appropriate error. Do not forget to unlock the mutex on this path.
+	 */
+
+	ForwardSetStaticError((ForwardParam *)param, msg_send_dstlost);
+	Tcl_MutexUnlock(&rcForwardMutex);
+	return;
+    }
+
+    /*
      * Create and initialize the event and data structures.
      */
 
@@ -2285,8 +2576,9 @@ ForwardOpToOwnerThread(
     evPtr->rcPtr = rcPtr;
     evPtr->param = (ForwardParam *) param;
 
-    resultPtr->src = Tcl_GetCurrentThread();
-    resultPtr->dst = dst;
+    resultPtr->src  = Tcl_GetCurrentThread();
+    resultPtr->dst  = dst;
+    resultPtr->dsti = rcPtr->interp;
     resultPtr->done = NULL;
     resultPtr->result = -1;
     resultPtr->evPtr = evPtr;
@@ -2295,16 +2587,18 @@ ForwardOpToOwnerThread(
      * Now execute the forward.
      */
 
-    Tcl_MutexLock(&rcForwardMutex);
     TclSpliceIn(resultPtr, forwardList);
+    /* Do not unlock here. That is done by the ConditionWait */
 
     /*
-     * Ensure cleanup of the event if any of the two involved threads exits
-     * while this event is pending or in progress.
+     * Ensure cleanup of the event if the origin thread exits while this event
+     * is pending or in progress. Exitus of the destination thread is handled
+     * by DeleteThreadReflectionChannelMap(), this is set up by
+     * GetThreadReflectedChannelMap().  This is what we use the 'forwardList'
+     * (see above) for.
      */
 
     Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr);
-    Tcl_CreateThreadExitHandler(DstExitProc, (ClientData) evPtr);
 
     /*
      * Queue the event and poke the other thread's notifier.
@@ -2323,6 +2617,9 @@ ForwardOpToOwnerThread(
 	 * NOTE (1): Is it possible that the current thread goes away while
 	 * waiting here? IOW Is it possible that "SrcExitProc" is called while
 	 * we are here? See complementary note (2) in "SrcExitProc"
+	 *
+	 * The ConditionWait unlocks the mutex during the wait and relocks it
+	 * immediately after.
 	 */
 
 	Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL);
@@ -2330,6 +2627,7 @@ ForwardOpToOwnerThread(
 
     /*
      * Unlink result from the forwarder list.
+     * No need to lock. Either still locked, or locked by the ConditionWait
      */
 
     TclSpliceOut(resultPtr, forwardList);
@@ -2341,14 +2639,13 @@ ForwardOpToOwnerThread(
     Tcl_ConditionFinalize(&resultPtr->done);
 
     /*
-     * Kill the cleanup handlers now, and the result structure as well, before
+     * Kill the cleanup handler now, and the result structure as well, before
      * returning the success code.
      *
      * Note: The event structure has already been deleted.
      */
 
     Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr);
-    Tcl_DeleteThreadExitHandler(DstExitProc, (ClientData) evPtr);
 
     result = resultPtr->result;
     ckfree((char*) resultPtr);
@@ -2378,6 +2675,8 @@ ForwardProc(
     Tcl_Interp *interp = rcPtr->interp;
     ForwardParam *paramPtr = evPtr->param;
     Tcl_Obj *resObj = NULL;	/* Interp result of InvokeTclMethod */
+    ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
+    Tcl_HashEntry* hPtr;         /* Entry in the above map */
 
     /*
      * Ignore the event if no one is waiting for its result anymore.
@@ -2411,8 +2710,22 @@ ForwardProc(
 	 * Freeing is done here, in the origin thread, because the argv[]
 	 * objects belong to this thread. Deallocating them in a different
 	 * thread is not allowed
+	 *
+	 * We remove the channel from both interpreter and thread maps before
+	 * releasing the memory, to prevent future accesses (like by
+	 * 'postevent') from finding and dereferencing a dangling pointer.
 	 */
 
+	rcmPtr = GetReflectedChannelMap (interp);
+	hPtr = Tcl_FindHashEntry (&rcmPtr->map, 
+				  Tcl_GetChannelName (rcPtr->chan));
+	Tcl_DeleteHashEntry (hPtr);
+
+        rcmPtr = GetThreadReflectedChannelMap();
+	hPtr = Tcl_FindHashEntry (&rcmPtr->map, 
+				  Tcl_GetChannelName (rcPtr->chan));
+	Tcl_DeleteHashEntry (hPtr);
+
 	FreeReflectedChannel(rcPtr);
 	break;
 
@@ -2674,33 +2987,6 @@ SrcExitProc(
 }
 
 static void
-DstExitProc(
-    ClientData clientData)
-{
-    ForwardingEvent *evPtr = (ForwardingEvent *) clientData;
-    ForwardingResult *resultPtr = evPtr->resultPtr;
-    ForwardParam *paramPtr = evPtr->param;
-
-    /*
-     * NOTE (3): It is not clear if the event still exists when this handler
-     * is called. We might have to use 'resultPtr' as our clientData instead.
-     */
-
-    /*
-     * The receiver for the event exited, before processing the event. We
-     * detach the result now, wake the originator up and signal failure.
-     */
-
-    evPtr->resultPtr = NULL;
-    resultPtr->evPtr = NULL;
-    resultPtr->result = TCL_ERROR;
-
-    ForwardSetStaticError(paramPtr, msg_send_dstlost);
-
-    Tcl_ConditionNotify(&resultPtr->done);
-}
-
-static void
 ForwardSetObjError(
     ForwardParam *paramPtr,
     Tcl_Obj *obj)
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 5a0d1ba..82c9645 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -13,7 +13,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: ioCmd.test,v 1.41 2008/04/21 16:26:39 dgp Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.42 2008/04/24 18:51:01 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -779,6 +779,11 @@ test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match g
 # --- --- --- --------- --------- ---------
 # Helper commands to record the arguments to handler methods.
 
+# Stored in a script so that the threads and interpreters needing this
+# code do not need their own copy but can access this variable.
+
+set helperscript {
+
 proc note  {item}  {global res; lappend res $item; return}
 proc track {}      {upvar args item; note $item; return}
 proc notes {items} {foreach i $items {note $i}}
@@ -806,6 +811,10 @@ proc onfinal {} {
     if {[lindex $hargs 0] ne "finalize"} {return}
     return -code return ""
 }
+}
+
+# Set everything up in the main thread.
+eval $helperscript
 
 # --- --- --- --------- --------- ---------
 # method finalize
@@ -1829,6 +1838,90 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup {
     rename dummy {}
 } -returnCodes error -result {can not find reflected channel named "rc*"}
 
+# --- === *** ###########################
+# 'Pull the rug' tests. Create channel in a interpreter A, move to
+# other interpreter B, destroy the origin interpreter (A) before or
+# during access from B. Must not crash, must return proper errors.
+
+test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
+
+    set ida [interp create];#puts <<$ida>>
+    set idb [interp create];#puts <<$idb>>
+
+    # Magic to get the test* commands in the slaves
+    load {} Tcltest $ida
+    load {} Tcltest $idb
+
+    # Set up channel in interpreter
+    interp eval $ida $helperscript
+    set chan [interp eval $ida {
+	proc foo {args} {oninit seek; onfinal; track; return}
+	set chan [chan create {r w} foo]
+	fconfigure $chan -buffering none
+	set chan
+    }]
+
+    # Move channel to 2nd interpreter.
+    interp eval $ida [list testchannel cut    $chan]
+    interp eval $idb [list testchannel splice $chan]
+
+    # Kill origin interpreter, then access channel from 2nd interpreter.
+    interp delete $ida
+
+    set     res {}
+    lappend res [catch {interp eval $idb [list puts  $chan shoo]} msg] $msg
+    lappend res [catch {interp eval $idb [list tell  $chan]}      msg] $msg
+    lappend res [catch {interp eval $idb [list seek  $chan 1]}    msg] $msg
+    lappend res [catch {interp eval $idb [list gets  $chan]}      msg] $msg
+    lappend res [catch {interp eval $idb [list close $chan]}      msg] $msg
+    set res
+
+} -constraints {testchannel} \
+    -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body {
+
+    set ida [interp create];#puts <<$ida>>
+    set idb [interp create];#puts <<$idb>>
+
+    # Magic to get the test* commands in the slaves
+    load {} Tcltest $ida
+    load {} Tcltest $idb
+
+    # Set up channel in thread
+    set chan [interp eval $ida $helperscript]
+    set chan [interp eval $ida {
+	proc foo {args} {
+	    oninit; onfinal; track;
+	    # destroy interpreter during channel access
+	    # Actually not possible for an interp to destory itself.
+	    interp delete {}
+	    return}
+	set chan [chan create {r w} foo]
+	fconfigure $chan -buffering none
+	set chan
+    }]
+
+    # Move channel to 2nd thread.
+    interp eval $ida [list testchannel cut    $chan]
+    interp eval $idb [list testchannel splice $chan]
+
+    # Run access from interpreter B, this will give us a synchronous
+    # response.
+
+    interp eval $idb [list set chan $chan]
+    interp eval $idb [list set mid $tcltest::mainThread]
+    set res [interp eval $idb {
+	# wait a bit, give the main thread the time to start its event
+	# loop to wait for the response from B
+	after 2000
+	catch { puts $chan shoo } res
+	set res
+    }]
+    set res
+} -constraints {testchannel impossible} \
+    -result {Owner lost}
+
 # ### ### ### ######### ######### #########
 ## Same tests as above, but exercising the code forwarding and
 ## receiving driver operations to the originator thread.
@@ -3217,6 +3310,90 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
 } -constraints {testchannel testthread} \
     -result {{can not find reflected channel named "rc*"}}
 
+# --- === *** ###########################
+# 'Pull the rug' tests. Create channel in a thread A, move to other
+# thread B, destroy the origin thread (A) before or during access from
+# B. Must not crash, must return proper errors.
+
+test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
+
+    #puts <<$tcltest::mainThread>>main
+    set tida [testthread create];#puts <<$tida>>
+    set tidb [testthread create];#puts <<$tidb>>
+
+    # Set up channel in thread
+    testthread send $tida $helperscript
+    set chan [testthread send $tida {
+	proc foo {args} {oninit seek; onfinal; track; return}
+	set chan [chan create {r w} foo]
+	fconfigure $chan -buffering none
+	set chan
+    }]
+
+    # Move channel to 2nd thread.
+    testthread send $tida [list testchannel cut    $chan]
+    testthread send $tidb [list testchannel splice $chan]
+
+    # Kill origin thread, then access channel from 2nd thread.
+    testthread send -async $tida {testthread exit}
+    after 100
+
+    set     res {}
+    lappend res [catch {testthread send $tidb [list puts  $chan shoo]} msg] $msg
+
+    lappend res [catch {testthread send $tidb [list tell  $chan]}      msg] $msg
+    lappend res [catch {testthread send $tidb [list seek  $chan 1]}    msg] $msg
+    lappend res [catch {testthread send $tidb [list gets  $chan]}      msg] $msg
+    lappend res [catch {testthread send $tidb [list close $chan]}      msg] $msg
+    tcltest::threadReap
+    set res
+
+} -constraints {testchannel testthread} \
+    -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
+
+    #puts <<$tcltest::mainThread>>main
+    set tida [testthread create];#puts <<$tida>>
+    set tidb [testthread create];#puts <<$tidb>>
+
+    # Set up channel in thread
+    set chan [testthread send $tida $helperscript]
+    set chan [testthread send $tida {
+	proc foo {args} {
+	    oninit; onfinal; track;
+	    # destroy thread during channel access
+	    testthread exit
+	    return}
+	set chan [chan create {r w} foo]
+	fconfigure $chan -buffering none
+	set chan
+    }]
+
+    # Move channel to 2nd thread.
+    testthread send $tida [list testchannel cut    $chan]
+    testthread send $tidb [list testchannel splice $chan]
+
+    # Run access from thread B, wait for response from A (A is not
+    # using event loop at this point, so the event pile up in the
+    # queue.
+
+    testthread send $tidb [list set chan $chan]
+    testthread send $tidb [list set mid $tcltest::mainThread]
+    testthread send -async $tidb {
+	# wait a bit, give the main thread the time to start its event
+	# loop to wait for the response from B
+	after 2000
+	catch { puts $chan shoo } res
+	testthread send -async $mid [list set ::res $res]
+    }
+    vwait ::res
+
+    tcltest::threadReap
+    set res
+} -constraints {testchannel testthread} \
+    -result {Owner lost}
+
 # ### ### ### ######### ######### #########
 
 # ### ### ### ######### ######### #########