Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclThreadTest.c

/*
 * tclThreadTest.c --
 *
 *    This file implements the testthread command. Eventually this should be
 *    tclThreadCmd.c
 *    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.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclThreadTest.c,v 1.24 2006/09/22 14:45:48 dkf Exp $
 */

#include "tclInt.h"

extern int  Tcltest_Init(Tcl_Interp *interp);

#ifdef TCL_THREADS
/*
 * Each thread has an single instance of the following structure. There is one
 * 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 thread can send messages but only the main interpreter can
 * receive them.
 */

typedef struct ThreadSpecificData {
    Tcl_ThreadId  threadId;          /* Tcl ID for this thread */
    Tcl_Interp *interp;              /* Main interpreter for this thread */
    int flags;                       /* See the TP_ defines below... */
    struct ThreadSpecificData *nextPtr;   /* List for "thread names" */
    struct ThreadSpecificData *prevPtr;   /* List for "thread names" */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;

/*
 * This list is used to list all threads that have interpreters. This is
 * protected by threadMutex.
 */

static struct ThreadSpecificData *threadList;

/*
 * The following bit-values are legal for the "flags" field of the
 * ThreadSpecificData structure.
 */
#define TP_Dying               0x001 /* This thread is being cancelled */

/*
 * An instance of the following structure contains all information that is
 * passed into a new thread when the thread is created using either the
 * "thread create" Tcl command or the TclCreateThread() C function.
 */

typedef struct ThreadCtrl {
    char *script;       /* The Tcl command this thread should
                         * execute */
    int flags;                /* Initial value of the "flags" field in the
                         * ThreadSpecificData structure for the new
                         * thread. Might contain TP_Detached or
                         * TP_TclThread. */
    Tcl_Condition condWait;   /* This condition variable is used to
                         * synchronize the parent and child threads.
                         * The child won't run until it acquires
                         * threadMutex, and the parent function won't
                         * complete until signaled on this condition
                         * variable. */
} ThreadCtrl;

/*
 * This is the event used to send scripts to other threads.
 */

typedef struct ThreadEvent {
    Tcl_Event event;          /* Must be first */
    char *script;       /* The script to execute. */
    struct ThreadEventResult *resultPtr;
                        /* To communicate the result. This is NULL if
                         * we don't care about it. */
} ThreadEvent;

typedef struct ThreadEventResult {
    Tcl_Condition done;       /* Signaled when the script completes */
    int code;                 /* Return value of Tcl_Eval */
    char *result;       /* Result from the script */
    char *errorInfo;          /* Copy of errorInfo variable */
    char *errorCode;          /* Copy of errorCode variable */
    Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */
    Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */
    struct ThreadEvent *eventPtr;   /* Back pointer */
    struct ThreadEventResult *nextPtr;    /* List for cleanup */
    struct ThreadEventResult *prevPtr;

} ThreadEventResult;

static ThreadEventResult *resultList;

/*
 * This is for simple error handling when a thread script exits badly.
 */

static Tcl_ThreadId errorThreadId;
static char *errorProcString;

/*
 * Access to the list of threads and to the thread send results is guarded by
 * this mutex.
 */

TCL_DECLARE_MUTEX(threadMutex)

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLEXPORT

EXTERN int        TclThread_Init(Tcl_Interp *interp);
EXTERN int        Tcl_ThreadObjCmd(ClientData clientData,
                      Tcl_Interp *interp, int objc,
                      Tcl_Obj *const objv[]);
EXTERN int        TclCreateThread(Tcl_Interp *interp, char *script,
                      int joinable);
EXTERN int        TclThreadList(Tcl_Interp *interp);
EXTERN int        TclThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
                      char *script, int wait);

#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT

Tcl_ThreadCreateType    NewTestThread(ClientData clientData);
static void       ListRemove(ThreadSpecificData *tsdPtr);
static void       ListUpdateInner(ThreadSpecificData *tsdPtr);
static int        ThreadEventProc(Tcl_Event *evPtr, int mask);
static void       ThreadErrorProc(Tcl_Interp *interp);
static void       ThreadFreeProc(ClientData clientData);
static int        ThreadDeleteEvent(Tcl_Event *eventPtr,
                      ClientData clientData);
static void       ThreadExitProc(ClientData clientData);

/*
 *----------------------------------------------------------------------
 *
 * TclThread_Init --
 *
 *    Initialize the test thread command.
 *
 * Results:
 *      TCL_OK if the package was properly initialized.
 *
 * Side effects:
 *    Add the "testthread" command to the interp.
 *
 *----------------------------------------------------------------------
 */

