开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclThreadTest.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：27k
源码类别：

通讯编程

开发平台：

Visual C++

tclThreadTest.c：源码内容
  1. /* 
  2.  * tclThreadTest.c --
  3.  *
  4.  * This file implements the testthread command.  Eventually this
  5.  * should be tclThreadCmd.c
  6.  * Some of this code is based on work done by Richard Hipp on behalf of
  7.  * Conservation Through Innovation, Limited, with their permission.
  8.  *
  9.  * Copyright (c) 1998 by Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * RCS: @(#) $Id: tclThreadTest.c,v 1.16.2.2 2006/09/22 14:48:52 dkf Exp $
  15.  */
  17. #include "tclInt.h"
  19. #ifdef TCL_THREADS
  20. /*
  21.  * Each thread has an single instance of the following structure.  There
  22.  * is one instance of this structure per thread even if that thread contains
  23.  * multiple interpreters.  The interpreter identified by this structure is
  24.  * the main interpreter for the thread.  
  25.  *
  26.  * The main interpreter is the one that will process any messages 
  27.  * received by a thread.  Any thread can send messages but only the
  28.  * main interpreter can receive them.
  29.  */
  31. typedef struct ThreadSpecificData {
  32.     Tcl_ThreadId  threadId;          /* Tcl ID for this thread */
  33.     Tcl_Interp *interp;              /* Main interpreter for this thread */
  34.     int flags;                       /* See the TP_ defines below... */
  35.     struct ThreadSpecificData *nextPtr; /* List for "thread names" */
  36.     struct ThreadSpecificData *prevPtr; /* List for "thread names" */
  37. } ThreadSpecificData;
  38. static Tcl_ThreadDataKey dataKey;
  40. /*
  41.  * This list is used to list all threads that have interpreters.
  42.  * This is protected by threadMutex.
  43.  */
  45. static struct ThreadSpecificData *threadList;
  47. /*
  48.  * The following bit-values are legal for the "flags" field of the
  49.  * ThreadSpecificData structure.
  50.  */
  51. #define TP_Dying               0x001 /* This thread is being cancelled */
  53. /*
  54.  * An instance of the following structure contains all information that is
  55.  * passed into a new thread when the thread is created using either the
  56.  * "thread create" Tcl command or the TclCreateThread() C function.
  57.  */
  59. typedef struct ThreadCtrl {
  60.     char *script;    /* The TCL command this thread should execute */
  61.     int flags;        /* Initial value of the "flags" field in the 
  62.                        * ThreadSpecificData structure for the new thread.
  63.                        * Might contain TP_Detached or TP_TclThread. */
  64.     Tcl_Condition condWait;
  65.     /* This condition variable is used to synchronize
  66.      * the parent and child threads.  The child won't run
  67.      * until it acquires threadMutex, and the parent function
  68.      * won't complete until signaled on this condition
  69.      * variable. */
  70. } ThreadCtrl;
  72. /*
  73.  * This is the event used to send scripts to other threads.
  74.  */
  76. typedef struct ThreadEvent {
  77.     Tcl_Event event; /* Must be first */
  78.     char *script; /* The script to execute. */
  79.     struct ThreadEventResult *resultPtr;
  80. /* To communicate the result.  This is
  81.  * NULL if we don't care about it. */
  82. } ThreadEvent;
  84. typedef struct ThreadEventResult {
  85.     Tcl_Condition done; /* Signaled when the script completes */
  86.     int code; /* Return value of Tcl_Eval */
  87.     char *result; /* Result from the script */
  88.     char *errorInfo; /* Copy of errorInfo variable */
  89.     char *errorCode; /* Copy of errorCode variable */
  90.     Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */
  91.     Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */
  92.     struct ThreadEvent *eventPtr; /* Back pointer */
  93.     struct ThreadEventResult *nextPtr; /* List for cleanup */
  94.     struct ThreadEventResult *prevPtr;
  96. } ThreadEventResult;
  98. static ThreadEventResult *resultList;
  100. /*
  101.  * This is for simple error handling when a thread script exits badly.
  102.  */
  104. static Tcl_ThreadId errorThreadId;
  105. static char *errorProcString;
  107. /* 
  108.  * Access to the list of threads and to the thread send results is
  109.  * guarded by this mutex. 
  110.  */
  112. TCL_DECLARE_MUTEX(threadMutex)
  114. #undef TCL_STORAGE_CLASS
  115. #define TCL_STORAGE_CLASS DLLEXPORT
  117. EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
  118. EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,
  119. Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
  120. EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,
  121. char *script, int joinable));
  122. EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));
  123. EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,
  124. char *script, int wait));
  126. #undef TCL_STORAGE_CLASS
  127. #define TCL_STORAGE_CLASS DLLIMPORT
  129. Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData));
  130. static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
  131. static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
  132. static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
  133. static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
  134. static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
  135. static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
  136. ClientData clientData));
  137. static void ThreadExitProc _ANSI_ARGS_((ClientData clientData));
  140. /*
  141.  *----------------------------------------------------------------------
  142.  *
  143.  * TclThread_Init --
  144.  *
  145.  * Initialize the test thread command.
  146.  *
  147.  * Results:
  148.  *      TCL_OK if the package was properly initialized.
  149.  *
  150.  * Side effects:
  151.  * Add the "testthread" command to the interp.
  152.  *
  153.  *----------------------------------------------------------------------
  154.  */
  156. int
  157. TclThread_Init(interp)
  158.     Tcl_Interp *interp; /* The current Tcl interpreter */
  159. {
  160.     
  161.     Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd, 
  162.     (ClientData)NULL ,NULL);
  163.     if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {
  164. return TCL_ERROR;
  165.     }
  166.     return TCL_OK;
  167. }
  170. /*
  171.  *----------------------------------------------------------------------
  172.  *
  173.  * Tcl_ThreadObjCmd --
  174.  *
  175.  * This procedure is invoked to process the "testthread" Tcl command.
  176.  * See the user documentation for details on what it does.
  177.  *
  178.  * thread create ?-joinable? ?script?
  179.  * thread send id ?-async? script
  180.  * thread exit
  181.  * thread info id
  182.  * thread names
  183.  * thread wait
  184.  * thread errorproc proc
  185.  * thread join id
  186.  *
  187.  * Results:
  188.  * A standard Tcl result.
  189.  *
  190.  * Side effects:
  191.  * See the user documentation.
  192.  *
  193.  *----------------------------------------------------------------------
  194.  */
  196. /* ARGSUSED */
  197. int
  198. Tcl_ThreadObjCmd(dummy, interp, objc, objv)
  199.     ClientData dummy; /* Not used. */
  200.     Tcl_Interp *interp; /* Current interpreter. */
  201.     int objc; /* Number of arguments. */
  202.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  203. {
  204.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  205.     int option;
  206.     static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names",
  207.     "send", "wait", "errorproc",
  208.     (char *) NULL};
  209.     enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN,
  210.   THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
  212.     if (objc < 2) {
  213. Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
  214. return TCL_ERROR;
  215.     }
  216.     if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions,
  217.     "option", 0, &option) != TCL_OK) {
  218. return TCL_ERROR;
  219.     }
  221.     /* 
  222.      * Make sure the initial thread is on the list before doing anything.
  223.      */
  225.     if (tsdPtr->interp == NULL) {
  226. Tcl_MutexLock(&threadMutex);
  227. tsdPtr->interp = interp;
  228. ListUpdateInner(tsdPtr);
  229. Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
  230. Tcl_MutexUnlock(&threadMutex);
  231.     }
  233.     switch ((enum options)option) {
  234. case THREAD_CREATE: {
  235.     char *script;
  236.     int   joinable, len;
  238.     if (objc == 2) {
  239.         /* Neither joinable nor special script
  240.  */
  242.         joinable = 0;
  243. script   = "testthread wait"; /* Just enter the event loop */
  245.     } else if (objc == 3) {
  246.         /* Possibly -joinable, then no special script,
  247.  * no joinable, then its a script.
  248.  */
  250.         script = Tcl_GetString(objv[2]);
  251. len    = strlen (script);
  253. if ((len > 1) &&
  254.     (script [0] == '-') && (script [1] == 'j') &&
  255.     (0 == strncmp (script, "-joinable", (size_t) len))) {
  256.     joinable = 1;
  257.     script   = "testthread wait"; /* Just enter the event loop
  258.    */
  259. } else {
  260.     /* Remember the script */
  261.     joinable = 0;
  262. }
  263.     } else if (objc == 4) {
  264.         /* Definitely a script available, but is the flag
  265.  * -joinable ?
  266.  */
  268.         script = Tcl_GetString(objv[2]);
  269. len    = strlen (script);
  271. joinable = ((len > 1) &&
  272.     (script [0] == '-') && (script [1] == 'j') &&
  273.     (0 == strncmp (script, "-joinable", (size_t) len)));
  275. script = Tcl_GetString(objv[3]);
  276.     } else {
  277. Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
  278. return TCL_ERROR;
  279.     }
  280.     return TclCreateThread(interp, script, joinable);
  281. }
  282. case THREAD_EXIT: {
  283.     if (objc > 2) {
  284. Tcl_WrongNumArgs(interp, 1, objv, NULL);
  285. return TCL_ERROR;
  286.     }
  287.     ListRemove(NULL);
  288.     Tcl_ExitThread(0);
  289.     return TCL_OK;
  290. }
  291. case THREAD_ID:
  292.     if (objc == 2) {
  293. Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
  294. Tcl_SetObjResult(interp, idObj);
  295. return TCL_OK;
  296.     } else {
  297. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  298. return TCL_ERROR;
  299.     }
  300.         case THREAD_JOIN: {
  301.     long id;
  302.     int result, status;
  304.     if (objc != 3) {
  305. Tcl_WrongNumArgs(interp, 1, objv, "join id");
  306. return TCL_ERROR;
  307.     }
  308.     if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
  309. return TCL_ERROR;
  310.     }
  312.     result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
  313.     if (result == TCL_OK) {
  314.         Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
  315.     } else {
  316.         char buf [20];
  317. sprintf (buf, "%ld", id);
  318. Tcl_AppendResult (interp, "cannot join thread ", buf, NULL);
  319.     }
  320.     return result;
  321. }
  322. case THREAD_NAMES: {
  323.     if (objc > 2) {
  324. Tcl_WrongNumArgs(interp, 2, objv, NULL);
  325. return TCL_ERROR;
  326.     }
  327.     return TclThreadList(interp);
  328. }
  329. case THREAD_SEND: {
  330.     long id;
  331.     char *script;
  332.     int wait, arg;
  334.     if ((objc != 4) && (objc != 5)) {
  335. Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
  336. return TCL_ERROR;
  337.     }
  338.     if (objc == 5) {
  339. if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
  340.     Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
  341.     return TCL_ERROR;
  342. }
  343. wait = 0;
  344. arg = 3;
  345.     } else {
  346. wait = 1;
  347. arg = 2;
  348.     }
  349.     if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
  350. return TCL_ERROR;
  351.     }
  352.     arg++;
  353.     script = Tcl_GetString(objv[arg]);
  354.     return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
  355. }
  356. case THREAD_WAIT: {
  357.     while (1) {
  358. (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
  359.     }
  360. }
  361. case THREAD_ERRORPROC: {
  362.     /*
  363.      * Arrange for this proc to handle thread death errors.
  364.      */
  366.     char *proc;
  367.     if (objc != 3) {
  368. Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc");
  369. return TCL_ERROR;
  370.     }
  371.     Tcl_MutexLock(&threadMutex);
  372.     errorThreadId = Tcl_GetCurrentThread();
  373.     if (errorProcString) {
  374. ckfree(errorProcString);
  375.     }
  376.     proc = Tcl_GetString(objv[2]);
  377.     errorProcString = ckalloc(strlen(proc)+1);
  378.     strcpy(errorProcString, proc);
  379.     Tcl_MutexUnlock(&threadMutex);
  380.     return TCL_OK;
  381. }
  382.     }
  383.     return TCL_OK;
  384. }
  387. /*
  388.  *----------------------------------------------------------------------
  389.  *
  390.  * TclCreateThread --
  391.  *
  392.  * This procedure is invoked to create a thread containing an interp to
  393.  * run a script.  This returns after the thread has started executing.
  394.  *
  395.  * Results:
  396.  * A standard Tcl result, which is the thread ID.
  397.  *
  398.  * Side effects:
  399.  * Create a thread.
  400.  *
  401.  *----------------------------------------------------------------------
  402.  */
  404. /* ARGSUSED */
  405. int
  406. TclCreateThread(interp, script, joinable)
  407.     Tcl_Interp *interp; /* Current interpreter. */
  408.     char *script; /* Script to execute */
  409.     int         joinable; /* Flag, joinable thread or not */
  410. {
  411.     ThreadCtrl ctrl;
  412.     Tcl_ThreadId id;
  414.     ctrl.script = script;
  415.     ctrl.condWait = NULL;
  416.     ctrl.flags = 0;
  418.     joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
  420.     Tcl_MutexLock(&threadMutex);
  421.     if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
  422.  TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
  423. Tcl_MutexUnlock(&threadMutex);
  424.         Tcl_AppendResult(interp,"can't create a new thread",NULL);
  425. ckfree((void*)ctrl.script);
  426. return TCL_ERROR;
  427.     }
  429.     /*
  430.      * Wait for the thread to start because it is using something on our stack!
  431.      */
  433.     Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
  434.     Tcl_MutexUnlock(&threadMutex);
  435.     Tcl_ConditionFinalize(&ctrl.condWait);
  436.     Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
  437.     return TCL_OK;
  438. }
  440. /*
  441.  *------------------------------------------------------------------------
  442.  *
  443.  * NewTestThread --
  444.  *
  445.  *    This routine is the "main()" for a new thread whose task is to
  446.  *    execute a single TCL script.  The argument to this function is
  447.  *    a pointer to a structure that contains the text of the TCL script
  448.  *    to be executed.
  449.  *
  450.  *    Space to hold the script field of the ThreadControl structure passed 
  451.  *    in as the only argument was obtained from malloc() and must be freed 
  452.  *    by this function before it exits.  Space to hold the ThreadControl
  453.  *    structure itself is released by the calling function, and the
  454.  *    two condition variables in the ThreadControl structure are destroyed
  455.  *    by the calling function.  The calling function will destroy the
  456.  *    ThreadControl structure and the condition variable as soon as
  457.  *    ctrlPtr->condWait is signaled, so this routine must make copies of
  458.  *    any data it might need after that point.
  459.  *
  460.  * Results:
  461.  *    none
  462.  *
  463.  * Side effects:
  464.  *    A TCL script is executed in a new thread.
  465.  *
  466.  *------------------------------------------------------------------------
  467.  */
  468. Tcl_ThreadCreateType
  469. NewTestThread(clientData)
  470.     ClientData clientData;
  471. {
  472.     ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
  473.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  474.     int result;
  475.     char *threadEvalScript;
  477.     /*
  478.      * Initialize the interpreter.  This should be more general.
  479.      */
  481.     tsdPtr->interp = Tcl_CreateInterp();
  482.     result = Tcl_Init(tsdPtr->interp);
  483.     result = TclThread_Init(tsdPtr->interp);
  485.     /*
  486.      * Update the list of threads.
  487.      */
  489.     Tcl_MutexLock(&threadMutex);
  490.     ListUpdateInner(tsdPtr);
  491.     /*
  492.      * We need to keep a pointer to the alloc'ed mem of the script
  493.      * we are eval'ing, for the case that we exit during evaluation
  494.      */
  495.     threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1);
  496.     strcpy(threadEvalScript, ctrlPtr->script);
  498.     Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
  500.     /*
  501.      * Notify the parent we are alive.
  502.      */
  504.     Tcl_ConditionNotify(&ctrlPtr->condWait);
  505.     Tcl_MutexUnlock(&threadMutex);
  507.     /*
  508.      * Run the script.
  509.      */
  511.     Tcl_Preserve((ClientData) tsdPtr->interp);
  512.     result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
  513.     if (result != TCL_OK) {
  514. ThreadErrorProc(tsdPtr->interp);
  515.     }
  517.     /*
  518.      * Clean up.
  519.      */
  521.     ListRemove(tsdPtr);
  522.     Tcl_Release((ClientData) tsdPtr->interp);
  523.     Tcl_DeleteInterp(tsdPtr->interp);
  524.     Tcl_ExitThread(result);
  526.     TCL_THREAD_CREATE_RETURN;
  527. }
  529. /*
  530.  *------------------------------------------------------------------------
  531.  *
  532.  * ThreadErrorProc --
  533.  *
  534.  *    Send a message to the thread willing to hear about errors.
  535.  *
  536.  * Results:
  537.  *    none
  538.  *
  539.  * Side effects:
  540.  *    Send an event.
  541.  *
  542.  *------------------------------------------------------------------------
  543.  */
  544. static void
  545. ThreadErrorProc(interp)
  546.     Tcl_Interp *interp; /* Interp that failed */
  547. {
  548.     Tcl_Channel errChannel;
  549.     CONST char *errorInfo, *argv[3];
  550.     char *script;
  551.     char buf[TCL_DOUBLE_SPACE+1];
  552.     sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
  554.     errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  555.     if (errorProcString == NULL) {
  556. errChannel = Tcl_GetStdChannel(TCL_STDERR);
  557. Tcl_WriteChars(errChannel, "Error from thread ", -1);
  558. Tcl_WriteChars(errChannel, buf, -1);
  559. Tcl_WriteChars(errChannel, "n", 1);
  560. Tcl_WriteChars(errChannel, errorInfo, -1);
  561. Tcl_WriteChars(errChannel, "n", 1);
  562.     } else {
  563. argv[0] = errorProcString;
  564. argv[1] = buf;
  565. argv[2] = errorInfo;
  566. script = Tcl_Merge(3, argv);
  567. TclThreadSend(interp, errorThreadId, script, 0);
  568. ckfree(script);
  569.     }
  570. }
  573. /*
  574.  *------------------------------------------------------------------------
  575.  *
  576.  * ListUpdateInner --
  577.  *
  578.  *    Add the thread local storage to the list.  This assumes
  579.  * the caller has obtained the mutex.
  580.  *
  581.  * Results:
  582.  *    none
  583.  *
  584.  * Side effects:
  585.  *    Add the thread local storage to its list.
  586.  *
  587.  *------------------------------------------------------------------------
  588.  */
  589. static void
  590. ListUpdateInner(tsdPtr)
  591.     ThreadSpecificData *tsdPtr;
  592. {
  593.     if (tsdPtr == NULL) {
  594. tsdPtr = TCL_TSD_INIT(&dataKey);
  595.     }
  596.     tsdPtr->threadId = Tcl_GetCurrentThread();
  597.     tsdPtr->nextPtr = threadList;
  598.     if (threadList) {
  599. threadList->prevPtr = tsdPtr;
  600.     }
  601.     tsdPtr->prevPtr = NULL;
  602.     threadList = tsdPtr;
  603. }
  605. /*
  606.  *------------------------------------------------------------------------
  607.  *
  608.  * ListRemove --
  609.  *
  610.  *    Remove the thread local storage from its list.  This grabs the
  611.  * mutex to protect the list.
  612.  *
  613.  * Results:
  614.  *    none
  615.  *
  616.  * Side effects:
  617.  *    Remove the thread local storage from its list.
  618.  *
  619.  *------------------------------------------------------------------------
  620.  */
  621. static void
  622. ListRemove(tsdPtr)
  623.     ThreadSpecificData *tsdPtr;
  624. {
  625.     if (tsdPtr == NULL) {
  626. tsdPtr = TCL_TSD_INIT(&dataKey);
  627.     }
  628.     Tcl_MutexLock(&threadMutex);
  629.     if (tsdPtr->prevPtr) {
  630. tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
  631.     } else {
  632. threadList = tsdPtr->nextPtr;
  633.     }
  634.     if (tsdPtr->nextPtr) {
  635. tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
  636.     }
  637.     tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
  638.     Tcl_MutexUnlock(&threadMutex);
  639. }
  642. /*
  643.  *------------------------------------------------------------------------
  644.  *
  645.  * TclThreadList --
  646.  *
  647.  *    Return a list of threads running Tcl interpreters.
  648.  *
  649.  * Results:
  650.  *    A standard Tcl result.
  651.  *
  652.  * Side effects:
  653.  *    None.
  654.  *
  655.  *------------------------------------------------------------------------
  656.  */
  657. int
  658. TclThreadList(interp)
  659.     Tcl_Interp *interp;
  660. {
  661.     ThreadSpecificData *tsdPtr;
  662.     Tcl_Obj *listPtr;
  664.     listPtr = Tcl_NewListObj(0, NULL);
  665.     Tcl_MutexLock(&threadMutex);
  666.     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
  667. Tcl_ListObjAppendElement(interp, listPtr,
  668. Tcl_NewLongObj((long)tsdPtr->threadId));
  669.     }
  670.     Tcl_MutexUnlock(&threadMutex);
  671.     Tcl_SetObjResult(interp, listPtr);
  672.     return TCL_OK;
  673. }
  676. /*
  677.  *------------------------------------------------------------------------
  678.  *
  679.  * TclThreadSend --
  680.  *
  681.  *    Send a script to another thread.
  682.  *
  683.  * Results:
  684.  *    A standard Tcl result.
  685.  *
  686.  * Side effects:
  687.  *    None.
  688.  *
  689.  *------------------------------------------------------------------------
  690.  */
  691. int
  692. TclThreadSend(interp, id, script, wait)
  693.     Tcl_Interp *interp; /* The current interpreter. */
  694.     Tcl_ThreadId id; /* Thread Id of other interpreter. */
  695.     char *script; /* The script to evaluate. */
  696.     int wait; /* If 1, we block for the result. */
  697. {
  698.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  699.     ThreadEvent *threadEventPtr;
  700.     ThreadEventResult *resultPtr;
  701.     int found, code;
  702.     Tcl_ThreadId threadId = (Tcl_ThreadId) id;
  704.     /* 
  705.      * Verify the thread exists.
  706.      */
  708.     Tcl_MutexLock(&threadMutex);
  709.     found = 0;
  710.     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
  711. if (tsdPtr->threadId == threadId) {
  712.     found = 1;
  713.     break;
  714. }
  715.     }
  716.     if (!found) {
  717. Tcl_MutexUnlock(&threadMutex);
  718. Tcl_AppendResult(interp, "invalid thread id", NULL);
  719. return TCL_ERROR;
  720.     }
  722.     /*
  723.      * Short circut sends to ourself.  Ought to do something with -async,
  724.      * like run in an idle handler.
  725.      */
  727.     if (threadId == Tcl_GetCurrentThread()) {
  728.         Tcl_MutexUnlock(&threadMutex);
  729. return Tcl_GlobalEval(interp, script);
  730.     }
  732.     /* 
  733.      * Create the event for its event queue.
  734.      */
  736.     threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
  737.     threadEventPtr->script = ckalloc(strlen(script) + 1);
  738.     strcpy(threadEventPtr->script, script);
  739.     if (!wait) {
  740. resultPtr = threadEventPtr->resultPtr = NULL;
  741.     } else {
  742. resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
  743. threadEventPtr->resultPtr = resultPtr;
  745. /*
  746.  * Initialize the result fields.
  747.  */
  749. resultPtr->done = NULL;
  750. resultPtr->code = 0;
  751. resultPtr->result = NULL;
  752. resultPtr->errorInfo = NULL;
  753. resultPtr->errorCode = NULL;
  755. /* 
  756.  * Maintain the cleanup list.
  757.  */
  759. resultPtr->srcThreadId = Tcl_GetCurrentThread();
  760. resultPtr->dstThreadId = threadId;
  761. resultPtr->eventPtr = threadEventPtr;
  762. resultPtr->nextPtr = resultList;
  763. if (resultList) {
  764.     resultList->prevPtr = resultPtr;
  765. }
  766. resultPtr->prevPtr = NULL;
  767. resultList = resultPtr;
  768.     }
  770.     /*
  771.      * Queue the event and poke the other thread's notifier.
  772.      */
  774.     threadEventPtr->event.proc = ThreadEventProc;
  775.     Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, 
  776.     TCL_QUEUE_TAIL);
  777.     Tcl_ThreadAlert(threadId);
  779.     if (!wait) {
  780. Tcl_MutexUnlock(&threadMutex);
  781. return TCL_OK;
  782.     }
  784.     /* 
  785.      * Block on the results and then get them.
  786.      */
  788.     Tcl_ResetResult(interp);
  789.     while (resultPtr->result == NULL) {
  790.         Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
  791.     }
  793.     /*
  794.      * Unlink result from the result list.
  795.      */
  797.     if (resultPtr->prevPtr) {
  798. resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
  799.     } else {
  800. resultList = resultPtr->nextPtr;
  801.     }
  802.     if (resultPtr->nextPtr) {
  803. resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
  804.     }
  805.     resultPtr->eventPtr = NULL;
  806.     resultPtr->nextPtr = NULL;
  807.     resultPtr->prevPtr = NULL;
  809.     Tcl_MutexUnlock(&threadMutex);
  811.     if (resultPtr->code != TCL_OK) {
  812. if (resultPtr->errorCode) {
  813.     Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
  814.     ckfree(resultPtr->errorCode);
  815. }
  816. if (resultPtr->errorInfo) {
  817.     Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
  818.     ckfree(resultPtr->errorInfo);
  819. }
  820.     }
  821.     Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
  822.     Tcl_ConditionFinalize(&resultPtr->done);
  823.     code = resultPtr->code;
  825.     ckfree((char *) resultPtr);
  827.     return code;
  828. }
  831. /*
  832.  *------------------------------------------------------------------------
  833.  *
  834.  * ThreadEventProc --
  835.  *
  836.  *    Handle the event in the target thread.
  837.  *
  838.  * Results:
  839.  *    Returns 1 to indicate that the event was processed.
  840.  *
  841.  * Side effects:
  842.  *    Fills out the ThreadEventResult struct.
  843.  *
  844.  *------------------------------------------------------------------------
  845.  */
  846. static int
  847. ThreadEventProc(evPtr, mask)
  848.     Tcl_Event *evPtr; /* Really ThreadEvent */
  849.     int mask;
  850. {
  851.     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
  852.     ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
  853.     ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
  854.     Tcl_Interp *interp = tsdPtr->interp;
  855.     int code;
  856.     CONST char *result, *errorCode, *errorInfo;
  858.     if (interp == NULL) {
  859. code = TCL_ERROR;
  860. result = "no target interp!";
  861. errorCode = "THREAD";
  862. errorInfo = "";
  863.     } else {
  864. Tcl_Preserve((ClientData) interp);
  865. Tcl_ResetResult(interp);
  866. Tcl_CreateThreadExitHandler(ThreadFreeProc,
  867. (ClientData) threadEventPtr->script);
  868. code = Tcl_GlobalEval(interp, threadEventPtr->script);
  869. Tcl_DeleteThreadExitHandler(ThreadFreeProc,
  870. (ClientData) threadEventPtr->script);
  871. if (code != TCL_OK) {
  872.     errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
  873.     errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  874. } else {
  875.     errorCode = errorInfo = NULL;
  876. }
  877. result = Tcl_GetStringResult(interp);
  878.     }
  879.     ckfree(threadEventPtr->script);
  880.     if (resultPtr) {
  881. Tcl_MutexLock(&threadMutex);
  882. resultPtr->code = code;
  883. resultPtr->result = ckalloc(strlen(result) + 1);
  884. strcpy(resultPtr->result, result);
  885. if (errorCode != NULL) {
  886.     resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
  887.     strcpy(resultPtr->errorCode, errorCode);
  888. }
  889. if (errorInfo != NULL) {
  890.     resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
  891.     strcpy(resultPtr->errorInfo, errorInfo);
  892. }
  893. Tcl_ConditionNotify(&resultPtr->done);
  894. Tcl_MutexUnlock(&threadMutex);
  895.     }
  896.     if (interp != NULL) {
  897. Tcl_Release((ClientData) interp);
  898.     }
  899.     return 1;
  900. }
  902. /*
  903.  *------------------------------------------------------------------------
  904.  *
  905.  * ThreadFreeProc --
  906.  *
  907.  *    This is called from when we are exiting and memory needs
  908.  *    to be freed.
  909.  *
  910.  * Results:
  911.  *    None.
  912.  *
  913.  * Side effects:
  914.  * Clears up mem specified in ClientData
  915.  *
  916.  *------------------------------------------------------------------------
  917.  */
  918.      /* ARGSUSED */
  919. static void
  920. ThreadFreeProc(clientData)
  921.     ClientData clientData;
  922. {
  923.     if (clientData) {
  924. ckfree((char *) clientData);
  925.     }
  926. }
  928. /*
  929.  *------------------------------------------------------------------------
  930.  *
  931.  * ThreadDeleteEvent --
  932.  *
  933.  *    This is called from the ThreadExitProc to delete memory related
  934.  *    to events that we put on the queue.
  935.  *
  936.  * Results:
  937.  *    1 it was our event and we want it removed, 0 otherwise.
  938.  *
  939.  * Side effects:
  940.  * It cleans up our events in the event queue for this thread.
  941.  *
  942.  *------------------------------------------------------------------------
  943.  */
  944.      /* ARGSUSED */
  945. static int
  946. ThreadDeleteEvent(eventPtr, clientData)
  947.     Tcl_Event *eventPtr; /* Really ThreadEvent */
  948.     ClientData clientData; /* dummy */
  949. {
  950.     if (eventPtr->proc == ThreadEventProc) {
  951. ckfree((char *) ((ThreadEvent *) eventPtr)->script);
  952. return 1;
  953.     }
  954.     /*
  955.      * If it was NULL, we were in the middle of servicing the event
  956.      * and it should be removed
  957.      */
  958.     return (eventPtr->proc == NULL);
  959. }
  961. /*
  962.  *------------------------------------------------------------------------
  963.  *
  964.  * ThreadExitProc --
  965.  *
  966.  *    This is called when the thread exits.  
  967.  *
  968.  * Results:
  969.  *    None.
  970.  *
  971.  * Side effects:
  972.  * It unblocks anyone that is waiting on a send to this thread.
  973.  * It cleans up any events in the event queue for this thread.
  974.  *
  975.  *------------------------------------------------------------------------
  976.  */
  977.      /* ARGSUSED */
  978. static void
  979. ThreadExitProc(clientData)
  980.     ClientData clientData;
  981. {
  982.     char *threadEvalScript = (char *) clientData;
  983.     ThreadEventResult *resultPtr, *nextPtr;
  984.     Tcl_ThreadId self = Tcl_GetCurrentThread();
  986.     Tcl_MutexLock(&threadMutex);
  988.     if (threadEvalScript) {
  989. ckfree((char *) threadEvalScript);
  990. threadEvalScript = NULL;
  991.     }
  992.     Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
  994.     for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
  995. nextPtr = resultPtr->nextPtr;
  996. if (resultPtr->srcThreadId == self) {
  997.     /*
  998.      * We are going away.  By freeing up the result we signal
  999.      * to the other thread we don't care about the result.
  1000.      */
  1001.     if (resultPtr->prevPtr) {
  1002. resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
  1003.     } else {
  1004. resultList = resultPtr->nextPtr;
  1005.     }
  1006.     if (resultPtr->nextPtr) {
  1007. resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
  1008.     }
  1009.     resultPtr->nextPtr = resultPtr->prevPtr = 0;
  1010.     resultPtr->eventPtr->resultPtr = NULL;
  1011.     ckfree((char *)resultPtr);
  1012. } else if (resultPtr->dstThreadId == self) {
  1013.     /*
  1014.      * Dang.  The target is going away.  Unblock the caller.
  1015.      * The result string must be dynamically allocated because
  1016.      * the main thread is going to call free on it.
  1017.      */
  1019.     char *msg = "target thread died";
  1020.     resultPtr->result = ckalloc(strlen(msg)+1);
  1021.     strcpy(resultPtr->result, msg);
  1022.     resultPtr->code = TCL_ERROR;
  1023.     Tcl_ConditionNotify(&resultPtr->done);
  1024. }
  1025.     }
  1026.     Tcl_MutexUnlock(&threadMutex);
  1027. }
  1029. #endif /* TCL_THREADS */