summaryrefslogtreecommitdiffstats
path: root/generic/tclThreadTest.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclThreadTest.c')
-rw-r--r--generic/tclThreadTest.c377
1 files changed, 265 insertions, 112 deletions
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index e8363da..02ee038 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -7,17 +7,17 @@
* Conservation Through Innovation, Limited, with their permission.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 2006-2008 by Joe Mistachkin. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclThreadTest.c,v 1.24 2006/09/22 14:45:48 dkf Exp $
*/
+#ifndef USE_TCL_STUBS
+# define USE_TCL_STUBS
+#endif
#include "tclInt.h"
-extern int Tcltest_Init(Tcl_Interp *interp);
-
#ifdef TCL_THREADS
/*
* Each thread has an single instance of the following structure. There is one
@@ -31,11 +31,13 @@ extern int Tcltest_Init(Tcl_Interp *interp);
*/
typedef struct ThreadSpecificData {
- Tcl_ThreadId threadId; /* Tcl ID for this thread */
- Tcl_Interp *interp; /* Main interpreter for this thread */
- int flags; /* See the TP_ defines below... */
- struct ThreadSpecificData *nextPtr; /* List for "thread names" */
- struct ThreadSpecificData *prevPtr; /* List for "thread names" */
+ Tcl_ThreadId threadId; /* Tcl ID for this thread */
+ Tcl_Interp *interp; /* Main interpreter for this thread */
+ int flags; /* See the TP_ defines below... */
+ struct ThreadSpecificData *nextPtr;
+ /* List for "thread names" */
+ struct ThreadSpecificData *prevPtr;
+ /* List for "thread names" */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
@@ -44,22 +46,23 @@ static Tcl_ThreadDataKey dataKey;
* protected by threadMutex.
*/
-static struct ThreadSpecificData *threadList;
+static ThreadSpecificData *threadList = NULL;
/*
* The following bit-values are legal for the "flags" field of the
* ThreadSpecificData structure.
*/
-#define TP_Dying 0x001 /* This thread is being cancelled */
+
+#define TP_Dying 0x001 /* This thread is being canceled */
/*
* An instance of the following structure contains all information that is
* passed into a new thread when the thread is created using either the
- * "thread create" Tcl command or the TclCreateThread() C function.
+ * "thread create" Tcl command or the ThreadCreate() C function.
*/
typedef struct ThreadCtrl {
- char *script; /* The Tcl command this thread should
+ const char *script; /* The Tcl command this thread should
* execute */
int flags; /* Initial value of the "flags" field in the
* ThreadSpecificData structure for the new
@@ -105,6 +108,7 @@ static ThreadEventResult *resultList;
* This is for simple error handling when a thread script exits badly.
*/
+static Tcl_ThreadId mainThreadId;
static Tcl_ThreadId errorThreadId;
static char *errorProcString;
@@ -115,23 +119,18 @@ static char *errorProcString;
TCL_DECLARE_MUTEX(threadMutex)
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-EXTERN int TclThread_Init(Tcl_Interp *interp);
-EXTERN int Tcl_ThreadObjCmd(ClientData clientData,
+static int ThreadObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-EXTERN int TclCreateThread(Tcl_Interp *interp, char *script,
+static int ThreadCreate(Tcl_Interp *interp, const char *script,
int joinable);
-EXTERN int TclThreadList(Tcl_Interp *interp);
-EXTERN int TclThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
- char *script, int wait);
+static int ThreadList(Tcl_Interp *interp);
+static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
+ const char *script, int wait);
+static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
+ const char *result, int flags);
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
-
-Tcl_ThreadCreateType NewTestThread(ClientData clientData);
+static Tcl_ThreadCreateType NewTestThread(ClientData clientData);
static void ListRemove(ThreadSpecificData *tsdPtr);
static void ListUpdateInner(ThreadSpecificData *tsdPtr);
static int ThreadEventProc(Tcl_Event *evPtr, int mask);
@@ -140,6 +139,7 @@ static void ThreadFreeProc(ClientData clientData);
static int ThreadDeleteEvent(Tcl_Event *eventPtr,
ClientData clientData);
static void ThreadExitProc(ClientData clientData);
+extern int Tcltest_Init(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
@@ -149,7 +149,7 @@ static void ThreadExitProc(ClientData clientData);
* Initialize the test thread command.
*
* Results:
- * TCL_OK if the package was properly initialized.
+ * TCL_OK if the package was properly initialized.
*
* Side effects:
* Add the "testthread" command to the interp.
@@ -161,9 +161,17 @@ int
TclThread_Init(
Tcl_Interp *interp) /* The current Tcl interpreter */
{
+ /*
+ * If the main thread Id has not been set, do it now.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ if (mainThreadId == 0) {
+ mainThreadId = Tcl_GetCurrentThread();
+ }
+ Tcl_MutexUnlock(&threadMutex);
- Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd,
- (ClientData) NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
return TCL_OK;
}
@@ -171,15 +179,17 @@ TclThread_Init(
/*
*----------------------------------------------------------------------
*
- * Tcl_ThreadObjCmd --
+ * ThreadObjCmd --
*
* This procedure is invoked to process the "testthread" Tcl command. See
* the user documentation for details on what it does.
*
+ * thread cancel ?-unwind? id ?result?
* thread create ?-joinable? ?script?
- * thread send id ?-async? script
+ * thread send ?-async? id script
+ * thread event
* thread exit
- * thread info id
+ * thread id ?-main?
* thread names
* thread wait
* thread errorproc proc
@@ -195,8 +205,8 @@ TclThread_Init(
*/
/* ARGSUSED */
-int
-Tcl_ThreadObjCmd(
+static int
+ThreadObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -204,17 +214,19 @@ Tcl_ThreadObjCmd(
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
- static const char *threadOptions[] = {
- "create", "exit", "id", "join", "names",
- "send", "wait", "errorproc", NULL
+ static const char *const threadOptions[] = {
+ "cancel", "create", "event", "exit", "id",
+ "join", "names", "send", "wait", "errorproc",
+ NULL
};
enum options {
- THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
- THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
+ THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT,
+ THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND,
+ THREAD_WAIT, THREAD_ERRORPROC
};
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
@@ -235,8 +247,36 @@ Tcl_ThreadObjCmd(
}
switch ((enum options)option) {
+ case THREAD_CANCEL: {
+ long id;
+ const char *result;
+ int flags, arg;
+
+ if ((objc < 3) || (objc > 5)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?");
+ return TCL_ERROR;
+ }
+ flags = 0;
+ arg = 2;
+ if ((objc == 4) || (objc == 5)) {
+ if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) {
+ flags = TCL_CANCEL_UNWIND;
+ arg++;
+ }
+ }
+ if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ arg++;
+ if (arg < objc) {
+ result = Tcl_GetString(objv[arg]);
+ } else {
+ result = NULL;
+ }
+ return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
+ }
case THREAD_CREATE: {
- char *script;
+ const char *script;
int joinable, len;
if (objc == 2) {
@@ -254,9 +294,8 @@ Tcl_ThreadObjCmd(
script = Tcl_GetStringFromObj(objv[2], &len);
- if ((len > 1) &&
- (script [0] == '-') && (script [1] == 'j') &&
- (0 == strncmp (script, "-joinable", (size_t) len))) {
+ if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
+ (0 == strncmp(script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
@@ -272,17 +311,14 @@ Tcl_ThreadObjCmd(
*/
script = Tcl_GetStringFromObj(objv[2], &len);
-
- joinable = ((len > 1) &&
- (script [0] == '-') && (script [1] == 'j') &&
- (0 == strncmp(script, "-joinable", (size_t) len)));
-
+ joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
+ && (0 == strncmp(script, "-joinable", (size_t) len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
- return TclCreateThread(interp, script, joinable);
+ return ThreadCreate(interp, script, joinable);
}
case THREAD_EXIT:
if (objc > 2) {
@@ -293,8 +329,24 @@ Tcl_ThreadObjCmd(
Tcl_ExitThread(0);
return TCL_OK;
case THREAD_ID:
- if (objc == 2) {
- Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());
+ if (objc == 2 || objc == 3) {
+ Tcl_Obj *idObj;
+
+ /*
+ * Check if they want the main thread id or the current thread id.
+ */
+
+ if (objc == 2) {
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ } else if (objc == 3
+ && strcmp("-main", Tcl_GetString(objv[2])) == 0) {
+ Tcl_MutexLock(&threadMutex);
+ idObj = Tcl_NewLongObj((long)(size_t)mainThreadId);
+ Tcl_MutexUnlock(&threadMutex);
+ } else {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
@@ -303,24 +355,24 @@ Tcl_ThreadObjCmd(
return TCL_ERROR;
}
case THREAD_JOIN: {
- long id;
+ Tcl_WideInt id;
int result, status;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id");
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
return TCL_ERROR;
}
- result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
+ result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
if (result == TCL_OK) {
- Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
} else {
- char buf [20];
+ char buf[20];
- sprintf(buf, "%ld", id);
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
}
return result;
@@ -330,10 +382,10 @@ Tcl_ThreadObjCmd(
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- return TclThreadList(interp);
+ return ThreadList(interp);
case THREAD_SEND: {
- long id;
- char *script;
+ Tcl_WideInt id;
+ const char *script;
int wait, arg;
if ((objc != 4) && (objc != 5)) {
@@ -351,19 +403,28 @@ Tcl_ThreadObjCmd(
wait = 1;
arg = 2;
}
- if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
script = Tcl_GetString(objv[arg]);
- return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
+ return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
+ }
+ case THREAD_EVENT: {
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(
+ Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
+ return TCL_OK;
}
case THREAD_ERRORPROC: {
/*
* Arrange for this proc to handle thread death errors.
*/
- char *proc;
+ const char *proc;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
@@ -375,15 +436,41 @@ Tcl_ThreadObjCmd(
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
- errorProcString = ckalloc(strlen(proc)+1);
+ errorProcString = ckalloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
case THREAD_WAIT:
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "");
+ return TCL_ERROR;
+ }
while (1) {
+ /*
+ * If the script has been unwound, bail out immediately. This does
+ * not follow the recommended guidelines for how extensions should
+ * handle the script cancellation functionality because this is
+ * not a "normal" extension. Most extensions do not have a command
+ * that simply enters an infinite Tcl event loop. Normal
+ * extensions should not specify the TCL_CANCEL_UNWIND when
+ * calling Tcl_Canceled to check if the command has been canceled.
+ */
+
+ if (Tcl_Canceled(interp,
+ TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
+ break;
+ }
(void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
}
+
+ /*
+ * If we get to this point, we have been canceled by another thread,
+ * which is considered to be an "error".
+ */
+
+ ThreadErrorProc(interp);
+ return TCL_OK;
}
return TCL_OK;
}
@@ -391,7 +478,7 @@ Tcl_ThreadObjCmd(
/*
*----------------------------------------------------------------------
*
- * TclCreateThread --
+ * ThreadCreate --
*
* This procedure is invoked to create a thread containing an interp to
* run a script. This returns after the thread has started executing.
@@ -406,10 +493,10 @@ Tcl_ThreadObjCmd(
*/
/* ARGSUSED */
-int
-TclCreateThread(
+static int
+ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
- char *script, /* Script to execute */
+ const char *script, /* Script to execute */
int joinable) /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
@@ -425,8 +512,7 @@ TclCreateThread(
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
- Tcl_AppendResult(interp, "can't create a new thread", NULL);
- ckfree((char *) ctrl.script);
+ Tcl_AppendResult(interp, "can't create a new thread", NULL);
return TCL_ERROR;
}
@@ -437,7 +523,7 @@ TclCreateThread(
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
- Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id));
return TCL_OK;
}
@@ -473,18 +559,20 @@ Tcl_ThreadCreateType
NewTestThread(
ClientData clientData)
{
- ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
+ ThreadCtrl *ctrlPtr = clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
/*
- * Initialize the interpreter. This should be more general.
+ * Initialize the interpreter. This should be more general.
*/
tsdPtr->interp = Tcl_CreateInterp();
result = Tcl_Init(tsdPtr->interp);
- result = TclThread_Init(tsdPtr->interp);
+ if (result != TCL_OK) {
+ ThreadErrorProc(tsdPtr->interp);
+ }
/*
* This is part of the test facility. Initialize _ALL_ test commands for
@@ -492,6 +580,9 @@ NewTestThread(
*/
result = Tcltest_Init(tsdPtr->interp);
+ if (result != TCL_OK) {
+ ThreadErrorProc(tsdPtr->interp);
+ }
/*
* Update the list of threads.
@@ -505,10 +596,10 @@ NewTestThread(
* eval'ing, for the case that we exit during evaluation
*/
- threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1);
+ threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
- Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
+ Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
/*
* Notify the parent we are alive.
@@ -521,7 +612,7 @@ NewTestThread(
* Run the script.
*/
- Tcl_Preserve((ClientData) tsdPtr->interp);
+ Tcl_Preserve(tsdPtr->interp);
result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
@@ -531,9 +622,9 @@ NewTestThread(
* Clean up.
*/
- ListRemove(tsdPtr);
- Tcl_Release((ClientData) tsdPtr->interp);
Tcl_DeleteInterp(tsdPtr->interp);
+ Tcl_Release(tsdPtr->interp);
+ ListRemove(tsdPtr);
Tcl_ExitThread(result);
TCL_THREAD_CREATE_RETURN;
@@ -563,7 +654,8 @@ ThreadErrorProc(
const char *errorInfo, *argv[3];
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
+
+ sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
@@ -578,7 +670,7 @@ ThreadErrorProc(
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
- TclThreadSend(interp, errorThreadId, script, 0);
+ ThreadSend(interp, errorThreadId, script, 0);
ckfree(script);
}
}
@@ -651,13 +743,14 @@ ListRemove(
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
+ tsdPtr->interp = NULL;
Tcl_MutexUnlock(&threadMutex);
}
/*
*------------------------------------------------------------------------
*
- * TclThreadList --
+ * ThreadList --
*
* Return a list of threads running Tcl interpreters.
*
@@ -669,8 +762,8 @@ ListRemove(
*
*------------------------------------------------------------------------
*/
-int
-TclThreadList(
+static int
+ThreadList(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr;
@@ -680,7 +773,7 @@ TclThreadList(
Tcl_MutexLock(&threadMutex);
for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewLongObj((long) tsdPtr->threadId));
+ Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId));
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetObjResult(interp, listPtr);
@@ -690,7 +783,7 @@ TclThreadList(
/*
*------------------------------------------------------------------------
*
- * TclThreadSend --
+ * ThreadSend --
*
* Send a script to another thread.
*
@@ -703,11 +796,11 @@ TclThreadList(
*------------------------------------------------------------------------
*/
-int
-TclThreadSend(
+static int
+ThreadSend(
Tcl_Interp *interp, /* The current interpreter. */
Tcl_ThreadId id, /* Thread Id of other interpreter. */
- char *script, /* The script to evaluate. */
+ const char *script, /* The script to evaluate. */
int wait) /* If 1, we block for the result. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -740,7 +833,7 @@ TclThreadSend(
*/
if (threadId == Tcl_GetCurrentThread()) {
- Tcl_MutexUnlock(&threadMutex);
+ Tcl_MutexUnlock(&threadMutex);
return Tcl_GlobalEval(interp, script);
}
@@ -748,13 +841,13 @@ TclThreadSend(
* Create the event for its event queue.
*/
- threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
+ threadEventPtr = ckalloc(sizeof(ThreadEvent));
threadEventPtr->script = ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
- resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
+ resultPtr = ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
@@ -787,7 +880,7 @@ TclThreadSend(
*/
threadEventPtr->event.proc = ThreadEventProc;
- Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
+ Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
TCL_QUEUE_TAIL);
Tcl_ThreadAlert(threadId);
@@ -802,7 +895,7 @@ TclThreadSend(
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
- Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
+ Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
/*
@@ -833,11 +926,12 @@ TclThreadSend(
ckfree(resultPtr->errorInfo);
}
}
- Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
+ Tcl_AppendResult(interp, resultPtr->result, NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
- ckfree((char *) resultPtr);
+ ckfree(resultPtr->result);
+ ckfree(resultPtr);
return code;
}
@@ -845,6 +939,62 @@ TclThreadSend(
/*
*------------------------------------------------------------------------
*
+ * ThreadCancel --
+ *
+ * Cancels a script in another thread.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *------------------------------------------------------------------------
+ */
+
+static int
+ThreadCancel(
+ Tcl_Interp *interp, /* The current interpreter. */
+ Tcl_ThreadId id, /* Thread Id of other interpreter. */
+ const char *result, /* The result or NULL for default. */
+ int flags) /* Flags for Tcl_CancelEval. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int found;
+ Tcl_ThreadId threadId = (Tcl_ThreadId) id;
+
+ /*
+ * Verify the thread exists.
+ */
+
+ Tcl_MutexLock(&threadMutex);
+ found = 0;
+ for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
+ if (tsdPtr->threadId == threadId) {
+ found = 1;
+ break;
+ }
+ }
+ if (!found) {
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_AppendResult(interp, "invalid thread id", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Since Tcl_CancelEval can be safely called from any thread,
+ * we do it now.
+ */
+
+ Tcl_MutexUnlock(&threadMutex);
+ Tcl_ResetResult(interp);
+ return Tcl_CancelEval(tsdPtr->interp,
+ (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
* ThreadEventProc --
*
* Handle the event in the target thread.
@@ -864,7 +1014,7 @@ ThreadEventProc(
int mask)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
+ ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
@@ -876,13 +1026,11 @@ ThreadEventProc(
errorCode = "THREAD";
errorInfo = "";
} else {
- Tcl_Preserve((ClientData) interp);
+ Tcl_Preserve(interp);
Tcl_ResetResult(interp);
- Tcl_CreateThreadExitHandler(ThreadFreeProc,
- (ClientData) threadEventPtr->script);
+ Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
code = Tcl_GlobalEval(interp, threadEventPtr->script);
- Tcl_DeleteThreadExitHandler(ThreadFreeProc,
- (ClientData) threadEventPtr->script);
+ Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
@@ -909,7 +1057,7 @@ ThreadEventProc(
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
- Tcl_Release((ClientData) interp);
+ Tcl_Release(interp);
}
return 1;
}
@@ -937,7 +1085,7 @@ ThreadFreeProc(
ClientData clientData)
{
if (clientData) {
- ckfree((char *) clientData);
+ ckfree(clientData);
}
}
@@ -965,7 +1113,7 @@ ThreadDeleteEvent(
ClientData clientData) /* dummy */
{
if (eventPtr->proc == ThreadEventProc) {
- ckfree((char *) ((ThreadEvent *) eventPtr)->script);
+ ckfree(((ThreadEvent *) eventPtr)->script);
return 1;
}
@@ -999,17 +1147,22 @@ static void
ThreadExitProc(
ClientData clientData)
{
- char *threadEvalScript = (char *) clientData;
+ char *threadEvalScript = clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->interp != NULL) {
+ ListRemove(tsdPtr);
+ }
Tcl_MutexLock(&threadMutex);
if (threadEvalScript) {
- ckfree((char *) threadEvalScript);
+ ckfree(threadEvalScript);
threadEvalScript = NULL;
}
- Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
+ Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL);
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
@@ -1029,7 +1182,7 @@ ThreadExitProc(
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
- ckfree((char *) resultPtr);
+ ckfree(resultPtr);
} else if (resultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller. The result
@@ -1037,9 +1190,9 @@ ThreadExitProc(
* going to call free on it.
*/
- char *msg = "target thread died";
+ const char *msg = "target thread died";
- resultPtr->result = ckalloc(strlen(msg)+1);
+ resultPtr->result = ckalloc(strlen(msg) + 1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
generated by cgit v0.12 at 2025-10-31 14:10:54 (GMT)