int
TclThread_Init(
    Tcl_Interp *interp)       /* The current Tcl interpreter */
{

    Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd,
          (ClientData) NULL, NULL);
    return TCL_OK;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_ThreadObjCmd --
 *
 *    This procedure is invoked to process the "testthread" Tcl command. See
 *    the user documentation for details on what it does.
 *
 *    thread create ?-joinable? ?script?
 *    thread send id ?-async? script
 *    thread exit
 *    thread info id
 *    thread names
 *    thread wait
 *    thread errorproc proc
 *    thread join id
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_ThreadObjCmd(
    ClientData dummy,         /* Not used. */
    Tcl_Interp *interp,       /* Current interpreter. */
    int objc,                 /* Number of arguments. */
    Tcl_Obj *const objv[])    /* Argument objects. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int option;
    static const char *threadOptions[] = {
      "create", "exit", "id", "join", "names",
      "send", "wait", "errorproc", NULL
    };
    enum options {
      THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
      THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
    };

    if (objc < 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
      return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
          &option) != TCL_OK) {
      return TCL_ERROR;
    }

    /*
     * Make sure the initial thread is on the list before doing anything.
     */

    if (tsdPtr->interp == NULL) {
      Tcl_MutexLock(&threadMutex);
      tsdPtr->interp = interp;
      ListUpdateInner(tsdPtr);
      Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
      Tcl_MutexUnlock(&threadMutex);
    }

    switch ((enum options)option) {
    case THREAD_CREATE: {
      char *script;
      int joinable, len;

      if (objc == 2) {
          /*
           * Neither joinable nor special script
           */

          joinable = 0;
          script = "testthread wait";           /* Just enter event loop */
      } else if (objc == 3) {
          /*
           * Possibly -joinable, then no special script, no joinable, then
           * its a script.
           */

          script = Tcl_GetStringFromObj(objv[2], &len);

          if ((len > 1) &&
                (script [0] == '-') && (script [1] == 'j') &&
                (0 == strncmp (script, "-joinable", (size_t) len))) {
            joinable = 1;
            script = "testthread wait";   /* Just enter event loop */
          } else {
            /*
             * Remember the script
             */

            joinable = 0;
          }
      } else if (objc == 4) {
          /*
           * Definitely a script available, but is the flag -joinable?
           */

          script = Tcl_GetStringFromObj(objv[2], &len);

          joinable = ((len > 1) &&
                (script [0] == '-') && (script [1] == 'j') &&
                (0 == strncmp(script, "-joinable", (size_t) len)));

          script = Tcl_GetString(objv[3]);
      } else {
          Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
          return TCL_ERROR;
      }
      return TclCreateThread(interp, script, joinable);
    }
    case THREAD_EXIT:
      if (objc > 2) {
          Tcl_WrongNumArgs(interp, 2, objv, NULL);
          return TCL_ERROR;
      }
      ListRemove(NULL);
      Tcl_ExitThread(0);
      return TCL_OK;
    case THREAD_ID:
      if (objc == 2) {
          Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());

          Tcl_SetObjResult(interp, idObj);
          return TCL_OK;
      } else {
          Tcl_WrongNumArgs(interp, 2, objv, NULL);
          return TCL_ERROR;
      }
    case THREAD_JOIN: {
      long id;
      int result, status;

      if (objc != 3) {
          Tcl_WrongNumArgs(interp, 2, objv, "id");
          return TCL_ERROR;
      }
      if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
          return TCL_ERROR;
      }

      result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
      if (result == TCL_OK) {
          Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
      } else {
          char buf [20];

          sprintf(buf, "%ld", id);
          Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
      }
      return result;
    }
    case THREAD_NAMES:
      if (objc > 2) {
          Tcl_WrongNumArgs(interp, 2, objv, NULL);
          return TCL_ERROR;
      }
      return TclThreadList(interp);
    case THREAD_SEND: {
      long id;
      char *script;
      int wait, arg;

      if ((objc != 4) && (objc != 5)) {
          Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
          return TCL_ERROR;
      }
      if (objc == 5) {
          if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
            Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
            return TCL_ERROR;
          }
          wait = 0;
          arg = 3;
      } else {
          wait = 1;
          arg = 2;
      }
      if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
          return TCL_ERROR;
      }
      arg++;
      script = Tcl_GetString(objv[arg]);
      return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
    }
    case THREAD_ERRORPROC: {
      /*
       * Arrange for this proc to handle thread death errors.
       */

      char *proc;

      if (objc != 3) {
          Tcl_WrongNumArgs(interp, 2, objv, "proc");
          return TCL_ERROR;
      }
      Tcl_MutexLock(&threadMutex);
      errorThreadId = Tcl_GetCurrentThread();
      if (errorProcString) {
          ckfree(errorProcString);
      }
      proc = Tcl_GetString(objv[2]);
      errorProcString = ckalloc(strlen(proc)+1);
      strcpy(errorProcString, proc);
      Tcl_MutexUnlock(&threadMutex);
      return TCL_OK;
    }
    case THREAD_WAIT:
      while (1) {
          (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
      }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCreateThread --
 *
 *    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.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
TclCreateThread(
    Tcl_Interp *interp,       /* Current interpreter. */
    char *script,       /* Script to execute */
    int joinable)       /* Flag, joinable thread or not */
{
    ThreadCtrl ctrl;
    Tcl_ThreadId id;

    ctrl.script = script;
    ctrl.condWait = NULL;
    ctrl.flags = 0;

    joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;

    Tcl_MutexLock(&threadMutex);
    if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
          TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
      Tcl_MutexUnlock(&threadMutex);
        Tcl_AppendResult(interp, "can't create a new thread", NULL);
      ckfree((char *) ctrl.script);
      return TCL_ERROR;
    }

    /*
     * Wait for the thread to start because it is using something on our stack!
     */

    Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
    Tcl_MutexUnlock(&threadMutex);
    Tcl_ConditionFinalize(&ctrl.condWait);
    Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * NewTestThread --
 *
 *    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.
 *
 *    Space to hold the script field of the ThreadControl structure passed
 *    in as the only argument was obtained from malloc() and must be freed
 *    by this function before it exits. Space to hold the ThreadControl
 *    structure itself is released by the calling function, and the two
 *    condition variables in the ThreadControl structure are destroyed by
 *    the calling function. 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
NewTestThread(
    ClientData clientData)
{
    ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    int result;
    char *threadEvalScript;

    /*
     * Initialize the interpreter.  This should be more general.
     */

    tsdPtr->interp = Tcl_CreateInterp();
    result = Tcl_Init(tsdPtr->interp);
    result = TclThread_Init(tsdPtr->interp);

    /*
     * This is part of the test facility. Initialize _ALL_ test commands for
     * use by the new thread.
     */

    result = Tcltest_Init(tsdPtr->interp);

    /*
     * Update the list of threads.
     */

    Tcl_MutexLock(&threadMutex);
    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
     */

    threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1);
    strcpy(threadEvalScript, ctrlPtr->script);

    Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);

    /*
     * Notify the parent we are alive.
     */

    Tcl_ConditionNotify(&ctrlPtr->condWait);
    Tcl_MutexUnlock(&threadMutex);

    /*
     * Run the script.
     */

    Tcl_Preserve((ClientData) tsdPtr->interp);
    result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
    if (result != TCL_OK) {
      ThreadErrorProc(tsdPtr->interp);
    }

    /*
     * Clean up.
     */

    ListRemove(tsdPtr);
    Tcl_Release((ClientData) tsdPtr->interp);
    Tcl_DeleteInterp(tsdPtr->interp);
    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(
    Tcl_Interp *interp)       /* Interp that failed */
{
    Tcl_Channel errChannel;
    const char *errorInfo, *argv[3];
    char *script;
    char buf[TCL_DOUBLE_SPACE+1];
    sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());

    errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
    if (errorProcString == NULL) {
      errChannel = Tcl_GetStdChannel(TCL_STDERR);
      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);
    } else {
      argv[0] = errorProcString;
      argv[1] = buf;
      argv[2] = errorInfo;
      script = Tcl_Merge(3, argv);
      TclThreadSend(interp, errorThreadId, script, 0);
      ckfree(script);
    }
}


