/* * 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.103 2009/07/22 11:25:34 nijtmans 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 = (char *)""; /* * 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; const 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; const 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; const 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; const 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; const char *var = (const 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) { ThreadSpecificData *tsdPtr = ThreadExistsInner(thrId); if (tsdPtr == (ThreadSpecificData*)NULL) { Tcl_MutexUnlock(&threadMutex); Tcl_ConditionFinalize(&ctrl.condWait); ErrorNoSuchThread(interp, thrId); return TCL_ERROR; } tsdPtr->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; const char *argv[3]; char 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 */ 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] = errorInfo; sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData)); sendPtr->execProc = ThreadSendEval; sendPtr->freeProc = (ThreadSendFree*)Tcl_Free; sendPtr->clientData = (ClientData) Tcl_Merge(3, 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_SetObjResult(interp, Tcl_NewStringObj(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; const 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; const 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; { const 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; { const 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: */