summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-04-24 18:50:41 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-04-24 18:50:41 (GMT)
commite56b4f5bbf2cf2a602730b664a8ad82cb816ca87 (patch)
tree14872d7cb419a292119c91cfb9d856e2bf8bd881
parentc5fd5355ee987e7f3b51128bdf7272c8e571eea6 (diff)
downloadtcl-e56b4f5bbf2cf2a602730b664a8ad82cb816ca87.zip
tcl-e56b4f5bbf2cf2a602730b664a8ad82cb816ca87.tar.gz
tcl-e56b4f5bbf2cf2a602730b664a8ad82cb816ca87.tar.bz2
* 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.
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclIORChan.c382
-rw-r--r--tests/ioCmd.test179
3 files changed, 523 insertions, 49 deletions
diff --git a/ChangeLog b/ChangeLog
index 38ad2dc..618f606 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-15 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (CopyData): Applied another patch by Alexandre
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 157e712..9781a5a 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.28.2.2 2008/04/04 17:19:42 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIORChan.c,v 1.28.2.3 2008/04/24 18:50:42 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 5c6a330..fa5d058 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.36.2.4 2008/04/10 20:55:27 andreas_kupries Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.36.2.5 2008/04/24 18:50:42 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -758,6 +758,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}}
@@ -785,6 +790,10 @@ proc onfinal {} {
if {[lindex $hargs 0] ne "finalize"} {return}
return -code return ""
}
+}
+
+# Set everything up in the main thread.
+eval $helperscript
# --- --- --- --------- --------- ---------
# method finalize
@@ -1808,6 +1817,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.
@@ -3196,6 +3289,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}
+
# ### ### ### ######### ######### #########
# ### ### ### ######### ######### #########