/*
 *------------------------------------------------------------------------
 *
 * ListUpdateInner --
 *
 *    Add the thread local storage to the list. This assumes the caller has
 *    obtained the mutex.
 *
 * Results:
 *    None
 *
 * Side effects:
 *    Add the thread local storage to its list.
 *
 *------------------------------------------------------------------------
 */

static void
ListUpdateInner(
    ThreadSpecificData *tsdPtr)
{
    if (tsdPtr == NULL) {
      tsdPtr = TCL_TSD_INIT(&dataKey);
    }
    tsdPtr->threadId = Tcl_GetCurrentThread();
    tsdPtr->nextPtr = threadList;
    if (threadList) {
      threadList->prevPtr = tsdPtr;
    }
    tsdPtr->prevPtr = NULL;
    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(
    ThreadSpecificData *tsdPtr)
{
    if (tsdPtr == NULL) {
      tsdPtr = TCL_TSD_INIT(&dataKey);
    }
    Tcl_MutexLock(&threadMutex);
    if (tsdPtr->prevPtr) {
      tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
    } else {
      threadList = tsdPtr->nextPtr;
    }
    if (tsdPtr->nextPtr) {
      tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
    }
    tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
    Tcl_MutexUnlock(&threadMutex);
}

/*
 *------------------------------------------------------------------------
 *
 * TclThreadList --
 *
 *    Return a list of threads running Tcl interpreters.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */
int
TclThreadList(
    Tcl_Interp *interp)
{
    ThreadSpecificData *tsdPtr;
    Tcl_Obj *listPtr;

    listPtr = Tcl_NewListObj(0, NULL);
    Tcl_MutexLock(&threadMutex);
    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
      Tcl_ListObjAppendElement(interp, listPtr,
            Tcl_NewLongObj((long) tsdPtr->threadId));
    }
    Tcl_MutexUnlock(&threadMutex);
    Tcl_SetObjResult(interp, listPtr);
    return TCL_OK;
}

