/*
* threadCmd.c --
*
* This file implements the Tcl thread commands that allow script
* level access to threading. It will not load into a core that was
* not compiled for thread support.
*
* See http://www.tcl.tk/doc/howto/thread_model.html
*
* Some of this code is based on work done by Richard Hipp on behalf of
* Conservation Through Innovation, Limited, with their permission.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
* Copyright (c) 1999,2000 by Scriptics Corporation.
* Copyright (c) 2002 by Zoran Vasiljevic.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: threadCmd.c,v 1.100 2006/10/06 14:31:48 vasiljevic Exp $
* ----------------------------------------------------------------------------
*/
#include "tclThread.h"
#ifdef NS_AOLSERVER
# include "aolstub.cpp"
#endif
/*
* Access to the list of threads and to the thread send results
* (defined below) is guarded by this mutex.
*/
TCL_DECLARE_MUTEX(threadMutex)
/*
* Each thread has an single instance of the following structure. There
* is one instance of this structure per thread even if that thread contains
* multiple interpreters. The interpreter identified by this structure is
* the main interpreter for the thread. The main interpreter is the one that
* will process any messages received by a thread. Any interpreter can send
* messages but only the main interpreter can receive them, unless you're
* not doing asynchronous script backfiring. In such cases the caller might
* signal the thread to which interpreter the result should be delivered.
*/
typedef struct ThreadSpecificData {
Tcl_ThreadId threadId; /* The real ID of this thread */
Tcl_Interp *interp; /* Main interp for this thread */
Tcl_Condition doOneEvent; /* Signalled just before running
an event from the event loop */
int flags; /* One of the ThreadFlags below */
int refCount; /* Used for thread reservation */
int eventsPending; /* # of unprocessed events */
int maxEventsCount; /* Maximum # of pending events */
struct ThreadEventResult *result;
struct ThreadSpecificData *nextPtr;
struct ThreadSpecificData *prevPtr;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#define THREAD_FLAGS_NONE 0 /* None */
#define THREAD_FLAGS_STOPPED 1 /* Thread is being stopped */
#define THREAD_FLAGS_INERROR 2 /* Thread is in error */
#define THREAD_FLAGS_UNWINDONERROR 4 /* Thread unwinds on script error */
#define THREAD_RESERVE 1 /* Reserves the thread */
#define THREAD_RELEASE 2 /* Releases the thread */
/*
* Length of storage for building the Tcl handle for the thread.
*/
#define THREAD_HNDLPREFIX "tid"
#define THREAD_HNDLMAXLEN 32
/*
* This list is used to list all threads that have interpreters.
*/
static struct ThreadSpecificData *threadList = NULL;
/*
* Used to represent the empty result.
*/
static char *threadEmptyResult = "";
/*
* 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 ThreadCreate() C function.
*/
typedef struct ThreadCtrl {
char *script; /* Script to execute */
int flags; /* Initial value of the "flags"
* field in ThreadSpecificData */
Tcl_Condition condWait; /* Condition variable used to
* sync parent and child threads */
ClientData cd; /* Opaque ptr to pass to thread */
} ThreadCtrl;
/*
* Structure holding result of the command executed in target thread.
*/
typedef struct ThreadEventResult {
Tcl_Condition done; /* Set when the script completes */
int code; /* Return value of the function */
char *result; /* Result from the function */
char *errorInfo; /* Copy of errorInfo variable */
char *errorCode; /* Copy of errorCode variable */
Tcl_ThreadId srcThreadId; /* Id of sender, if it dies */
Tcl_ThreadId dstThreadId; /* Id of target, if it dies */
struct ThreadEvent *eventPtr; /* Back pointer */
struct ThreadEventResult *nextPtr; /* List for cleanup */
struct ThreadEventResult *prevPtr;
} ThreadEventResult;
/*
* This list links all active ThreadEventResult structures. This way
* an exiting thread can inform all threads waiting on jobs posted to
* his event queue that it is dying, so they might stop waiting.
*/
static ThreadEventResult *resultList;
/*
* This is the event used to send commands to other threads.
*/
typedef struct ThreadEvent {
Tcl_Event event; /* Must be first */
struct ThreadSendData *sendData; /* See below */
struct ThreadClbkData *clbkData; /* See below */
struct ThreadEventResult *resultPtr; /* To communicate the result back.
* NULL if we don't care about it */
} ThreadEvent;
typedef int (ThreadSendProc) _ANSI_ARGS_((Tcl_Interp*, ClientData));
typedef void (ThreadSendFree) _ANSI_ARGS_((ClientData));
static ThreadSendProc ThreadSendEval; /* Does a regular Tcl_Eval */
static ThreadSendProc ThreadClbkSetVar; /* Sets the named variable */
/*
* These structures are used to communicate commands between source and target
* threads. The ThreadSendData is used for source->target command passing,
* while the ThreadClbkData is used for doing asynchronous callbacks.
*
* Important: structures below must have first three elements indentical!
*/
typedef struct ThreadSendData {
ThreadSendProc *execProc; /* Func to exec in remote thread */
ClientData clientData; /* Ptr to pass to send function */
ThreadSendFree *freeProc; /* Function to free client data */
/* ---- */
Tcl_Interp *interp; /* Interp to run the command */
} ThreadSendData;
typedef struct ThreadClbkData {
ThreadSendProc *execProc; /* The callback function */
ClientData clientData; /* Ptr to pass to clbk function */
ThreadSendFree *freeProc; /* Function to free client data */
/* ---- */
Tcl_Interp *interp; /* Interp to run the command */
Tcl_ThreadId threadId; /* Thread where to post callback */
ThreadEventResult result; /* Returns result asynchronously */
} ThreadClbkData;
/*
* Event used to transfer a channel between threads.
*/
typedef struct TransferEvent {
Tcl_Event event; /* Must be first */
Tcl_Channel chan; /* The channel to transfer */
struct TransferResult *resultPtr; /* To communicate the result */
} TransferEvent;
typedef struct TransferResult {
Tcl_Condition done; /* Set when transfer is done */
int resultCode; /* Set to TCL_OK or TCL_ERROR when
the transfer is done. Def = -1 */
char *resultMsg; /* Initialized to NULL. Set to a
allocated string by the targer
thread in case of an error */
Tcl_ThreadId srcThreadId; /* Id of src thread, if it dies */
Tcl_ThreadId dstThreadId; /* Id of tgt thread, if it dies */
struct TransferEvent *eventPtr; /* Back pointer */
struct TransferResult *nextPtr; /* Next in the linked list */
struct TransferResult *prevPtr; /* Previous in the linked list */
} TransferResult;
static TransferResult *transferList;
/*
* This is for simple error handling when a thread script exits badly.
*/
static Tcl_ThreadId errorThreadId; /* Id of thread to post error message */
static char *errorProcString; /* Tcl script to run when reporting error */
/*
* Definition of flags for ThreadSend.
*/
#define THREAD_SEND_WAIT 1<<1
#define THREAD_SEND_HEAD 1<<2
#ifdef BUILD_thread
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLEXPORT
#endif
/*
* Miscelaneous functions used within this file
*/
static Tcl_EventDeleteProc ThreadDeleteEvent;
static Tcl_ThreadCreateType
NewThread _ANSI_ARGS_((ClientData clientData));
static ThreadSpecificData*
ThreadExistsInner _ANSI_ARGS_((Tcl_ThreadId id));
static int
ThreadInit _ANSI_ARGS_((Tcl_Interp *interp));
static int
ThreadCreate _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script,
int stacksize,
int flags,
int preserve));
static int
ThreadSend _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId id,
ThreadSendData *sendPtr,
ThreadClbkData *clbkPtr,
int flags));
static void
ThreadSetResult _ANSI_ARGS_((Tcl_Interp *interp,
int code,
ThreadEventResult *resultPtr));
static int
ThreadGetOption _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId id,
char *option,
Tcl_DString *ds));
static int
ThreadSetOption _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId id,
char *option,
char *value));
static int
ThreadReserve _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId id,
int operation,
int wait));
static int
ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
int mask));
static int
ThreadWait _ANSI_ARGS_((void));
static int
ThreadExists _ANSI_ARGS_((Tcl_ThreadId id));
static int
ThreadList _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId **thrIdArray));
static void
ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
static void
ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
static void
ThreadIdleProc _ANSI_ARGS_((ClientData clientData));
static void
ThreadExitProc _ANSI_ARGS_((ClientData clientData));
static void
ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static void
ListRemoveInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static void
ListUpdate _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static void
ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
static int
ThreadJoin _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId id));
static int
ThreadTransfer _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId id,
Tcl_Channel chan));
static int
ThreadDetach _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel chan));
static int
ThreadAttach _ANSI_ARGS_((Tcl_Interp *interp,
char *chanName));
static int
TransferEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
int mask));
static void
ThreadGetHandle _ANSI_ARGS_((Tcl_ThreadId,
char *handlePtr));
static int
ThreadGetId _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *handleObj,
Tcl_ThreadId *thrIdPtr));
static void
ErrorNoSuchThread _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_ThreadId thrId));
static void
ThreadCutChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Channel channel));
/*
* Functions implementing Tcl commands
*/
static Tcl_ObjCmdProc ThreadCreateObjCmd;
static Tcl_ObjCmdProc ThreadReserveObjCmd;
static Tcl_ObjCmdProc ThreadReleaseObjCmd;
static Tcl_ObjCmdProc ThreadSendObjCmd;
static Tcl_ObjCmdProc ThreadBroadcastObjCmd;
static Tcl_ObjCmdProc ThreadUnwindObjCmd;
static Tcl_ObjCmdProc ThreadExitObjCmd;
static Tcl_ObjCmdProc ThreadIdObjCmd;
static Tcl_ObjCmdProc ThreadNamesObjCmd;
static Tcl_ObjCmdProc ThreadWaitObjCmd;
static Tcl_ObjCmdProc ThreadExistsObjCmd;
static Tcl_ObjCmdProc ThreadConfigureObjCmd;
static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
static Tcl_ObjCmdProc ThreadJoinObjCmd;
static Tcl_ObjCmdProc ThreadTransferObjCmd;
static Tcl_ObjCmdProc ThreadDetachObjCmd;
static Tcl_ObjCmdProc ThreadAttachObjCmd;
static int
ThreadInit(interp)
Tcl_Interp *interp; /* The current Tcl interpreter */
{
Tcl_Obj *boolObjPtr;
char *msg;
int boolVar;
if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
return TCL_ERROR;
}
boolObjPtr = Tcl_GetVar2Ex(interp, "::tcl_platform", "threaded", 0);
if (boolObjPtr == NULL
|| Tcl_GetBooleanFromObj(interp, boolObjPtr, &boolVar) != TCL_OK
|| boolVar == 0) {
msg = "Tcl core wasn't compiled for threading.";
Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
return TCL_ERROR;
}
/*
* We seem to have a Tcl core compiled with threads enabled.
*/
TCL_CMD(interp, THNS"create", ThreadCreateObjCmd);
TCL_CMD(interp, THNS"send", ThreadSendObjCmd);
TCL_CMD(interp, THNS"broadcast", ThreadBroadcastObjCmd);
TCL_CMD(interp, THNS"exit", ThreadExitObjCmd);
TCL_CMD(interp, THNS"unwind", ThreadUnwindObjCmd);
TCL_CMD(interp, THNS"id", ThreadIdObjCmd);
TCL_CMD(interp, THNS"names", ThreadNamesObjCmd);
TCL_CMD(interp, THNS"exists", ThreadExistsObjCmd);
TCL_CMD(interp, THNS"wait", ThreadWaitObjCmd);
TCL_CMD(interp, THNS"configure", ThreadConfigureObjCmd);
TCL_CMD(interp, THNS"errorproc", ThreadErrorProcObjCmd);
TCL_CMD(interp, THNS"preserve", ThreadReserveObjCmd);
TCL_CMD(interp, THNS"release", ThreadReleaseObjCmd);
TCL_CMD(interp, THNS"join", ThreadJoinObjCmd);
TCL_CMD(interp, THNS"transfer", ThreadTransferObjCmd);
TCL_CMD(interp, THNS"detach", ThreadDetachObjCmd);
TCL_CMD(interp, THNS"attach", ThreadAttachObjCmd);
/*
* Add shared variable commands
*/
Sv_Init(interp);
/*
* Add commands to access thread
* synchronization primitives.
*/
Sp_Init(interp);
/*
* Add threadpool commands.
*/
Tpool_Init(interp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Thread_Init --
*
* Initialize the thread commands.
*
* Results:
* TCL_OK if the package was properly initialized.
*
* Side effects:
* Adds package commands to the current interp.
*
*----------------------------------------------------------------------
*/
EXTERN int
Thread_Init(interp)
Tcl_Interp *interp; /* The current Tcl interpreter */
{
int status = ThreadInit(interp);
if (status != TCL_OK) {
return status;
}
return Tcl_PkgProvide(interp, "Thread", PACKAGE_VERSION);
}
/*
*----------------------------------------------------------------------
*
* Thread_SafeInit --
*
* This function is called from within initialization of the safe
* Tcl interpreter.
*
* Results:
* Standard Tcl result
*
* Side effects:
* Commands added to the current interpreter,
*
*----------------------------------------------------------------------
*/
EXTERN int
Thread_SafeInit(interp)
Tcl_Interp *interp;
{
return Thread_Init(interp);
}
/*
*----------------------------------------------------------------------
*
* Init --
*
* Make sure internal list of threads references the current thread.
*
* Results:
* None
*
* Side effects:
* The list of threads is initialized to include the current thread.
*
*----------------------------------------------------------------------
*/
static void
Init(interp)
Tcl_Interp *interp; /* Current interpreter. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->interp == (Tcl_Interp*)NULL) {
memset(tsdPtr, 0, sizeof(ThreadSpecificData));
tsdPtr->interp = interp;
ListUpdate(tsdPtr);
Tcl_CreateThreadExitHandler(ThreadExitProc,
(ClientData)threadEmptyResult);
}
}
/*
*----------------------------------------------------------------------
*
* ThreadCreateObjCmd --
*
* This procedure is invoked to process the "thread::create" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadCreateObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int argc, rsrv = 0;
char *arg, *script;
int flags = TCL_THREAD_NOFLAGS;
Init(interp);
/*
* Syntax: thread::create ?-joinable? ?-preserved? ?script?
*/
script = THNS"wait";
for (argc = 1; argc < objc; argc++) {
arg = Tcl_GetStringFromObj(objv[argc], NULL);
if (OPT_CMP(arg, "--")) {
argc++;
if ((argc + 1) == objc) {
script = Tcl_GetStringFromObj(objv[argc], NULL);
} else {
goto usage;
}
break;
} else if (OPT_CMP(arg, "-joinable")) {
flags |= TCL_THREAD_JOINABLE;
} else if (OPT_CMP(arg, "-preserved")) {
rsrv = 1;
} else if ((argc + 1) == objc) {
script = Tcl_GetStringFromObj(objv[argc], NULL);
} else {
goto usage;
}
}
return ThreadCreate(interp, script, TCL_THREAD_STACK_DEFAULT, flags, rsrv);
usage:
Tcl_WrongNumArgs(interp, 1, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ThreadReserveObjCmd --
*
* This procedure is invoked to process the "thread::preserve" and
* "thread::release" Tcl commands, depending on the flag passed by
* the ClientData argument. See the user documentation for details
* on what those command do.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadReserveObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_ThreadId thrId = (Tcl_ThreadId)0;
Init(interp);
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?threadId?");
return TCL_ERROR;
}
if (objc == 2) {
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
}
return ThreadReserve(interp, thrId, THREAD_RESERVE, 0);
}
/*
*----------------------------------------------------------------------
*
* ThreadReleaseObjCmd --
*
* This procedure is invoked to process the "thread::release" Tcl
* command. See the user documentation for details on what this
* command does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadReleaseObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int wait = 0;
Tcl_ThreadId thrId = (Tcl_ThreadId)0;
Init(interp);
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-wait? ?threadId?");
return TCL_ERROR;
}
if (objc > 1) {
if (OPT_CMP(Tcl_GetString(objv[1]), "-wait")) {
wait = 1;
if (ThreadGetId(interp, objv[2], &thrId) != TCL_OK) {
return TCL_ERROR;
}
} else if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
}
return ThreadReserve(interp, thrId, THREAD_RELEASE, wait);
}
/*
*----------------------------------------------------------------------
*
* ThreadUnwindObjCmd --
*
* This procedure is invoked to process the "thread::unwind" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadUnwindObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return ThreadReserve(interp, 0, THREAD_RELEASE, 0);
}
/*
*----------------------------------------------------------------------
*
* ThreadExitObjCmd --
*
* This procedure is invoked to process the "thread::exit" Tcl
* command. This causes an unconditional close of the thread
* and is GUARENTEED to cause memory leaks. Use this with caution.
*
* Results:
* Doesn't actually return.
*
* Side effects:
* Lots. improper clean up of resources.
*
*----------------------------------------------------------------------
*/
static int
ThreadExitObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Init(interp);
ListRemove(NULL);
Tcl_ExitThread(666);
return TCL_OK; /* NOT REACHED */
}
/*
*----------------------------------------------------------------------
*
* ThreadIdObjCmd --
*
* This procedure is invoked to process the "thread::id" Tcl command.
* This returns the ID of the current thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadIdObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char thrHandle[THREAD_HNDLMAXLEN];
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadNamesObjCmd --
*
* This procedure is invoked to process the "thread::names" Tcl
* command. This returns a list of all known thread IDs.
* These are only threads created via this module (e.g., not
* driver threads or the notifier).
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadNamesObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ii, length;
char *result, thrHandle[THREAD_HNDLMAXLEN];
Tcl_ThreadId *thrIdArray;
Tcl_DString threadNames;
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
length = ThreadList(interp, &thrIdArray);
if (length == 0) {
return TCL_OK;
}
Tcl_DStringInit(&threadNames);
for (ii = 0; ii < length; ii++) {
ThreadGetHandle(thrIdArray[ii], thrHandle);
Tcl_DStringAppendElement(&threadNames, thrHandle);
}
length = Tcl_DStringLength(&threadNames);
result = Tcl_DStringValue(&threadNames);
Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length));
Tcl_DStringFree(&threadNames);
Tcl_Free((char*)thrIdArray);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSendObjCmd --
*
* This procedure is invoked to process the "thread::send" Tcl
* command. This sends a script to another thread for execution.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadSendObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ret, len, vlen = 0, ii = 0, flags = 0;
Tcl_ThreadId thrId;
char *script, *arg, *var = NULL;
ThreadClbkData *clbkPtr = NULL;
ThreadSendData *sendPtr = NULL;
Init(interp);
/*
* Syntax: thread::send ?-async? ?-head? threadId script ?varName?
*/
if (objc < 3 || objc > 6) {
goto usage;
}
flags = THREAD_SEND_WAIT;
for (ii = 1; ii < objc; ii++) {
arg = Tcl_GetStringFromObj(objv[ii], NULL);
if (OPT_CMP(arg, "-async")) {
flags &= ~THREAD_SEND_WAIT;
} else if (OPT_CMP(arg, "-head")) {
flags |= THREAD_SEND_HEAD;
} else {
break;
}
}
if (ii >= objc) {
goto usage;
}
if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) {
return TCL_ERROR;
}
if (++ii >= objc) {
goto usage;
}
script = Tcl_GetStringFromObj(objv[ii], &len);
if (++ii < objc) {
var = Tcl_GetStringFromObj(objv[ii], &vlen);
}
if (var && (flags & THREAD_SEND_WAIT) == 0) {
if (thrId == Tcl_GetCurrentThread()) {
/*
* FIXME: Do something for callbacks to self
*/
Tcl_SetResult(interp, "can't notify self", TCL_STATIC);
return TCL_ERROR;
}
/*
* Prepare record for the callback. This is asynchronously
* posted back to us when the target thread finishes processing.
* We should do a vwait on the "var" to get notified.
*/
clbkPtr = (ThreadClbkData*)Tcl_Alloc(sizeof(ThreadClbkData));
clbkPtr->execProc = ThreadClbkSetVar;
clbkPtr->freeProc = (ThreadSendFree*)Tcl_Free;
clbkPtr->interp = interp;
clbkPtr->threadId = Tcl_GetCurrentThread();
clbkPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+vlen), var);
}
/*
* Prepare job record for the target thread
*/
sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData));
sendPtr->interp = NULL; /* Signal to use thread main interp */
sendPtr->execProc = ThreadSendEval;
sendPtr->freeProc = (ThreadSendFree*)Tcl_Free;
sendPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+len), script);
ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags);
if (var && (flags & THREAD_SEND_WAIT)) {
/*
* Leave job's result in passed variable
* and return the code, like "catch" does.
*/
Tcl_Obj *resultObj = Tcl_GetObjResult(interp);
if (!Tcl_SetVar2Ex(interp, var, NULL, resultObj, TCL_LEAVE_ERR_MSG)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
return TCL_OK;
}
return ret;
usage:
Tcl_WrongNumArgs(interp,1,objv,"?-async? ?-head? id script ?varName?");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ThreadBroadcastObjCmd --
*
* This procedure is invoked to process the "thread::broadcast" Tcl
* command. This asynchronously sends a script to all known threads.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Script is sent to all known threads except the caller thread.
*
*----------------------------------------------------------------------
*/
static int
ThreadBroadcastObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ii, len, nthreads;
char *script;
Tcl_ThreadId *thrIdArray;
ThreadSendData *sendPtr, job;
Init(interp);
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "script");
return TCL_ERROR;
}
script = Tcl_GetStringFromObj(objv[1], &len);
/*
* Get the list of known threads. Note that this one may
* actually change (thread may exit or otherwise cease to
* exist) while we circle in the loop below. We really do
* not care about that here since we don't return any
* script results to the caller.
*/
nthreads = ThreadList(interp, &thrIdArray);
if (nthreads == 0) {
return TCL_OK;
}
/*
* Prepare the structure with the job description
* to be sent asynchronously to each known thread.
*/
job.interp = NULL; /* Signal to use thread's main interp */
job.execProc = ThreadSendEval;
job.freeProc = (ThreadSendFree*)Tcl_Free;
job.clientData = NULL;
/*
* Now, circle this list and send each thread the script.
* This is sent asynchronously, since we do not care what
* are they going to do with it. Also, the event is queued
* to the head of the event queue (as out-of-band message).
*/
for (ii = 0; ii < nthreads; ii++) {
if (thrIdArray[ii] == Tcl_GetCurrentThread()) {
continue; /* Do not broadcast self */
}
sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData));
*sendPtr = job;
sendPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+len), script);
ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD);
}
Tcl_Free((char*)thrIdArray);
Tcl_ResetResult(interp);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadWaitObjCmd --
*
* This procedure is invoked to process the "thread::wait" Tcl
* command. This enters the event loop.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Enters the event loop.
*
*----------------------------------------------------------------------
*/
static int
ThreadWaitObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Init(interp);
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return ThreadWait();
}
/*
*----------------------------------------------------------------------
*
* ThreadErrorProcObjCmd --
*
* This procedure is invoked to process the "thread::errorproc"
* command. This registers a procedure to handle thread errors.
* Empty string as the name of the procedure will reset the
* default behaviour, which is writing to standard error channel.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Registers an errorproc.
*
*----------------------------------------------------------------------
*/
static int
ThreadErrorProcObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int len;
char *proc;
Init(interp);
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?proc?");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
if (objc == 1) {
if (errorProcString) {
Tcl_SetResult(interp, errorProcString, TCL_VOLATILE);
}
} else {
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
Tcl_Free(errorProcString);
}
proc = Tcl_GetStringFromObj(objv[1], &len);
if (len == 0) {
errorProcString = NULL;
} else {
errorProcString = Tcl_Alloc(1+strlen(proc));
strcpy(errorProcString, proc);
}
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadJoinObjCmd --
*
* This procedure is invoked to process the "thread::join" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadJoinObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_ThreadId thrId;
Init(interp);
/*
* Syntax of 'join': id
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "id");
return TCL_ERROR;
}
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
return ThreadJoin(interp, thrId);
}
/*
*----------------------------------------------------------------------
*
* ThreadTransferObjCmd --
*
* This procedure is invoked to process the "thread::transfer" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadTransferObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_ThreadId thrId;
Tcl_Channel chan;
Init(interp);
/*
* Syntax of 'transfer': id channel
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "id channel");
return TCL_ERROR;
}
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL);
if (chan == (Tcl_Channel)NULL) {
return TCL_ERROR;
}
return ThreadTransfer(interp, thrId, Tcl_GetTopChannel(chan));
}
/*
*----------------------------------------------------------------------
*
* ThreadDetachObjCmd --
*
* This procedure is invoked to process the "thread::detach" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadDetachObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan;
Init(interp);
/*
* Syntax: thread::detach channel
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == (Tcl_Channel)NULL) {
return TCL_ERROR;
}
return ThreadDetach(interp, Tcl_GetTopChannel(chan));
}
/*
*----------------------------------------------------------------------
*
* ThreadAttachObjCmd --
*
* This procedure is invoked to process the "thread::attach" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadAttachObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *chanName;
Init(interp);
/*
* Syntax: thread::attach channel
*/
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "channel");
return TCL_ERROR;
}
chanName = Tcl_GetString(objv[1]);
if (Tcl_IsChannelExisting(chanName)) {
return TCL_OK;
}
return ThreadAttach(interp, chanName);
}
/*
*----------------------------------------------------------------------
*
* ThreadExistsObjCmd --
*
* This procedure is invoked to process the "thread::exists" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadExistsObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_ThreadId thrId;
Init(interp);
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "id");
return TCL_ERROR;
}
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), ThreadExists(thrId));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadConfigureObjCmd --
*
* This procedure is invoked to process the Tcl "thread::configure"
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*----------------------------------------------------------------------
*/
static int
ThreadConfigureObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *option, *value;
Tcl_ThreadId thrId; /* Id of the thread to configure */
int i; /* Iterate over arg-value pairs. */
Tcl_DString ds; /* DString to hold result of
* calling GetThreadOption. */
if (objc < 2 || (objc % 2 == 1 && objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "threadlId ?optionName? "
"?value? ?optionName value?...");
return TCL_ERROR;
}
Init(interp);
if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 2) {
Tcl_DStringInit(&ds);
if (ThreadGetOption(interp, thrId, NULL, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
if (objc == 3) {
Tcl_DStringInit(&ds);
option = Tcl_GetString(objv[2]);
if (ThreadGetOption(interp, thrId, option, &ds) != TCL_OK) {
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
Tcl_DStringResult(interp, &ds);
return TCL_OK;
}
for (i = 3; i < objc; i += 2) {
option = Tcl_GetString(objv[i-1]);
value = Tcl_GetString(objv[i]);
if (ThreadSetOption(interp, thrId, option, value) != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSendEval --
*
* Evaluates Tcl script passed from source to target thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadSendEval(interp, clientData)
Tcl_Interp *interp;
ClientData clientData;
{
ThreadSendData *sendPtr = (ThreadSendData*)clientData;
char *script = (char*)sendPtr->clientData;
return Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
}
/*
*----------------------------------------------------------------------
*
* ThreadClbkSetVar --
*
* Sets the Tcl variable in the source thread, as the result
* of the asynchronous callback.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* New Tcl variable may be created
*
*----------------------------------------------------------------------
*/
static int
ThreadClbkSetVar(interp, clientData)
Tcl_Interp *interp;
ClientData clientData;
{
ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData;
char *var = (char*)clbkPtr->clientData;
Tcl_Obj *valObj;
ThreadEventResult *resultPtr = &clbkPtr->result;
/*
* Get the result of the posted command.
* We will use it to fill-in the result variable.
*/
valObj = Tcl_NewStringObj(resultPtr->result, -1);
if (resultPtr->result != threadEmptyResult) {
Tcl_Free(resultPtr->result);
}
/*
* Set the result variable
*/
if (Tcl_SetVar2Ex(interp, var, NULL, valObj,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
/*
* In case of error, trigger the bgerror mechansim
*/
if (resultPtr->code == TCL_ERROR) {
if (resultPtr->errorCode) {
var = "errorCode";
Tcl_SetVar(interp, var, resultPtr->errorCode, TCL_GLOBAL_ONLY);
Tcl_Free((char*)resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
var = "errorInfo";
Tcl_SetVar(interp, var, resultPtr->errorInfo, TCL_GLOBAL_ONLY);
Tcl_Free((char*)resultPtr->errorInfo);
}
Tcl_SetObjResult(interp, valObj);
Tcl_BackgroundError(interp);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadCreate --
*
* This procedure is invoked to create a thread containing an
* interp to run a script. This returns after the thread has
* started executing.
*
* Results:
* A standard Tcl result, which is the thread ID.
*
* Side effects:
* Create a thread.
*
*----------------------------------------------------------------------
*/
static int
ThreadCreate(interp, script, stacksize, flags, preserve)
Tcl_Interp *interp; /* Current interpreter. */
CONST char *script; /* Script to evaluate */
int stacksize; /* Zero for default size */
int flags; /* Zero for no flags */
int preserve; /* If true, reserve the thread */
{
char thrHandle[THREAD_HNDLMAXLEN];
ThreadCtrl ctrl;
Tcl_ThreadId thrId;
#ifdef NS_AOLSERVER
ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL);
#endif
ctrl.script = (char *)script;
ctrl.condWait = NULL;
ctrl.flags = 0;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&thrId, NewThread, (ClientData)&ctrl,
stacksize, flags) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_SetResult(interp, "can't create a new thread", TCL_STATIC);
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using
* the ThreadCtrl argument which is on our stack.
*/
while (ctrl.script != NULL) {
Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
}
if (preserve) {
(ThreadExistsInner(thrId))->refCount++;
}
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&ctrl.condWait);
ThreadGetHandle(thrId, thrHandle);
Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NewThread --
*
* This routine is the "main()" for a new thread whose task is to
* execute a single TCL script. The argument to this function is
* a pointer to a structure that contains the text of the Tcl script
* to be executed, plus some synchronization primitives. Those are
* used so the caller gets signalized when the new thread has
* done its initialization.
*
* Space to hold the ThreadControl structure itself is reserved on
* the stack of the calling function. The two condition variables
* in the ThreadControl structure are destroyed by the calling
* function as well. The calling function will destroy the
* ThreadControl structure and the condition variable as soon as
* ctrlPtr->condWait is signaled, so this routine must make copies
* of any data it might need after that point.
*
* Results:
* none
*
* Side effects:
* A Tcl script is executed in a new thread.
*
*----------------------------------------------------------------------
*/
Tcl_ThreadCreateType
NewThread(clientData)
ClientData clientData;
{
ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Interp *interp;
int result = TCL_OK, scriptLen;
char *evalScript;
/*
* Initialize the interpreter. The bad thing here is that we
* assume that initialization of the Tcl interp will be
* error free, which it may not. In the future we must recover
* from this and exit gracefully (this is not that easy as
* it seems on the first glance...)
*/
#ifdef NS_AOLSERVER
struct mydata *md = (struct mydata*)ctrlPtr->cd;
Ns_ThreadSetName("-tclthread-");
interp = (Tcl_Interp*)Ns_TclAllocateInterp(md ? md->server : NULL);
#else
interp = Tcl_CreateInterp();
result = Tcl_Init(interp);
#endif
#if !defined(NS_AOLSERVER) || (defined(NS_MAJOR_VERSION) && NS_MAJOR_VERSION >= 4)
result = Thread_Init(interp);
#endif
tsdPtr->interp = interp;
Tcl_MutexLock(&threadMutex);
/*
* Update the list of threads.
*/
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script
* we are eval'ing, for the case that we exit during evaluation
*/
scriptLen = strlen(ctrlPtr->script);
evalScript = strcpy((char*)Tcl_Alloc(scriptLen+1), ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc,(ClientData)evalScript);
/*
* Notify the parent we are alive.
*/
ctrlPtr->script = NULL;
Tcl_ConditionNotify(&ctrlPtr->condWait);
Tcl_MutexUnlock(&threadMutex);
/*
* Run the script.
*/
Tcl_Preserve((ClientData)tsdPtr->interp);
result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
}
/*
* Clean up. Note: add something like TlistRemove for the transfer list.
*/
if (tsdPtr->doOneEvent) {
Tcl_ConditionFinalize(&tsdPtr->doOneEvent);
}
ListRemove(tsdPtr);
/*
* It is up to all other extensions, including Tk, to be responsible
* for their own events when they receive their Tcl_CallWhenDeleted
* notice when we delete this interp.
*/
#ifdef NS_AOLSERVER
Ns_TclMarkForDelete(tsdPtr->interp);
Ns_TclDeAllocateInterp(tsdPtr->interp);
#else
Tcl_DeleteInterp(tsdPtr->interp);
#endif
Tcl_Release((ClientData)tsdPtr->interp);
/*
* Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls
* ThreadExitHandlers and cleans the notifier as well as other sub-
* systems that save thread state data.
*/
Tcl_ExitThread(result);
TCL_THREAD_CREATE_RETURN;
}
/*
*----------------------------------------------------------------------
*
* ThreadErrorProc --
*
* Send a message to the thread willing to hear about errors.
*
* Results:
* None
*
* Side effects:
* Send an event.
*
*----------------------------------------------------------------------
*/
static void
ThreadErrorProc(interp)
Tcl_Interp *interp; /* Interp that failed */
{
ThreadSendData *sendPtr;
char *argv[3], buf[THREAD_HNDLMAXLEN];
CONST char *errorInfo;
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if (errorInfo == NULL) {
errorInfo = "";
}
if (errorProcString == NULL) {
#ifdef NS_AOLSERVER
Ns_Log(Error, "%s\n%s", Tcl_GetStringResult(interp), errorInfo);
#else
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel == NULL) {
/* Fixes the [#634845] bug; credits to
* Wojciech Kocjan <wojciech@kocjan.org> */
return;
}
ThreadGetHandle(Tcl_GetCurrentThread(), buf);
Tcl_WriteChars(errChannel, "Error from thread ", -1);
Tcl_WriteChars(errChannel, buf, -1);
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_WriteChars(errChannel, errorInfo, -1);
Tcl_WriteChars(errChannel, "\n", 1);
#endif
} else {
ThreadGetHandle(Tcl_GetCurrentThread(), buf);
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = (char*)errorInfo;
sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData));
sendPtr->execProc = ThreadSendEval;
sendPtr->freeProc = (ThreadSendFree*)Tcl_Free;
sendPtr->clientData = (ClientData) Tcl_Merge(3, (CONST84 char**)argv);
sendPtr->interp = NULL;
ThreadSend(interp, errorThreadId, sendPtr, NULL, 0);
}
}
/*
*----------------------------------------------------------------------
*
* ListUpdate --
*
* Add the thread local storage to the list. This grabs the
* mutex to protect the list.
*
* Results:
* None
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ListUpdate(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
Tcl_MutexLock(&threadMutex);
ListUpdateInner(tsdPtr);
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ListUpdateInner --
*
* Add the thread local storage to the list. This assumes the caller
* has obtained the threadMutex.
*
* Results:
* None
*
* Side effects:
* Add the thread local storage to its list.
*
*----------------------------------------------------------------------
*/
static void
ListUpdateInner(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (threadList) {
threadList->prevPtr = tsdPtr;
}
tsdPtr->nextPtr = threadList;
tsdPtr->prevPtr = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
threadList = tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* ListRemove --
*
* Remove the thread local storage from its list. This grabs the
* mutex to protect the list.
*
* Results:
* None
*
* Side effects:
* Remove the thread local storage from its list.
*
*----------------------------------------------------------------------
*/
static void
ListRemove(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
}
Tcl_MutexLock(&threadMutex);
ListRemoveInner(tsdPtr);
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ListRemoveInner --
*
* Remove the thread local storage from its list.
*
* Results:
* None
*
* Side effects:
* Remove the thread local storage from its list.
*
*----------------------------------------------------------------------
*/
static void
ListRemoveInner(tsdPtr)
ThreadSpecificData *tsdPtr;
{
if (tsdPtr->prevPtr || tsdPtr->nextPtr) {
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
threadList = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
} else if (tsdPtr == threadList) {
threadList = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* ThreadList --
*
* Return a list of threads running Tcl interpreters.
*
* Results:
* Number of threads.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadList(interp, thrIdArray)
Tcl_Interp *interp;
Tcl_ThreadId **thrIdArray;
{
int ii, count = 0;
ThreadSpecificData *tsdPtr;
Tcl_MutexLock(&threadMutex);
/*
* First walk; find out how many threads are registered.
* We may avoid this and gain some speed by maintaining
* the counter of allocated structs in the threadList.
*/
for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
count++;
}
if (count == 0) {
return 0;
}
/*
* Allocate storage for passing thread id's to caller
*/
*thrIdArray = (Tcl_ThreadId*)Tcl_Alloc(count * sizeof(Tcl_ThreadId));
/*
* Second walk; fill-in the array with thread ID's
*/
for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) {
(*thrIdArray)[ii] = tsdPtr->threadId;
}
Tcl_MutexUnlock(&threadMutex);
return count;
}
/*
*----------------------------------------------------------------------
*
* ThreadExists --
*
* Test wether a thread given by it's id is known to us.
*
* Results:
* Pointer to thread specific data structure or
* NULL if no thread with given ID found
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadExists(thrId)
Tcl_ThreadId thrId;
{
ThreadSpecificData *tsdPtr;
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
Tcl_MutexUnlock(&threadMutex);
return tsdPtr != NULL;
}
/*
*----------------------------------------------------------------------
*
* ThreadExistsInner --
*
* Test wether a thread given by it's id is known to us. Assumes
* caller holds the thread mutex.
*
* Results:
* Pointer to thread specific data structure or
* NULL if no thread with given ID found
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
ThreadExistsInner(thrId)
Tcl_ThreadId thrId; /* Thread id to look for. */
{
ThreadSpecificData *tsdPtr;
for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
if (tsdPtr->threadId == thrId) {
return tsdPtr;
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ThreadJoin --
*
* Wait for the exit of a different thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The status of the exiting thread is left in the interp result
* area, but only in the case of success.
*
*----------------------------------------------------------------------
*/
static int
ThreadJoin(interp, thrId)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_ThreadId thrId; /* Thread ID of other interpreter. */
{
int ret, state;
ret = Tcl_JoinThread(thrId, &state);
if (ret == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult (interp), state);
} else {
char thrHandle[THREAD_HNDLMAXLEN];
ThreadGetHandle(thrId, thrHandle);
Tcl_AppendResult(interp, "cannot join thread ", thrHandle, NULL);
}
return ret;
}
/*
*----------------------------------------------------------------------
*
* ThreadTransfer --
*
* Transfers the specified channel which must not be shared and has
* to be registered in the given interp from that location to the
* main interp of the specified thread.
*
* Thanks to Anreas Kupries for the initial implementation.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The thread-global lists of all known channels of both threads
* involved (specified and current) are modified. The channel is
* moved, all event handling for the channel is killed.
*
*----------------------------------------------------------------------
*/
static int
ThreadTransfer(interp, thrId, chan)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_ThreadId thrId; /* Thread Id of other interpreter. */
Tcl_Channel chan; /* The channel to transfer */
{
/* Steps to perform for the transfer:
*
* i. Sanity checks: chan has to registered in interp, must not be
* shared. This automatically excludes the special channels for
* stdin, stdout and stderr!
* ii. Clear event handling.
* iii. Bump reference counter up to prevent destruction during the
* following unregister, then unregister the channel from the
* interp. Remove it from the thread-global list of all channels
* too.
* iv. Wrap the channel into an event and send that to the other
* thread, then wait for the other thread to process our message.
* v. The event procedure called by the other thread is
* 'TransferEventProc'. It links the channel into the
* thread-global list of channels for that thread, registers it
* in the main interp of the other thread, removes the artificial
* reference, at last notifies this thread of the sucessful
* transfer. This allows this thread then to proceed.
*/
TransferEvent *evPtr;
TransferResult *resultPtr;
if (!Tcl_IsChannelRegistered(interp, chan)) {
Tcl_SetResult(interp, "channel is not registered here", TCL_STATIC);
}
if (Tcl_IsChannelShared(chan)) {
Tcl_SetResult(interp, "channel is shared", TCL_STATIC);
return TCL_ERROR;
}
/*
* Short circut transfers to ourself. Nothing to do.
*/
if (thrId == Tcl_GetCurrentThread()) {
return TCL_OK;
}
Tcl_MutexLock(&threadMutex);
/*
* Verify the thread exists.
*/
if (ThreadExistsInner(thrId) == NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
/*
* Cut the channel out of the interp/thread
*/
ThreadCutChannel(interp, chan);
/*
* Wrap it into an event.
*/
resultPtr = (TransferResult*)Tcl_Alloc(sizeof(TransferResult));
evPtr = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent));
evPtr->chan = chan;
evPtr->event.proc = TransferEventProc;
evPtr->resultPtr = resultPtr;
/*
* Initialize the result fields.
*/
resultPtr->done = (Tcl_Condition) NULL;
resultPtr->resultCode = -1;
resultPtr->resultMsg = (char *) NULL;
/*
* Maintain the cleanup list.
*/
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->dstThreadId = thrId;
resultPtr->eventPtr = evPtr;
SpliceIn(resultPtr, transferList);
/*
* Queue the event and poke the other thread's notifier.
*/
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(thrId);
/*
* (*) Block until the other thread has either processed the transfer
* or rejected it.
*/
while (resultPtr->resultCode < 0) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
/*
* Unlink result from the result list.
*/
SpliceOut(resultPtr, transferList);
resultPtr->eventPtr = NULL;
resultPtr->nextPtr = NULL;
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
Tcl_ConditionFinalize(&resultPtr->done);
/*
* Process the result now.
*/
if (resultPtr->resultCode != TCL_OK) {
/*
* Transfer failed, restore old state of channel with respect
* to current thread and specified interp.
*/
Tcl_SpliceChannel(chan);
Tcl_RegisterChannel(interp, chan);
Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan);
Tcl_AppendResult(interp, "transfer failed: ", NULL);
if (resultPtr->resultMsg) {
Tcl_AppendResult(interp, resultPtr->resultMsg, NULL);
Tcl_Free(resultPtr->resultMsg);
} else {
Tcl_AppendResult(interp, "for reasons unknown", NULL);
}
return TCL_ERROR;
}
if (resultPtr->resultMsg) {
Tcl_Free(resultPtr->resultMsg);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadDetach --
*
* Detaches the specified channel which must not be shared and has
* to be registered in the given interp. The detached channel is
* left in the transfer list until some other thread attaches it
+ by calling the "thread::attach" command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The thread-global lists of all known channels (transferList)
* is modified. All event handling for the channel is killed.
*
*----------------------------------------------------------------------
*/
static int
ThreadDetach(interp, chan)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_Channel chan; /* The channel to detach */
{
TransferEvent *evPtr;
TransferResult *resultPtr;
if (!Tcl_IsChannelRegistered(interp, chan)) {
Tcl_SetResult(interp, "channel is not registered here", TCL_STATIC);
}
if (Tcl_IsChannelShared(chan)) {
Tcl_SetResult(interp, "channel is shared", TCL_STATIC);
return TCL_ERROR;
}
/*
* Cut the channel out of the interp/thread
*/
ThreadCutChannel(interp, chan);
/*
* Wrap it into the list of transfered channels. We generate no
* events associated with the detached channel, thus really not
* needing the transfer event structure allocated here. This
* is done purely to avoid having yet another wrapper.
*/
resultPtr = (TransferResult*)Tcl_Alloc(sizeof(TransferResult));
evPtr = (TransferEvent*)Tcl_Alloc(sizeof(TransferEvent));
evPtr->chan = chan;
evPtr->event.proc = NULL;
evPtr->resultPtr = resultPtr;
/*
* Initialize the result fields. This is not used.
*/
resultPtr->done = (Tcl_Condition)NULL;
resultPtr->resultCode = -1;
resultPtr->resultMsg = (char*)NULL;
/*
* Maintain the cleanup list. By setting the dst/srcThreadId
* to zero we signal the code in ThreadAttach that this is the
* detached channel. Therefore it should not be mistaken for
* some regular TransferChannel operation underway. Also, this
* will prevent the code in ThreadExitProc to splice out this
* record from the list when the threads are exiting.
* A side effect of this is that we may have entries in this
* list which may never be removed (i.e. nobody attaches the
* channel later on). This will result in both Tcl channel and
* memory leak.
*/
resultPtr->srcThreadId = (Tcl_ThreadId)0;
resultPtr->dstThreadId = (Tcl_ThreadId)0;
resultPtr->eventPtr = evPtr;
Tcl_MutexLock(&threadMutex);
SpliceIn(resultPtr, transferList);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadAttach --
*
* Attaches the previously detached channel into the current
* interpreter.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* The thread-global lists of all known channels (transferList)
* is modified.
*
*----------------------------------------------------------------------
*/
static int
ThreadAttach(interp, chanName)
Tcl_Interp *interp; /* The current interpreter. */
char *chanName; /* The name of the channel to detach */
{
int found = 0;
Tcl_Channel chan = NULL;
TransferResult *resPtr;
/*
* Locate the channel to attach by looking up its name in
* the list of transfered channels. Watch that we don't
* hit the regular channel transfer event.
*/
Tcl_MutexLock(&threadMutex);
for (resPtr = transferList; resPtr; resPtr = resPtr->nextPtr) {
chan = resPtr->eventPtr->chan;
if (!strcmp(Tcl_GetChannelName(chan),chanName)
&& !resPtr->dstThreadId) {
if (Tcl_IsChannelExisting(chanName)) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp, "channel already exists", NULL);
return TCL_ERROR;
}
SpliceOut(resPtr, transferList);
Tcl_Free((char*)resPtr->eventPtr);
Tcl_Free((char*)resPtr);
found = 1;
break;
}
}
Tcl_MutexUnlock(&threadMutex);
if (found == 0) {
Tcl_AppendResult(interp, "channel not detached", NULL);
return TCL_ERROR;
}
/*
* Splice channel into the current interpreter
*/
Tcl_SpliceChannel(chan);
Tcl_RegisterChannel(interp, chan);
Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSend --
*
* Run the procedure in other thread.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadSend(interp, thrId, send, clbk, flags)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_ThreadId thrId; /* Thread Id of other thread. */
ThreadSendData *send; /* Pointer to structure with work to do */
ThreadClbkData *clbk; /* Opt. callback structure (may be NULL) */
int flags; /* Wait or queue to tail */
{
ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */
int code;
ThreadEvent *eventPtr;
ThreadEventResult *resultPtr;
/*
* Verify the thread exists and is not in the error state.
* The thread is in the error state only if we've configured
* it to unwind on script evaluation error and last script
* evaluation resulted in error actually.
*/
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == (ThreadSpecificData*)NULL
|| (tsdPtr->flags & THREAD_FLAGS_INERROR)) {
int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR);
Tcl_MutexUnlock(&threadMutex);
ThreadFreeProc((ClientData)send);
if (clbk) {
ThreadFreeProc((ClientData)clbk);
}
if (inerror) {
Tcl_SetResult(interp, "thread is in error", TCL_STATIC);
} else {
ErrorNoSuchThread(interp, thrId);
}
return TCL_ERROR;
}
/*
* Short circut sends to ourself.
*/
if (thrId == Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
if ((flags & THREAD_SEND_WAIT)) {
return (*send->execProc)(interp, (ClientData)send);
} else {
send->interp = interp;
Tcl_Preserve((ClientData)send->interp);
Tcl_DoWhenIdle((Tcl_IdleProc*)ThreadIdleProc, (ClientData)send);
return TCL_OK;
}
}
/*
* Create the event for target thread event queue.
*/
eventPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent));
eventPtr->sendData = send;
eventPtr->clbkData = clbk;
/*
* Target thread about to service
* another event
*/
if (tsdPtr->maxEventsCount) {
tsdPtr->eventsPending++;
}
/*
* Caller wants to be notified, so we must take care
* it's interpreter stays alive until we've finished.
*/
if (eventPtr->clbkData) {
Tcl_Preserve((ClientData)eventPtr->clbkData->interp);
}
if ((flags & THREAD_SEND_WAIT) == 0) {
resultPtr = NULL;
eventPtr->resultPtr = NULL;
} else {
resultPtr = (ThreadEventResult*)Tcl_Alloc(sizeof(ThreadEventResult));
resultPtr->done = (Tcl_Condition)NULL;
resultPtr->result = NULL;
resultPtr->errorCode = NULL;
resultPtr->errorInfo = NULL;
resultPtr->dstThreadId = thrId;
resultPtr->srcThreadId = Tcl_GetCurrentThread();
resultPtr->eventPtr = eventPtr;
eventPtr->resultPtr = resultPtr;
SpliceIn(resultPtr, resultList);
}
/*
* Queue the event and poke the other thread's notifier.
*/
eventPtr->event.proc = ThreadEventProc;
if ((flags & THREAD_SEND_HEAD)) {
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_HEAD);
} else {
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_TAIL);
}
Tcl_ThreadAlert(thrId);
if ((flags & THREAD_SEND_WAIT) == 0) {
/*
* Might potentially spend some time here, until the
* worker thread clean's up it's queue a little bit.
*/
while (tsdPtr->maxEventsCount &&
tsdPtr->eventsPending > tsdPtr->maxEventsCount) {
Tcl_ConditionWait(&tsdPtr->doOneEvent, &threadMutex, NULL);
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
* Block on the result indefinitely.
*/
Tcl_ResetResult(interp);
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
SpliceOut(resultPtr, resultList);
Tcl_MutexUnlock(&threadMutex);
/*
* Return result to caller
*/
if (resultPtr->code == TCL_ERROR) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
Tcl_Free(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
Tcl_Free(resultPtr->errorInfo);
}
}
code = resultPtr->code;
Tcl_SetStringObj(Tcl_GetObjResult(interp), resultPtr->result, -1);
/*
* Cleanup
*/
Tcl_ConditionFinalize(&resultPtr->done);
if (resultPtr->result != threadEmptyResult) {
Tcl_Free(resultPtr->result);
}
Tcl_Free((char*)resultPtr);
return code;
}
/*
*----------------------------------------------------------------------
*
* ThreadWait --
*
* Waits for events and process them as they come, until signaled
* to stop.
*
* Results:
* TCL_OK always
*
* Side effects:
* Deletes any thread::send or thread::transfer events that are
* pending.
*
*----------------------------------------------------------------------
*/
static int
ThreadWait()
{
int canrun = 1;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Process events until signaled to stop.
*/
while (canrun) {
/*
* About to service another event.
* Wake-up eventual sleepers.
*/
if (tsdPtr->maxEventsCount) {
Tcl_MutexLock(&threadMutex);
tsdPtr->eventsPending--;
Tcl_ConditionNotify(&tsdPtr->doOneEvent);
Tcl_MutexUnlock(&threadMutex);
}
Tcl_DoOneEvent(TCL_ALL_EVENTS);
/*
* Test stop condition under mutex since
* some other thread may flip our flags.
*/
Tcl_MutexLock(&threadMutex);
canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0;
Tcl_MutexUnlock(&threadMutex);
}
/*
* Remove from the list of active threads, so nobody can post
* work to this thread, since it is just about to terminate.
*/
ListRemove(tsdPtr);
/*
* Now that the event processor for this thread is closing,
* delete all pending thread::send and thread::transfer events.
* These events are owned by us. We don't delete anyone else's
* events, but ours.
*/
Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadReserve --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadReserve(interp, thrId, operation, wait)
Tcl_Interp *interp; /* Current interpreter */
Tcl_ThreadId thrId; /* Target thread ID */
int operation; /* THREAD_RESERVE | THREAD_RELEASE */
int wait; /* Wait for thread to exit */
{
int users, dowait = 0;
ThreadEvent *evPtr;
ThreadSpecificData *tsdPtr;
Tcl_MutexLock(&threadMutex);
/*
* Check the given thread
*/
if (thrId == (Tcl_ThreadId)0) {
tsdPtr = TCL_TSD_INIT(&dataKey);
} else {
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == (ThreadSpecificData*)NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
}
switch (operation) {
case THREAD_RESERVE: ++tsdPtr->refCount; break;
case THREAD_RELEASE: --tsdPtr->refCount; dowait = wait; break;
}
users = tsdPtr->refCount;
if (users <= 0) {
/*
* We're last attached user, so tear down the *target* thread
*/
tsdPtr->flags |= THREAD_FLAGS_STOPPED;
if (thrId /* Not current! */) {
ThreadEventResult *resultPtr = NULL;
/*
* Remove from the list of active threads, so nobody can post
* work to this thread, since it is just about to terminate.
*/
ListRemoveInner(tsdPtr);
/*
* Send an dummy event, just to wake-up target thread.
* It should immediately exit thereafter. We might get
* stuck here for long time if user really wants to
* be absolutely sure that the thread has exited.
*/
if (dowait) {
resultPtr = (ThreadEventResult*)
Tcl_Alloc(sizeof(ThreadEventResult));
resultPtr->done = (Tcl_Condition)NULL;
resultPtr->result = NULL;
resultPtr->code = TCL_OK;
resultPtr->errorCode = NULL;
resultPtr->errorInfo = NULL;
resultPtr->dstThreadId = thrId;
resultPtr->srcThreadId = Tcl_GetCurrentThread();
SpliceIn(resultPtr, resultList);
}
evPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent));
evPtr->event.proc = ThreadEventProc;
evPtr->sendData = NULL;
evPtr->clbkData = NULL;
evPtr->resultPtr = resultPtr;
Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(thrId);
if (dowait) {
while (resultPtr->result == NULL) {
Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
}
SpliceOut(resultPtr, resultList);
Tcl_ConditionFinalize(&resultPtr->done);
if (resultPtr->result != threadEmptyResult) {
Tcl_Free(resultPtr->result); /* Will be ignored anyway */
}
Tcl_Free((char*)resultPtr);
}
}
}
Tcl_MutexUnlock(&threadMutex);
Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadEventProc --
*
* Handle the event in the target thread.
*
* Results:
* Returns 1 to indicate that the event was processed.
*
* Side effects:
* Fills out the ThreadEventResult struct.
*
*----------------------------------------------------------------------
*/
static int
ThreadEventProc(evPtr, mask)
Tcl_Event *evPtr; /* Really ThreadEvent */
int mask;
{
ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_Interp *interp = NULL;
Tcl_ThreadId thrId = Tcl_GetCurrentThread();
ThreadEvent *eventPtr = (ThreadEvent*)evPtr;
ThreadSendData *sendPtr = eventPtr->sendData;
ThreadClbkData *clbkPtr = eventPtr->clbkData;
ThreadEventResult* resultPtr = eventPtr->resultPtr;
int code = TCL_ERROR; /* Pessimistic assumption */
/*
* See wether user has any preferences about which interpreter
* to use for running this job. The job structure might indentify
* one. If not, just use the thread's main interpreter which is
* stored in the thread specific data structure.
* Note that later on we might discover that we're running the
* aync callback script. In this case, interpreter will be
* changed to one given in the callback.
*/
interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp;
if (interp != NULL) {
if (clbkPtr && clbkPtr->threadId == thrId) {
/* Watch: this thread evaluates it's own callback. */
interp = clbkPtr->interp;
} else {
Tcl_Preserve((ClientData)interp);
}
Tcl_ResetResult(interp);
if (sendPtr) {
Tcl_CreateThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr);
if (clbkPtr) {
Tcl_CreateThreadExitHandler(ThreadFreeProc,
(ClientData)clbkPtr);
}
code = (*sendPtr->execProc)(interp, (ClientData)sendPtr);
Tcl_DeleteThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr);
if (clbkPtr) {
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
(ClientData)clbkPtr);
}
} else {
code = TCL_OK;
}
}
ThreadFreeProc((ClientData)sendPtr);
if (resultPtr) {
/*
* Report job result synchronously to waiting caller
*/
Tcl_MutexLock(&threadMutex);
ThreadSetResult(interp, code, resultPtr);
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
} else if (clbkPtr && clbkPtr->threadId != thrId) {
ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr;
/*
* Route the callback back to it's originator.
* Do not wait for the result.
*/
if (code == TCL_ERROR) {
ThreadErrorProc(interp);
}
ThreadSetResult(interp, code, &clbkPtr->result);
ThreadSend(interp, clbkPtr->threadId, tmpPtr, NULL, 0);
} else if (code == TCL_ERROR) {
/*
* Only pass errors onto the registered error handler
* when we don't have a result target for this event.
*/
ThreadErrorProc(interp);
}
if (interp != NULL) {
Tcl_Release((ClientData)interp);
}
/*
* Mark unwind scenario for this thread if the script resulted
* in error condition and thread has been marked to unwind.
* This will cause thread to disappear from the list of active
* threads, clean-up its event queue and exit.
*/
if (code != TCL_OK) {
Tcl_MutexLock(&threadMutex);
if (tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR) {
tsdPtr->flags |= THREAD_FLAGS_INERROR;
if (tsdPtr->refCount == 0) {
tsdPtr->flags |= THREAD_FLAGS_STOPPED;
}
}
Tcl_MutexUnlock(&threadMutex);
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* ThreadSetResult --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static void
ThreadSetResult(interp, code, resultPtr)
Tcl_Interp *interp;
int code;
ThreadEventResult *resultPtr;
{
int reslen;
CONST char *errorCode, *errorInfo, *result;
if (interp == NULL) {
code = TCL_ERROR;
errorInfo = "";
errorCode = "THREAD";
result = "no target interp!";
reslen = strlen(result);
resultPtr->result = (reslen) ?
strcpy(Tcl_Alloc(1+reslen), result) : threadEmptyResult;
} else {
result = Tcl_GetStringResult(interp);
reslen = strlen(result);
resultPtr->result = (reslen) ?
strcpy(Tcl_Alloc(1+reslen), result) : threadEmptyResult;
if (code == TCL_ERROR) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
} else {
errorCode = NULL;
errorInfo = NULL;
}
}
resultPtr->code = code;
if (errorCode != NULL) {
resultPtr->errorCode = Tcl_Alloc(1+strlen(errorCode));
strcpy(resultPtr->errorCode, errorCode);
} else {
resultPtr->errorCode = NULL;
}
if (errorInfo != NULL) {
resultPtr->errorInfo = Tcl_Alloc(1+strlen(errorInfo));
strcpy(resultPtr->errorInfo, errorInfo);
} else {
resultPtr->errorInfo = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* ThreadGetOption --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadGetOption(interp, thrId, option, dsPtr)
Tcl_Interp *interp;
Tcl_ThreadId thrId;
char *option;
Tcl_DString *dsPtr;
{
int len;
ThreadSpecificData *tsdPtr = NULL;
/*
* If the optionName is NULL it means that we want
* a list of all options and values.
*/
len = (option == NULL) ? 0 : strlen(option);
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == (ThreadSpecificData*)NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'v'
&& !strncmp(option,"-eventmark", len))) {
char buf[16];
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-eventmark");
}
sprintf(buf, "%d", tsdPtr->maxEventsCount);
Tcl_DStringAppendElement(dsPtr, buf);
if (len != 0) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
if (len == 0 || (len > 2 && option[1] == 'u'
&& !strncmp(option,"-unwindonerror", len))) {
int flag = tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-unwindonerror");
}
Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0");
if (len != 0) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'r'
&& !strncmp(option,"-errorstate", len))) {
int flag = tsdPtr->flags & THREAD_FLAGS_INERROR;
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-errorstate");
}
Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0");
if (len != 0) {
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
}
if (len != 0) {
Tcl_AppendResult(interp, "bad option \"", option,
"\", should be one of -eventmark, "
"-unwindonerror or -errorstate", NULL);
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadSetOption --
*
* Results:
*
* Side effects:
*
*----------------------------------------------------------------------
*/
static int
ThreadSetOption(interp, thrId, option, value)
Tcl_Interp *interp;
Tcl_ThreadId thrId;
char *option;
char *value;
{
int len = strlen(option);
ThreadSpecificData *tsdPtr = NULL;
Tcl_MutexLock(&threadMutex);
tsdPtr = ThreadExistsInner(thrId);
if (tsdPtr == (ThreadSpecificData*)NULL) {
Tcl_MutexUnlock(&threadMutex);
ErrorNoSuchThread(interp, thrId);
return TCL_ERROR;
}
if (len > 3 && option[1] == 'e' && option[2] == 'v'
&& !strncmp(option,"-eventmark", len)) {
if (sscanf(value, "%d", &tsdPtr->maxEventsCount) != 1) {
Tcl_AppendResult(interp, "expected integer but got \"",
value, "\"", NULL);
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
} else if (len > 2 && option[1] == 'u'
&& !strncmp(option,"-unwindonerror", len)) {
int flag = 0;
if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
if (flag) {
tsdPtr->flags |= THREAD_FLAGS_UNWINDONERROR;
} else {
tsdPtr->flags &= ~THREAD_FLAGS_UNWINDONERROR;
}
} else if (len > 3 && option[1] == 'e' && option[2] == 'r'
&& !strncmp(option,"-errorstate", len)) {
int flag = 0;
if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
return TCL_ERROR;
}
if (flag) {
tsdPtr->flags |= THREAD_FLAGS_INERROR;
} else {
tsdPtr->flags &= ~THREAD_FLAGS_INERROR;
}
}
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ThreadIdleProc --
*
* Results:
*
* Side effects.
*
*----------------------------------------------------------------------
*/
static void
ThreadIdleProc(clientData)
ClientData clientData;
{
int ret;
ThreadSendData *sendPtr = (ThreadSendData*)clientData;
ret = (*sendPtr->execProc)(sendPtr->interp, (ClientData)sendPtr);
if (ret != TCL_OK) {
ThreadErrorProc(sendPtr->interp);
}
Tcl_Release((ClientData)sendPtr->interp);
}
/*
*----------------------------------------------------------------------
*
* TransferEventProc --
*
* Handle a transfer event in the target thread.
*
* Results:
* Returns 1 to indicate that the event was processed.
*
* Side effects:
* Fills out the TransferResult struct.
*
*----------------------------------------------------------------------
*/
static int
TransferEventProc(evPtr, mask)
Tcl_Event *evPtr; /* Really ThreadEvent */
int mask;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TransferEvent *eventPtr = (TransferEvent *)evPtr;
TransferResult *resultPtr = eventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
char* msg = NULL;
if (interp == NULL) {
/*
* Reject transfer in case of a missing target.
*/
code = TCL_ERROR;
msg = "target interp missing";
} else {
/*
* Add channel to current thread and interp.
* See ThreadTransfer for more explanations.
*/
if (Tcl_IsChannelExisting(Tcl_GetChannelName(eventPtr->chan))) {
/*
* Reject transfer. Channel of same name already exists in target.
*/
code = TCL_ERROR;
msg = "channel already exists in target";
} else {
Tcl_SpliceChannel(eventPtr->chan);
Tcl_RegisterChannel(interp, eventPtr->chan);
Tcl_UnregisterChannel((Tcl_Interp *) NULL, eventPtr->chan);
code = TCL_OK; /* Return success. */
}
}
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->resultCode = code;
if (msg != NULL) {
resultPtr->resultMsg = (char*)Tcl_Alloc(1+strlen (msg));
strcpy (resultPtr->resultMsg, msg);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* ThreadFreeProc --
*
* Called when we are exiting and memory needs to be freed.
*
* Results:
* None.
*
* Side effects:
* Clears up mem specified in ClientData
*
*----------------------------------------------------------------------
*/
static void
ThreadFreeProc(clientData)
ClientData clientData;
{
/*
* This will free send and/or callback structures
* since both are the same in the beginning.
*/
ThreadSendData *anyPtr = (ThreadSendData*)clientData;
if (anyPtr) {
if (anyPtr->clientData) {
(*anyPtr->freeProc)(anyPtr->clientData);
}
Tcl_Free((char*)anyPtr);
}
}
/*
*----------------------------------------------------------------------
*
* ThreadDeleteEvent --
*
* This is called from the ThreadExitProc to delete memory related
* to events that we put on the queue.
*
* Results:
* 1 it was our event and we want it removed, 0 otherwise.
*
* Side effects:
* It cleans up our events in the event queue for this thread.
*
*----------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(eventPtr, clientData)
Tcl_Event *eventPtr; /* Really ThreadEvent */
ClientData clientData; /* dummy */
{
if (eventPtr->proc == ThreadEventProc) {
/*
* Regular script event. Just dispose memory
*/
ThreadEvent *evPtr = (ThreadEvent*)eventPtr;
if (evPtr->sendData) {
ThreadFreeProc((ClientData)evPtr->sendData);
}
if (evPtr->clbkData) {
ThreadFreeProc((ClientData)evPtr->clbkData);
}
return 1;
}
if ((eventPtr->proc == TransferEventProc)) {
/*
* A channel is in flight toward the thread just exiting.
* Pass it back to the originator, if possible.
* Else kill it.
*/
TransferEvent* evPtr = (TransferEvent *) eventPtr;
if (evPtr->resultPtr == (TransferResult *) NULL) {
/* No thread to pass the channel back to. Kill it.
* This requires to splice it temporarily into our channel
* list and then forcing the ref.counter down to the real
* value of zero. This destroys the channel.
*/
Tcl_SpliceChannel(evPtr->chan);
Tcl_UnregisterChannel((Tcl_Interp *) NULL, evPtr->chan);
return 1;
}
/* Our caller (ThreadExitProc) will pass the channel back.
*/
return 1;
}
/*
* If it was NULL, we were in the middle of servicing the event
* and it should be removed
*/
return (eventPtr->proc == NULL);
}
/*
*----------------------------------------------------------------------
*
* ThreadExitProc --
*
* This is called when the thread exits.
*
* Results:
* None.
*
* Side effects:
* It unblocks anyone that is waiting on a send to this thread.
* It cleans up any events in the event queue for this thread.
*
*----------------------------------------------------------------------
*/
static void
ThreadExitProc(clientData)
ClientData clientData;
{
char *threadEvalScript = (char*)clientData;
char *diemsg = "target thread died";
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TransferResult *tResultPtr, *tNextPtr;
if (threadEvalScript && threadEvalScript != threadEmptyResult) {
Tcl_Free((char*)threadEvalScript);
}
Tcl_MutexLock(&threadMutex);
/*
* AOLserver and threadpool threads get started/stopped
* out of the control of this interface so this is
* the first chance to split them out of the thread list.
*/
ListRemoveInner(tsdPtr);
/*
* Delete events posted to our queue while we were running.
* For threads exiting from the thread::wait command, this
* has already been done in ThreadWait() function.
* For one-shot threads, having something here is a very
* strange condition. It *may* happen if somebody posts us
* an event while we were in the middle of processing some
* lengthly user script. It is unlikely to happen, though.
*/
Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL);
/*
* Walk the list of threads waiting for result from us
* and inform them that we're about to exit.
*/
for (resultPtr = resultList; resultPtr; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
if (resultPtr->srcThreadId == self) {
/*
* We are going away. By freeing up the result we signal
* to the other thread we don't care about the result.
*/
SpliceOut(resultPtr, resultList);
Tcl_Free((char*)resultPtr);
} else if (resultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller.
* The result string must be dynamically allocated
* because the main thread is going to call free on it.
*/
resultPtr->result = strcpy(Tcl_Alloc(1+strlen(diemsg)), diemsg);
resultPtr->code = TCL_ERROR;
resultPtr->errorCode = resultPtr->errorInfo = NULL;
Tcl_ConditionNotify(&resultPtr->done);
}
}
for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) {
tNextPtr = tResultPtr->nextPtr;
if (tResultPtr->srcThreadId == self) {
/*
* We are going away. By freeing up the result we signal
* to the other thread we don't care about the result.
*
* This should not happen, as this thread should be in
* ThreadTransfer at location (*).
*/
SpliceOut(tResultPtr, transferList);
Tcl_Free((char*)tResultPtr);
} else if (tResultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller.
* The result string must be dynamically allocated
* because the main thread is going to call free on it.
*/
tResultPtr->resultMsg = strcpy(Tcl_Alloc(1+strlen(diemsg)),
diemsg);
tResultPtr->resultCode = TCL_ERROR;
Tcl_ConditionNotify(&tResultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
/*
*----------------------------------------------------------------------
*
* ThreadGetHandle --
*
* Construct the handle of the thread which is suitable
* to pass to Tcl.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ThreadGetHandle(thrId, handlePtr)
Tcl_ThreadId thrId;
char *handlePtr;
{
sprintf(handlePtr, THREAD_HNDLPREFIX"%p", thrId);
}
/*
*----------------------------------------------------------------------
*
* ThreadGetId --
*
* Returns the ID of thread given it's Tcl handle.
*
* Results:
* Thread ID.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ThreadGetId(interp, handleObj, thrIdPtr)
Tcl_Interp *interp;
Tcl_Obj *handleObj;
Tcl_ThreadId *thrIdPtr;
{
char *thrHandle = Tcl_GetStringFromObj(handleObj, NULL);
if (sscanf(thrHandle, THREAD_HNDLPREFIX"%p", thrIdPtr) == 1) {
return TCL_OK;
}
Tcl_AppendResult(interp, "invalid thread handle \"",
thrHandle, "\"", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ErrorNoSuchThread --
*
* Convenience function to set interpreter result when the thread
* given by it's ID cannot be found.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
ErrorNoSuchThread(interp, thrId)
Tcl_Interp *interp;
Tcl_ThreadId thrId;
{
char thrHandle[THREAD_HNDLMAXLEN];
ThreadGetHandle(thrId, thrHandle);
Tcl_AppendResult(interp, "thread \"", thrHandle,
"\" does not exist", NULL);
}
/*
*----------------------------------------------------------------------
*
* ThreadCutChannel --
*
* Dissociate a Tcl channel from the current thread/interp.
*
* Results:
* None.
*
* Side effects:
* Events still pending in the thread event queue and ready to fire
* are not processed.
*
*----------------------------------------------------------------------
*/
static void
ThreadCutChannel(interp, chan)
Tcl_Interp *interp;
Tcl_Channel chan;
{
Tcl_ChannelType *chanTypePtr;
Tcl_DriverWatchProc *watchProc;
Tcl_ClearChannelHandlers(chan);
chanTypePtr = Tcl_GetChannelType(chan);
watchProc = Tcl_ChannelWatchProc(chanTypePtr);
/*
* This effectively disables processing of pending
* events which are ready to fire for the given
* channel. If we do not do this, events will hit
* the detached channel which is potentially being
* owned by some other thread. This will wreck havoc
* on our memory and eventually badly hurt us...
*/
if (watchProc) {
(*watchProc)(Tcl_GetChannelInstanceData(chan), 0);
}
/*
* Artificially bump the channel reference count
* which protects us from channel being closed
* during the Tcl_UnregisterChannel().
*/
Tcl_RegisterChannel((Tcl_Interp *) NULL, chan);
Tcl_UnregisterChannel(interp, chan);
Tcl_CutChannel(chan);
}
/* EOF $RCSfile: threadCmd.c,v $ */
/* Emacs Setup Variables */
/* Local Variables: */
/* mode: C */
/* indent-tabs-mode: nil */
/* c-basic-offset: 4 */
/* End: */
syntax highlighted by Code2HTML, v. 0.9.1