tclThreadTest.c

Go to the documentation of this file.
00001 /*
00002  * tclThreadTest.c --
00003  *
00004  *      This file implements the testthread command. Eventually this should be
00005  *      tclThreadCmd.c
00006  *      Some of this code is based on work done by Richard Hipp on behalf of
00007  *      Conservation Through Innovation, Limited, with their permission.
00008  *
00009  * Copyright (c) 1998 by Sun Microsystems, Inc.
00010  *
00011  * See the file "license.terms" for information on usage and redistribution of
00012  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00013  *
00014  * RCS: @(#) $Id: tclThreadTest.c,v 1.24 2006/09/22 14:45:48 dkf Exp $
00015  */
00016 
00017 #include "tclInt.h"
00018 
00019 extern int      Tcltest_Init(Tcl_Interp *interp);
00020 
00021 #ifdef TCL_THREADS
00022 /*
00023  * Each thread has an single instance of the following structure. There is one
00024  * instance of this structure per thread even if that thread contains multiple
00025  * interpreters. The interpreter identified by this structure is the main
00026  * interpreter for the thread.
00027  *
00028  * The main interpreter is the one that will process any messages received by
00029  * a thread. Any thread can send messages but only the main interpreter can
00030  * receive them.
00031  */
00032 
00033 typedef struct ThreadSpecificData {
00034     Tcl_ThreadId  threadId;          /* Tcl ID for this thread */
00035     Tcl_Interp *interp;              /* Main interpreter for this thread */
00036     int flags;                       /* See the TP_ defines below... */
00037     struct ThreadSpecificData *nextPtr; /* List for "thread names" */
00038     struct ThreadSpecificData *prevPtr; /* List for "thread names" */
00039 } ThreadSpecificData;
00040 static Tcl_ThreadDataKey dataKey;
00041 
00042 /*
00043  * This list is used to list all threads that have interpreters. This is
00044  * protected by threadMutex.
00045  */
00046 
00047 static struct ThreadSpecificData *threadList;
00048 
00049 /*
00050  * The following bit-values are legal for the "flags" field of the
00051  * ThreadSpecificData structure.
00052  */
00053 #define TP_Dying               0x001 /* This thread is being cancelled */
00054 
00055 /*
00056  * An instance of the following structure contains all information that is
00057  * passed into a new thread when the thread is created using either the
00058  * "thread create" Tcl command or the TclCreateThread() C function.
00059  */
00060 
00061 typedef struct ThreadCtrl {
00062     char *script;               /* The Tcl command this thread should
00063                                  * execute */
00064     int flags;                  /* Initial value of the "flags" field in the
00065                                  * ThreadSpecificData structure for the new
00066                                  * thread. Might contain TP_Detached or
00067                                  * TP_TclThread. */
00068     Tcl_Condition condWait;     /* This condition variable is used to
00069                                  * synchronize the parent and child threads.
00070                                  * The child won't run until it acquires
00071                                  * threadMutex, and the parent function won't
00072                                  * complete until signaled on this condition
00073                                  * variable. */
00074 } ThreadCtrl;
00075 
00076 /*
00077  * This is the event used to send scripts to other threads.
00078  */
00079 
00080 typedef struct ThreadEvent {
00081     Tcl_Event event;            /* Must be first */
00082     char *script;               /* The script to execute. */
00083     struct ThreadEventResult *resultPtr;
00084                                 /* To communicate the result. This is NULL if
00085                                  * we don't care about it. */
00086 } ThreadEvent;
00087 
00088 typedef struct ThreadEventResult {
00089     Tcl_Condition done;         /* Signaled when the script completes */
00090     int code;                   /* Return value of Tcl_Eval */
00091     char *result;               /* Result from the script */
00092     char *errorInfo;            /* Copy of errorInfo variable */
00093     char *errorCode;            /* Copy of errorCode variable */
00094     Tcl_ThreadId srcThreadId;   /* Id of sending thread, in case it dies */
00095     Tcl_ThreadId dstThreadId;   /* Id of target thread, in case it dies */
00096     struct ThreadEvent *eventPtr;       /* Back pointer */
00097     struct ThreadEventResult *nextPtr;  /* List for cleanup */
00098     struct ThreadEventResult *prevPtr;
00099 
00100 } ThreadEventResult;
00101 
00102 static ThreadEventResult *resultList;
00103 
00104 /*
00105  * This is for simple error handling when a thread script exits badly.
00106  */
00107 
00108 static Tcl_ThreadId errorThreadId;
00109 static char *errorProcString;
00110 
00111 /*
00112  * Access to the list of threads and to the thread send results is guarded by
00113  * this mutex.
00114  */
00115 
00116 TCL_DECLARE_MUTEX(threadMutex)
00117 
00118 #undef TCL_STORAGE_CLASS
00119 #define TCL_STORAGE_CLASS DLLEXPORT
00120 
00121 EXTERN int              TclThread_Init(Tcl_Interp *interp);
00122 EXTERN int              Tcl_ThreadObjCmd(ClientData clientData,
00123                             Tcl_Interp *interp, int objc,
00124                             Tcl_Obj *const objv[]);
00125 EXTERN int              TclCreateThread(Tcl_Interp *interp, char *script,
00126                             int joinable);
00127 EXTERN int              TclThreadList(Tcl_Interp *interp);
00128 EXTERN int              TclThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
00129                             char *script, int wait);
00130 
00131 #undef TCL_STORAGE_CLASS
00132 #define TCL_STORAGE_CLASS DLLIMPORT
00133 
00134 Tcl_ThreadCreateType    NewTestThread(ClientData clientData);
00135 static void             ListRemove(ThreadSpecificData *tsdPtr);
00136 static void             ListUpdateInner(ThreadSpecificData *tsdPtr);
00137 static int              ThreadEventProc(Tcl_Event *evPtr, int mask);
00138 static void             ThreadErrorProc(Tcl_Interp *interp);
00139 static void             ThreadFreeProc(ClientData clientData);
00140 static int              ThreadDeleteEvent(Tcl_Event *eventPtr,
00141                             ClientData clientData);
00142 static void             ThreadExitProc(ClientData clientData);
00143 
00144 /*
00145  *----------------------------------------------------------------------
00146  *
00147  * TclThread_Init --
00148  *
00149  *      Initialize the test thread command.
00150  *
00151  * Results:
00152  *      TCL_OK if the package was properly initialized.
00153  *
00154  * Side effects:
00155  *      Add the "testthread" command to the interp.
00156  *
00157  *----------------------------------------------------------------------
00158  */
00159 
00160 int
00161 TclThread_Init(
00162     Tcl_Interp *interp)         /* The current Tcl interpreter */
00163 {
00164 
00165     Tcl_CreateObjCommand(interp, "testthread", Tcl_ThreadObjCmd,
00166             (ClientData) NULL, NULL);
00167     return TCL_OK;
00168 }
00169 
00170 
00171 /*
00172  *----------------------------------------------------------------------
00173  *
00174  * Tcl_ThreadObjCmd --
00175  *
00176  *      This procedure is invoked to process the "testthread" Tcl command. See
00177  *      the user documentation for details on what it does.
00178  *
00179  *      thread create ?-joinable? ?script?
00180  *      thread send id ?-async? script
00181  *      thread exit
00182  *      thread info id
00183  *      thread names
00184  *      thread wait
00185  *      thread errorproc proc
00186  *      thread join id
00187  *
00188  * Results:
00189  *      A standard Tcl result.
00190  *
00191  * Side effects:
00192  *      See the user documentation.
00193  *
00194  *----------------------------------------------------------------------
00195  */
00196 
00197         /* ARGSUSED */
00198 int
00199 Tcl_ThreadObjCmd(
00200     ClientData dummy,           /* Not used. */
00201     Tcl_Interp *interp,         /* Current interpreter. */
00202     int objc,                   /* Number of arguments. */
00203     Tcl_Obj *const objv[])      /* Argument objects. */
00204 {
00205     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
00206     int option;
00207     static const char *threadOptions[] = {
00208         "create", "exit", "id", "join", "names",
00209         "send", "wait", "errorproc", NULL
00210     };
00211     enum options {
00212         THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES,
00213         THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC
00214     };
00215 
00216     if (objc < 2) {
00217         Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
00218         return TCL_ERROR;
00219     }
00220     if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
00221             &option) != TCL_OK) {
00222         return TCL_ERROR;
00223     }
00224 
00225     /*
00226      * Make sure the initial thread is on the list before doing anything.
00227      */
00228 
00229     if (tsdPtr->interp == NULL) {
00230         Tcl_MutexLock(&threadMutex);
00231         tsdPtr->interp = interp;
00232         ListUpdateInner(tsdPtr);
00233         Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
00234         Tcl_MutexUnlock(&threadMutex);
00235     }
00236 
00237     switch ((enum options)option) {
00238     case THREAD_CREATE: {
00239         char *script;
00240         int joinable, len;
00241 
00242         if (objc == 2) {
00243             /*
00244              * Neither joinable nor special script
00245              */
00246 
00247             joinable = 0;
00248             script = "testthread wait";         /* Just enter event loop */
00249         } else if (objc == 3) {
00250             /*
00251              * Possibly -joinable, then no special script, no joinable, then
00252              * its a script.
00253              */
00254 
00255             script = Tcl_GetStringFromObj(objv[2], &len);
00256 
00257             if ((len > 1) &&
00258                     (script [0] == '-') && (script [1] == 'j') &&
00259                     (0 == strncmp (script, "-joinable", (size_t) len))) {
00260                 joinable = 1;
00261                 script = "testthread wait";     /* Just enter event loop */
00262             } else {
00263                 /*
00264                  * Remember the script
00265                  */
00266 
00267                 joinable = 0;
00268             }
00269         } else if (objc == 4) {
00270             /*
00271              * Definitely a script available, but is the flag -joinable?
00272              */
00273 
00274             script = Tcl_GetStringFromObj(objv[2], &len);
00275 
00276             joinable = ((len > 1) &&
00277                     (script [0] == '-') && (script [1] == 'j') &&
00278                     (0 == strncmp(script, "-joinable", (size_t) len)));
00279 
00280             script = Tcl_GetString(objv[3]);
00281         } else {
00282             Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
00283             return TCL_ERROR;
00284         }
00285         return TclCreateThread(interp, script, joinable);
00286     }
00287     case THREAD_EXIT:
00288         if (objc > 2) {
00289             Tcl_WrongNumArgs(interp, 2, objv, NULL);
00290             return TCL_ERROR;
00291         }
00292         ListRemove(NULL);
00293         Tcl_ExitThread(0);
00294         return TCL_OK;
00295     case THREAD_ID:
00296         if (objc == 2) {
00297             Tcl_Obj *idObj = Tcl_NewLongObj((long) Tcl_GetCurrentThread());
00298 
00299             Tcl_SetObjResult(interp, idObj);
00300             return TCL_OK;
00301         } else {
00302             Tcl_WrongNumArgs(interp, 2, objv, NULL);
00303             return TCL_ERROR;
00304         }
00305     case THREAD_JOIN: {
00306         long id;
00307         int result, status;
00308 
00309         if (objc != 3) {
00310             Tcl_WrongNumArgs(interp, 2, objv, "id");
00311             return TCL_ERROR;
00312         }
00313         if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
00314             return TCL_ERROR;
00315         }
00316 
00317         result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
00318         if (result == TCL_OK) {
00319             Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
00320         } else {
00321             char buf [20];
00322 
00323             sprintf(buf, "%ld", id);
00324             Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
00325         }
00326         return result;
00327     }
00328     case THREAD_NAMES:
00329         if (objc > 2) {
00330             Tcl_WrongNumArgs(interp, 2, objv, NULL);
00331             return TCL_ERROR;
00332         }
00333         return TclThreadList(interp);
00334     case THREAD_SEND: {
00335         long id;
00336         char *script;
00337         int wait, arg;
00338 
00339         if ((objc != 4) && (objc != 5)) {
00340             Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
00341             return TCL_ERROR;
00342         }
00343         if (objc == 5) {
00344             if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
00345                 Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
00346                 return TCL_ERROR;
00347             }
00348             wait = 0;
00349             arg = 3;
00350         } else {
00351             wait = 1;
00352             arg = 2;
00353         }
00354         if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
00355             return TCL_ERROR;
00356         }
00357         arg++;
00358         script = Tcl_GetString(objv[arg]);
00359         return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
00360     }
00361     case THREAD_ERRORPROC: {
00362         /*
00363          * Arrange for this proc to handle thread death errors.
00364          */
00365 
00366         char *proc;
00367 
00368         if (objc != 3) {
00369             Tcl_WrongNumArgs(interp, 2, objv, "proc");
00370             return TCL_ERROR;
00371         }
00372         Tcl_MutexLock(&threadMutex);
00373         errorThreadId = Tcl_GetCurrentThread();
00374         if (errorProcString) {
00375             ckfree(errorProcString);
00376         }
00377         proc = Tcl_GetString(objv[2]);
00378         errorProcString = ckalloc(strlen(proc)+1);
00379         strcpy(errorProcString, proc);
00380         Tcl_MutexUnlock(&threadMutex);
00381         return TCL_OK;
00382     }
00383     case THREAD_WAIT:
00384         while (1) {
00385             (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
00386         }
00387     }
00388     return TCL_OK;
00389 }
00390 
00391 /*
00392  *----------------------------------------------------------------------
00393  *
00394  * TclCreateThread --
00395  *
00396  *      This procedure is invoked to create a thread containing an interp to
00397  *      run a script. This returns after the thread has started executing.
00398  *
00399  * Results:
00400  *      A standard Tcl result, which is the thread ID.
00401  *
00402  * Side effects:
00403  *      Create a thread.
00404  *
00405  *----------------------------------------------------------------------
00406  */
00407 
00408         /* ARGSUSED */
00409 int
00410 TclCreateThread(
00411     Tcl_Interp *interp,         /* Current interpreter. */
00412     char *script,               /* Script to execute */
00413     int joinable)               /* Flag, joinable thread or not */
00414 {
00415     ThreadCtrl ctrl;
00416     Tcl_ThreadId id;
00417 
00418     ctrl.script = script;
00419     ctrl.condWait = NULL;
00420     ctrl.flags = 0;
00421 
00422     joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
00423 
00424     Tcl_MutexLock(&threadMutex);
00425     if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
00426             TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
00427         Tcl_MutexUnlock(&threadMutex);
00428         Tcl_AppendResult(interp, "can't create a new thread", NULL);
00429         ckfree((char *) ctrl.script);
00430         return TCL_ERROR;
00431     }
00432 
00433     /*
00434      * Wait for the thread to start because it is using something on our stack!
00435      */
00436 
00437     Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
00438     Tcl_MutexUnlock(&threadMutex);
00439     Tcl_ConditionFinalize(&ctrl.condWait);
00440     Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
00441     return TCL_OK;
00442 }
00443 
00444 /*
00445  *------------------------------------------------------------------------
00446  *
00447  * NewTestThread --
00448  *
00449  *      This routine is the "main()" for a new thread whose task is to execute
00450  *      a single Tcl script. The argument to this function is a pointer to a
00451  *      structure that contains the text of the TCL script to be executed.
00452  *
00453  *      Space to hold the script field of the ThreadControl structure passed
00454  *      in as the only argument was obtained from malloc() and must be freed
00455  *      by this function before it exits. Space to hold the ThreadControl
00456  *      structure itself is released by the calling function, and the two
00457  *      condition variables in the ThreadControl structure are destroyed by
00458  *      the calling function. The calling function will destroy the
00459  *      ThreadControl structure and the condition variable as soon as
00460  *      ctrlPtr->condWait is signaled, so this routine must make copies of any
00461  *      data it might need after that point.
00462  *
00463  * Results:
00464  *      None
00465  *
00466  * Side effects:
00467  *      A Tcl script is executed in a new thread.
00468  *
00469  *------------------------------------------------------------------------
00470  */
00471 
00472 Tcl_ThreadCreateType
00473 NewTestThread(
00474     ClientData clientData)
00475 {
00476     ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
00477     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
00478     int result;
00479     char *threadEvalScript;
00480 
00481     /*
00482      * Initialize the interpreter.  This should be more general.
00483      */
00484 
00485     tsdPtr->interp = Tcl_CreateInterp();
00486     result = Tcl_Init(tsdPtr->interp);
00487     result = TclThread_Init(tsdPtr->interp);
00488 
00489     /*
00490      * This is part of the test facility. Initialize _ALL_ test commands for
00491      * use by the new thread.
00492      */
00493 
00494     result = Tcltest_Init(tsdPtr->interp);
00495 
00496     /*
00497      * Update the list of threads.
00498      */
00499 
00500     Tcl_MutexLock(&threadMutex);
00501     ListUpdateInner(tsdPtr);
00502 
00503     /*
00504      * We need to keep a pointer to the alloc'ed mem of the script we are
00505      * eval'ing, for the case that we exit during evaluation
00506      */
00507 
00508     threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1);
00509     strcpy(threadEvalScript, ctrlPtr->script);
00510 
00511     Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
00512 
00513     /*
00514      * Notify the parent we are alive.
00515      */
00516 
00517     Tcl_ConditionNotify(&ctrlPtr->condWait);
00518     Tcl_MutexUnlock(&threadMutex);
00519 
00520     /*
00521      * Run the script.
00522      */
00523 
00524     Tcl_Preserve((ClientData) tsdPtr->interp);
00525     result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
00526     if (result != TCL_OK) {
00527         ThreadErrorProc(tsdPtr->interp);
00528     }
00529 
00530     /*
00531      * Clean up.
00532      */
00533 
00534     ListRemove(tsdPtr);
00535     Tcl_Release((ClientData) tsdPtr->interp);
00536     Tcl_DeleteInterp(tsdPtr->interp);
00537     Tcl_ExitThread(result);
00538 
00539     TCL_THREAD_CREATE_RETURN;
00540 }
00541 
00542 /*
00543  *------------------------------------------------------------------------
00544  *
00545  * ThreadErrorProc --
00546  *
00547  *      Send a message to the thread willing to hear about errors.
00548  *
00549  * Results:
00550  *      None
00551  *
00552  * Side effects:
00553  *      Send an event.
00554  *
00555  *------------------------------------------------------------------------
00556  */
00557 
00558 static void
00559 ThreadErrorProc(
00560     Tcl_Interp *interp)         /* Interp that failed */
00561 {
00562     Tcl_Channel errChannel;
00563     const char *errorInfo, *argv[3];
00564     char *script;
00565     char buf[TCL_DOUBLE_SPACE+1];
00566     sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
00567 
00568     errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
00569     if (errorProcString == NULL) {
00570         errChannel = Tcl_GetStdChannel(TCL_STDERR);
00571         Tcl_WriteChars(errChannel, "Error from thread ", -1);
00572         Tcl_WriteChars(errChannel, buf, -1);
00573         Tcl_WriteChars(errChannel, "\n", 1);
00574         Tcl_WriteChars(errChannel, errorInfo, -1);
00575         Tcl_WriteChars(errChannel, "\n", 1);
00576     } else {
00577         argv[0] = errorProcString;
00578         argv[1] = buf;
00579         argv[2] = errorInfo;
00580         script = Tcl_Merge(3, argv);
00581         TclThreadSend(interp, errorThreadId, script, 0);
00582         ckfree(script);
00583     }
00584 }
00585 
00586 
00587 /*
00588  *------------------------------------------------------------------------
00589  *
00590  * ListUpdateInner --
00591  *
00592  *      Add the thread local storage to the list. This assumes the caller has
00593  *      obtained the mutex.
00594  *
00595  * Results:
00596  *      None
00597  *
00598  * Side effects:
00599  *      Add the thread local storage to its list.
00600  *
00601  *------------------------------------------------------------------------
00602  */
00603 
00604 static void
00605 ListUpdateInner(
00606     ThreadSpecificData *tsdPtr)
00607 {
00608     if (tsdPtr == NULL) {
00609         tsdPtr = TCL_TSD_INIT(&dataKey);
00610     }
00611     tsdPtr->threadId = Tcl_GetCurrentThread();
00612     tsdPtr->nextPtr = threadList;
00613     if (threadList) {
00614         threadList->prevPtr = tsdPtr;
00615     }
00616     tsdPtr->prevPtr = NULL;
00617     threadList = tsdPtr;
00618 }
00619 
00620 /*
00621  *------------------------------------------------------------------------
00622  *
00623  * ListRemove --
00624  *
00625  *      Remove the thread local storage from its list. This grabs the mutex to
00626  *      protect the list.
00627  *
00628  * Results:
00629  *      None
00630  *
00631  * Side effects:
00632  *      Remove the thread local storage from its list.
00633  *
00634  *------------------------------------------------------------------------
00635  */
00636 
00637 static void
00638 ListRemove(
00639     ThreadSpecificData *tsdPtr)
00640 {
00641     if (tsdPtr == NULL) {
00642         tsdPtr = TCL_TSD_INIT(&dataKey);
00643     }
00644     Tcl_MutexLock(&threadMutex);
00645     if (tsdPtr->prevPtr) {
00646         tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
00647     } else {
00648         threadList = tsdPtr->nextPtr;
00649     }
00650     if (tsdPtr->nextPtr) {
00651         tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
00652     }
00653     tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
00654     Tcl_MutexUnlock(&threadMutex);
00655 }
00656 
00657 /*
00658  *------------------------------------------------------------------------
00659  *
00660  * TclThreadList --
00661  *
00662  *    Return a list of threads running Tcl interpreters.
00663  *
00664  * Results:
00665  *    A standard Tcl result.
00666  *
00667  * Side effects:
00668  *    None.
00669  *
00670  *------------------------------------------------------------------------
00671  */
00672 int
00673 TclThreadList(
00674     Tcl_Interp *interp)
00675 {
00676     ThreadSpecificData *tsdPtr;
00677     Tcl_Obj *listPtr;
00678 
00679     listPtr = Tcl_NewListObj(0, NULL);
00680     Tcl_MutexLock(&threadMutex);
00681     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
00682         Tcl_ListObjAppendElement(interp, listPtr,
00683                 Tcl_NewLongObj((long) tsdPtr->threadId));
00684     }
00685     Tcl_MutexUnlock(&threadMutex);
00686     Tcl_SetObjResult(interp, listPtr);
00687     return TCL_OK;
00688 }
00689 
00690 /*
00691  *------------------------------------------------------------------------
00692  *
00693  * TclThreadSend --
00694  *
00695  *    Send a script to another thread.
00696  *
00697  * Results:
00698  *    A standard Tcl result.
00699  *
00700  * Side effects:
00701  *    None.
00702  *
00703  *------------------------------------------------------------------------
00704  */
00705 
00706 int
00707 TclThreadSend(
00708     Tcl_Interp *interp,         /* The current interpreter. */
00709     Tcl_ThreadId id,            /* Thread Id of other interpreter. */
00710     char *script,               /* The script to evaluate. */
00711     int wait)                   /* If 1, we block for the result. */
00712 {
00713     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
00714     ThreadEvent *threadEventPtr;
00715     ThreadEventResult *resultPtr;
00716     int found, code;
00717     Tcl_ThreadId threadId = (Tcl_ThreadId) id;
00718 
00719     /*
00720      * Verify the thread exists.
00721      */
00722 
00723     Tcl_MutexLock(&threadMutex);
00724     found = 0;
00725     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
00726         if (tsdPtr->threadId == threadId) {
00727             found = 1;
00728             break;
00729         }
00730     }
00731     if (!found) {
00732         Tcl_MutexUnlock(&threadMutex);
00733         Tcl_AppendResult(interp, "invalid thread id", NULL);
00734         return TCL_ERROR;
00735     }
00736 
00737     /*
00738      * Short circut sends to ourself. Ought to do something with -async, like
00739      * run in an idle handler.
00740      */
00741 
00742     if (threadId == Tcl_GetCurrentThread()) {
00743         Tcl_MutexUnlock(&threadMutex);
00744         return Tcl_GlobalEval(interp, script);
00745     }
00746 
00747     /*
00748      * Create the event for its event queue.
00749      */
00750 
00751     threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
00752     threadEventPtr->script = ckalloc(strlen(script) + 1);
00753     strcpy(threadEventPtr->script, script);
00754     if (!wait) {
00755         resultPtr = threadEventPtr->resultPtr = NULL;
00756     } else {
00757         resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
00758         threadEventPtr->resultPtr = resultPtr;
00759 
00760         /*
00761          * Initialize the result fields.
00762          */
00763 
00764         resultPtr->done = NULL;
00765         resultPtr->code = 0;
00766         resultPtr->result = NULL;
00767         resultPtr->errorInfo = NULL;
00768         resultPtr->errorCode = NULL;
00769 
00770         /*
00771          * Maintain the cleanup list.
00772          */
00773 
00774         resultPtr->srcThreadId = Tcl_GetCurrentThread();
00775         resultPtr->dstThreadId = threadId;
00776         resultPtr->eventPtr = threadEventPtr;
00777         resultPtr->nextPtr = resultList;
00778         if (resultList) {
00779             resultList->prevPtr = resultPtr;
00780         }
00781         resultPtr->prevPtr = NULL;
00782         resultList = resultPtr;
00783     }
00784 
00785     /*
00786      * Queue the event and poke the other thread's notifier.
00787      */
00788 
00789     threadEventPtr->event.proc = ThreadEventProc;
00790     Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
00791             TCL_QUEUE_TAIL);
00792     Tcl_ThreadAlert(threadId);
00793 
00794     if (!wait) {
00795         Tcl_MutexUnlock(&threadMutex);
00796         return TCL_OK;
00797     }
00798 
00799     /*
00800      * Block on the results and then get them.
00801      */
00802 
00803     Tcl_ResetResult(interp);
00804     while (resultPtr->result == NULL) {
00805         Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
00806     }
00807 
00808     /*
00809      * Unlink result from the result list.
00810      */
00811 
00812     if (resultPtr->prevPtr) {
00813         resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
00814     } else {
00815         resultList = resultPtr->nextPtr;
00816     }
00817     if (resultPtr->nextPtr) {
00818         resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
00819     }
00820     resultPtr->eventPtr = NULL;
00821     resultPtr->nextPtr = NULL;
00822     resultPtr->prevPtr = NULL;
00823 
00824     Tcl_MutexUnlock(&threadMutex);
00825 
00826     if (resultPtr->code != TCL_OK) {
00827         if (resultPtr->errorCode) {
00828             Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
00829             ckfree(resultPtr->errorCode);
00830         }
00831         if (resultPtr->errorInfo) {
00832             Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
00833             ckfree(resultPtr->errorInfo);
00834         }
00835     }
00836     Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
00837     Tcl_ConditionFinalize(&resultPtr->done);
00838     code = resultPtr->code;
00839 
00840     ckfree((char *) resultPtr);
00841 
00842     return code;
00843 }
00844 
00845 /*
00846  *------------------------------------------------------------------------
00847  *
00848  * ThreadEventProc --
00849  *
00850  *    Handle the event in the target thread.
00851  *
00852  * Results:
00853  *    Returns 1 to indicate that the event was processed.
00854  *
00855  * Side effects:
00856  *    Fills out the ThreadEventResult struct.
00857  *
00858  *------------------------------------------------------------------------
00859  */
00860 
00861 static int
00862 ThreadEventProc(
00863     Tcl_Event *evPtr,           /* Really ThreadEvent */
00864     int mask)
00865 {
00866     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
00867     ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
00868     ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
00869     Tcl_Interp *interp = tsdPtr->interp;
00870     int code;
00871     const char *result, *errorCode, *errorInfo;
00872 
00873     if (interp == NULL) {
00874         code = TCL_ERROR;
00875         result = "no target interp!";
00876         errorCode = "THREAD";
00877         errorInfo = "";
00878     } else {
00879         Tcl_Preserve((ClientData) interp);
00880         Tcl_ResetResult(interp);
00881         Tcl_CreateThreadExitHandler(ThreadFreeProc,
00882                 (ClientData) threadEventPtr->script);
00883         code = Tcl_GlobalEval(interp, threadEventPtr->script);
00884         Tcl_DeleteThreadExitHandler(ThreadFreeProc,
00885                 (ClientData) threadEventPtr->script);
00886         if (code != TCL_OK) {
00887             errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
00888             errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
00889         } else {
00890             errorCode = errorInfo = NULL;
00891         }
00892         result = Tcl_GetStringResult(interp);
00893     }
00894     ckfree(threadEventPtr->script);
00895     if (resultPtr) {
00896         Tcl_MutexLock(&threadMutex);
00897         resultPtr->code = code;
00898         resultPtr->result = ckalloc(strlen(result) + 1);
00899         strcpy(resultPtr->result, result);
00900         if (errorCode != NULL) {
00901             resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
00902             strcpy(resultPtr->errorCode, errorCode);
00903         }
00904         if (errorInfo != NULL) {
00905             resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
00906             strcpy(resultPtr->errorInfo, errorInfo);
00907         }
00908         Tcl_ConditionNotify(&resultPtr->done);
00909         Tcl_MutexUnlock(&threadMutex);
00910     }
00911     if (interp != NULL) {
00912         Tcl_Release((ClientData) interp);
00913     }
00914     return 1;
00915 }
00916 
00917 /*
00918  *------------------------------------------------------------------------
00919  *
00920  * ThreadFreeProc --
00921  *
00922  *    This is called from when we are exiting and memory needs
00923  *    to be freed.
00924  *
00925  * Results:
00926  *    None.
00927  *
00928  * Side effects:
00929  *      Clears up mem specified in ClientData
00930  *
00931  *------------------------------------------------------------------------
00932  */
00933 
00934      /* ARGSUSED */
00935 static void
00936 ThreadFreeProc(
00937     ClientData clientData)
00938 {
00939     if (clientData) {
00940         ckfree((char *) clientData);
00941     }
00942 }
00943 
00944 /*
00945  *------------------------------------------------------------------------
00946  *
00947  * ThreadDeleteEvent --
00948  *
00949  *    This is called from the ThreadExitProc to delete memory related
00950  *    to events that we put on the queue.
00951  *
00952  * Results:
00953  *    1 it was our event and we want it removed, 0 otherwise.
00954  *
00955  * Side effects:
00956  *      It cleans up our events in the event queue for this thread.
00957  *
00958  *------------------------------------------------------------------------
00959  */
00960 
00961      /* ARGSUSED */
00962 static int
00963 ThreadDeleteEvent(
00964     Tcl_Event *eventPtr,        /* Really ThreadEvent */
00965     ClientData clientData)      /* dummy */
00966 {
00967     if (eventPtr->proc == ThreadEventProc) {
00968         ckfree((char *) ((ThreadEvent *) eventPtr)->script);
00969         return 1;
00970     }
00971 
00972     /*
00973      * If it was NULL, we were in the middle of servicing the event and it
00974      * should be removed
00975      */
00976 
00977     return (eventPtr->proc == NULL);
00978 }
00979 
00980 /*
00981  *------------------------------------------------------------------------
00982  *
00983  * ThreadExitProc --
00984  *
00985  *    This is called when the thread exits.
00986  *
00987  * Results:
00988  *    None.
00989  *
00990  * Side effects:
00991  *      It unblocks anyone that is waiting on a send to this thread. It cleans
00992  *      up any events in the event queue for this thread.
00993  *
00994  *------------------------------------------------------------------------
00995  */
00996 
00997      /* ARGSUSED */
00998 static void
00999 ThreadExitProc(
01000     ClientData clientData)
01001 {
01002     char *threadEvalScript = (char *) clientData;
01003     ThreadEventResult *resultPtr, *nextPtr;
01004     Tcl_ThreadId self = Tcl_GetCurrentThread();
01005 
01006     Tcl_MutexLock(&threadMutex);
01007 
01008     if (threadEvalScript) {
01009         ckfree((char *) threadEvalScript);
01010         threadEvalScript = NULL;
01011     }
01012     Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
01013 
01014     for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
01015         nextPtr = resultPtr->nextPtr;
01016         if (resultPtr->srcThreadId == self) {
01017             /*
01018              * We are going away. By freeing up the result we signal to the
01019              * other thread we don't care about the result.
01020              */
01021 
01022             if (resultPtr->prevPtr) {
01023                 resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
01024             } else {
01025                 resultList = resultPtr->nextPtr;
01026             }
01027             if (resultPtr->nextPtr) {
01028                 resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
01029             }
01030             resultPtr->nextPtr = resultPtr->prevPtr = 0;
01031             resultPtr->eventPtr->resultPtr = NULL;
01032             ckfree((char *) resultPtr);
01033         } else if (resultPtr->dstThreadId == self) {
01034             /*
01035              * Dang. The target is going away. Unblock the caller. The result
01036              * string must be dynamically allocated because the main thread is
01037              * going to call free on it.
01038              */
01039 
01040             char *msg = "target thread died";
01041 
01042             resultPtr->result = ckalloc(strlen(msg)+1);
01043             strcpy(resultPtr->result, msg);
01044             resultPtr->code = TCL_ERROR;
01045             Tcl_ConditionNotify(&resultPtr->done);
01046         }
01047     }
01048     Tcl_MutexUnlock(&threadMutex);
01049 }
01050 #endif /* TCL_THREADS */
01051 
01052 /*
01053  * Local Variables:
01054  * mode: c
01055  * c-basic-offset: 4
01056  * fill-column: 78
01057  * End:
01058  */



Generated on Wed Mar 12 12:18:22 2008 by  doxygen 1.5.1