/*
 *------------------------------------------------------------------------
 *
 * TclThreadSend --
 *
 *    Send a script to another thread.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    None.
 *
 *------------------------------------------------------------------------
 */

int
TclThreadSend(
    Tcl_Interp *interp,       /* The current interpreter. */
    Tcl_ThreadId id,          /* Thread Id of other interpreter. */
    char *script,       /* The script to evaluate. */
    int wait)                 /* If 1, we block for the result. */
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadEvent *threadEventPtr;
    ThreadEventResult *resultPtr;
    int found, code;
    Tcl_ThreadId threadId = (Tcl_ThreadId) id;

    /*
     * Verify the thread exists.
     */

    Tcl_MutexLock(&threadMutex);
    found = 0;
    for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
      if (tsdPtr->threadId == threadId) {
          found = 1;
          break;
      }
    }
    if (!found) {
      Tcl_MutexUnlock(&threadMutex);
      Tcl_AppendResult(interp, "invalid thread id", NULL);
      return TCL_ERROR;
    }

    /*
     * Short circut sends to ourself. Ought to do something with -async, like
     * run in an idle handler.
     */

    if (threadId == Tcl_GetCurrentThread()) {
        Tcl_MutexUnlock(&threadMutex);
      return Tcl_GlobalEval(interp, script);
    }

    /*
     * Create the event for its event queue.
     */

    threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
    threadEventPtr->script = ckalloc(strlen(script) + 1);
    strcpy(threadEventPtr->script, script);
    if (!wait) {
      resultPtr = threadEventPtr->resultPtr = NULL;
    } else {
      resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
      threadEventPtr->resultPtr = resultPtr;

      /*
       * Initialize the result fields.
       */

      resultPtr->done = NULL;
      resultPtr->code = 0;
      resultPtr->result = NULL;
      resultPtr->errorInfo = NULL;
      resultPtr->errorCode = NULL;

      /*
       * Maintain the cleanup list.
       */

      resultPtr->srcThreadId = Tcl_GetCurrentThread();
      resultPtr->dstThreadId = threadId;
      resultPtr->eventPtr = threadEventPtr;
      resultPtr->nextPtr = resultList;
      if (resultList) {
          resultList->prevPtr = resultPtr;
      }
      resultPtr->prevPtr = NULL;
      resultList = resultPtr;
    }

    /*
     * Queue the event and poke the other thread's notifier.
     */

    threadEventPtr->event.proc = ThreadEventProc;
    Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
          TCL_QUEUE_TAIL);
    Tcl_ThreadAlert(threadId);

    if (!wait) {
      Tcl_MutexUnlock(&threadMutex);
      return TCL_OK;
    }

    /*
     * Block on the results and then get them.
     */

    Tcl_ResetResult(interp);
    while (resultPtr->result == NULL) {
        Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
    }

    /*
     * Unlink result from the result list.
     */

    if (resultPtr->prevPtr) {
      resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
    } else {
      resultList = resultPtr->nextPtr;
    }
    if (resultPtr->nextPtr) {
      resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
    }
    resultPtr->eventPtr = NULL;
    resultPtr->nextPtr = NULL;
    resultPtr->prevPtr = NULL;

    Tcl_MutexUnlock(&threadMutex);

    if (resultPtr->code != TCL_OK) {
      if (resultPtr->errorCode) {
          Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
          ckfree(resultPtr->errorCode);
      }
      if (resultPtr->errorInfo) {
          Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
          ckfree(resultPtr->errorInfo);
      }
    }
    Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
    Tcl_ConditionFinalize(&resultPtr->done);
    code = resultPtr->code;

    ckfree((char *) resultPtr);

    return code;
}

/*
 *------------------------------------------------------------------------
 *
 * 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(
    Tcl_Event *evPtr,         /* Really ThreadEvent */
    int mask)
{
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
    ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
    ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
    Tcl_Interp *interp = tsdPtr->interp;
    int code;
    const char *result, *errorCode, *errorInfo;

    if (interp == NULL) {
      code = TCL_ERROR;
      result = "no target interp!";
      errorCode = "THREAD";
      errorInfo = "";
    } else {
      Tcl_Preserve((ClientData) interp);
      Tcl_ResetResult(interp);
      Tcl_CreateThreadExitHandler(ThreadFreeProc,
            (ClientData) threadEventPtr->script);
      code = Tcl_GlobalEval(interp, threadEventPtr->script);
      Tcl_DeleteThreadExitHandler(ThreadFreeProc,
            (ClientData) threadEventPtr->script);
      if (code != TCL_OK) {
          errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
          errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
      } else {
          errorCode = errorInfo = NULL;
      }
      result = Tcl_GetStringResult(interp);
    }
    ckfree(threadEventPtr->script);
    if (resultPtr) {
      Tcl_MutexLock(&threadMutex);
      resultPtr->code = code;
      resultPtr->result = ckalloc(strlen(result) + 1);
      strcpy(resultPtr->result, result);
      if (errorCode != NULL) {
          resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
          strcpy(resultPtr->errorCode, errorCode);
      }
      if (errorInfo != NULL) {
          resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
          strcpy(resultPtr->errorInfo, errorInfo);
      }
      Tcl_ConditionNotify(&resultPtr->done);
      Tcl_MutexUnlock(&threadMutex);
    }
    if (interp != NULL) {
      Tcl_Release((ClientData) interp);
    }
    return 1;
}

/*
 *------------------------------------------------------------------------
 *
 * ThreadFreeProc --
 *
 *    This is called from when we are exiting and memory needs
 *    to be freed.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Clears up mem specified in ClientData
 *
 *------------------------------------------------------------------------
 */

     /* ARGSUSED */
static void
ThreadFreeProc(
    ClientData clientData)
{
    if (clientData) {
      ckfree((char *) clientData);
    }
}

/*
 *------------------------------------------------------------------------
 *
 * 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.
 *
 *------------------------------------------------------------------------
 */

     /* ARGSUSED */
static int
ThreadDeleteEvent(
    Tcl_Event *eventPtr,      /* Really ThreadEvent */
    ClientData clientData)    /* dummy */
{
    if (eventPtr->proc == ThreadEventProc) {
      ckfree((char *) ((ThreadEvent *) eventPtr)->script);
      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.
 *
 *------------------------------------------------------------------------
 */

     /* ARGSUSED */
static void
ThreadExitProc(
    ClientData clientData)
{
    char *threadEvalScript = (char *) clientData;
    ThreadEventResult *resultPtr, *nextPtr;
    Tcl_ThreadId self = Tcl_GetCurrentThread();

    Tcl_MutexLock(&threadMutex);

    if (threadEvalScript) {
      ckfree((char *) threadEvalScript);
      threadEvalScript = NULL;
    }
    Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);

    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.
           */

          if (resultPtr->prevPtr) {
            resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
          } else {
            resultList = resultPtr->nextPtr;
          }
          if (resultPtr->nextPtr) {
            resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
          }
          resultPtr->nextPtr = resultPtr->prevPtr = 0;
          resultPtr->eventPtr->resultPtr = NULL;
          ckfree((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.
           */

          char *msg = "target thread died";

          resultPtr->result = ckalloc(strlen(msg)+1);
          strcpy(resultPtr->result, msg);
          resultPtr->code = TCL_ERROR;
          Tcl_ConditionNotify(&resultPtr->done);
      }
    }
    Tcl_MutexUnlock(&threadMutex);
}
#endif /* TCL_THREADS */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index