util/src/TclTk/tcl8.6.12/generic/tclThreadTest.c

   1 /*
   2  * tclThreadTest.c --
   3  *
   4  *      This file implements the testthread command. Eventually this should be
   5  *      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  * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
  11  *
  12  * See the file "license.terms" for information on usage and redistribution of
  13  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14  */
  15
  16 #ifndef USE_TCL_STUBS
  17 #   define USE_TCL_STUBS
  18 #endif
  19 #include "tclInt.h"
  20
  21 #ifdef TCL_THREADS
  22 /*
  23  * Each thread has an single instance of the following structure. There is one
  24  * instance of this structure per thread even if that thread contains multiple
  25  * interpreters. The interpreter identified by this structure is the main
  26  * interpreter for the thread.
  27  *
  28  * The main interpreter is the one that will process any messages received by
  29  * a thread. Any thread can send messages but only the main interpreter can
  30  * receive them.
  31  */
  32
  33 typedef struct ThreadSpecificData {
  34     Tcl_ThreadId threadId;      /* Tcl ID for this thread */
  35     Tcl_Interp *interp;         /* Main interpreter for this thread */
  36     int flags;                  /* See the TP_ defines below... */
  37     struct ThreadSpecificData *nextPtr;
  38                                 /* List for "thread names" */
  39     struct ThreadSpecificData *prevPtr;
  40                                 /* List for "thread names" */
  41 } ThreadSpecificData;
  42 static Tcl_ThreadDataKey dataKey;
  43
  44 /*
  45  * This list is used to list all threads that have interpreters. This is
  46  * protected by threadMutex.
  47  */
  48
  49 static ThreadSpecificData *threadList = NULL;
  50
  51 /*
  52  * The following bit-values are legal for the "flags" field of the
  53  * ThreadSpecificData structure.
  54  */
  55
  56 #define TP_Dying                0x001 /* This thread is being canceled */
  57
  58 /*
  59  * An instance of the following structure contains all information that is
  60  * passed into a new thread when the thread is created using either the
  61  * "thread create" Tcl command or the ThreadCreate() C function.
  62  */
  63
  64 typedef struct ThreadCtrl {
  65     const char *script;         /* The Tcl command this thread should
  66                                  * execute */
  67     int flags;                  /* Initial value of the "flags" field in the
  68                                  * ThreadSpecificData structure for the new
  69                                  * thread. Might contain TP_Detached or
  70                                  * TP_TclThread. */
  71     Tcl_Condition condWait;     /* This condition variable is used to
  72                                  * synchronize the parent and child threads.
  73                                  * The child won't run until it acquires
  74                                  * threadMutex, and the parent function won't
  75                                  * complete until signaled on this condition
  76                                  * variable. */
  77 } ThreadCtrl;
  78
  79 /*
  80  * This is the event used to send scripts to other threads.
  81  */
  82
  83 typedef struct ThreadEvent {
  84     Tcl_Event event;            /* Must be first */
  85     char *script;               /* The script to execute. */
  86     struct ThreadEventResult *resultPtr;
  87                                 /* To communicate the result. This is NULL if
  88                                  * we don't care about it. */
  89 } ThreadEvent;
  90
  91 typedef struct ThreadEventResult {
  92     Tcl_Condition done;         /* Signaled when the script completes */
  93     int code;                   /* Return value of Tcl_Eval */
  94     char *result;               /* Result from the script */
  95     char *errorInfo;            /* Copy of errorInfo variable */
  96     char *errorCode;            /* Copy of errorCode variable */
  97     Tcl_ThreadId srcThreadId;   /* Id of sending thread, in case it dies */
  98     Tcl_ThreadId dstThreadId;   /* Id of target thread, in case it dies */
  99     struct ThreadEvent *eventPtr;       /* Back pointer */
 100     struct ThreadEventResult *nextPtr;  /* List for cleanup */
 101     struct ThreadEventResult *prevPtr;
 102
 103 } ThreadEventResult;
 104
 105 static ThreadEventResult *resultList;
 106
 107 /*
 108  * This is for simple error handling when a thread script exits badly.
 109  */
 110
 111 static Tcl_ThreadId mainThreadId;
 112 static Tcl_ThreadId errorThreadId;
 113 static char *errorProcString;
 114
 115 /*
 116  * Access to the list of threads and to the thread send results is guarded by
 117  * this mutex.
 118  */
 119
 120 TCL_DECLARE_MUTEX(threadMutex)
 121
 122 static int              ThreadObjCmd(ClientData clientData,
 123                             Tcl_Interp *interp, int objc,
 124                             Tcl_Obj *const objv[]);
 125 static int              ThreadCreate(Tcl_Interp *interp, const char *script,
 126                             int joinable);
 127 static int              ThreadList(Tcl_Interp *interp);
 128 static int              ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id,
 129                             const char *script, int wait);
 130 static int              ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id,
 131                             const char *result, int flags);
 132
 133 static Tcl_ThreadCreateType     NewTestThread(ClientData clientData);
 134 static void             ListRemove(ThreadSpecificData *tsdPtr);
 135 static void             ListUpdateInner(ThreadSpecificData *tsdPtr);
 136 static int              ThreadEventProc(Tcl_Event *evPtr, int mask);
 137 static void             ThreadErrorProc(Tcl_Interp *interp);
 138 static void             ThreadFreeProc(ClientData clientData);
 139 static int              ThreadDeleteEvent(Tcl_Event *eventPtr,
 140                             ClientData clientData);
 141 static void             ThreadExitProc(ClientData clientData);
 142 extern int              Tcltest_Init(Tcl_Interp *interp);
 143 \f
 144 /*
 145  *----------------------------------------------------------------------
 146  *
 147  * TclThread_Init --
 148  *
 149  *      Initialize the test thread command.
 150  *
 151  * Results:
 152  *      TCL_OK if the package was properly initialized.
 153  *
 154  * Side effects:
 155  *      Add the "testthread" command to the interp.
 156  *
 157  *----------------------------------------------------------------------
 158  */
 159
 160 int
 161 TclThread_Init(
 162     Tcl_Interp *interp)         /* The current Tcl interpreter */
 163 {
 164     /*
 165      * If the main thread Id has not been set, do it now.
 166      */
 167
 168     Tcl_MutexLock(&threadMutex);
 169     if (mainThreadId == 0) {
 170         mainThreadId = Tcl_GetCurrentThread();
 171     }
 172     Tcl_MutexUnlock(&threadMutex);
 173
 174     Tcl_CreateObjCommand(interp, "testthread", ThreadObjCmd, NULL, NULL);
 175     return TCL_OK;
 176 }
 177 \f
 178 /*
 179  *----------------------------------------------------------------------
 180  *
 181  * ThreadObjCmd --
 182  *
 183  *      This procedure is invoked to process the "testthread" Tcl command. See
 184  *      the user documentation for details on what it does.
 185  *
 186  *      thread cancel ?-unwind? id ?result?
 187  *      thread create ?-joinable? ?script?
 188  *      thread send ?-async? id script
 189  *      thread event
 190  *      thread exit
 191  *      thread id ?-main?
 192  *      thread names
 193  *      thread wait
 194  *      thread errorproc proc
 195  *      thread join id
 196  *
 197  * Results:
 198  *      A standard Tcl result.
 199  *
 200  * Side effects:
 201  *      See the user documentation.
 202  *
 203  *----------------------------------------------------------------------
 204  */
 205
 206         /* ARGSUSED */
 207 static int
 208 ThreadObjCmd(
 209     ClientData dummy,           /* Not used. */
 210     Tcl_Interp *interp,         /* Current interpreter. */
 211     int objc,                   /* Number of arguments. */
 212     Tcl_Obj *const objv[])      /* Argument objects. */
 213 {
 214     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 215     int option;
 216     static const char *const threadOptions[] = {
 217         "cancel", "create", "event", "exit", "id",
 218         "join", "names", "send", "wait", "errorproc",
 219         NULL
 220     };
 221     enum options {
 222         THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT,
 223         THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND,
 224         THREAD_WAIT, THREAD_ERRORPROC
 225     };
 226
 227     if (objc < 2) {
 228         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
 229         return TCL_ERROR;
 230     }
 231     if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions, "option", 0,
 232             &option) != TCL_OK) {
 233         return TCL_ERROR;
 234     }
 235
 236     /*
 237      * Make sure the initial thread is on the list before doing anything.
 238      */
 239
 240     if (tsdPtr->interp == NULL) {
 241         Tcl_MutexLock(&threadMutex);
 242         tsdPtr->interp = interp;
 243         ListUpdateInner(tsdPtr);
 244         Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
 245         Tcl_MutexUnlock(&threadMutex);
 246     }
 247
 248     switch ((enum options)option) {
 249     case THREAD_CANCEL: {
 250         Tcl_WideInt id;
 251         const char *result;
 252         int flags, arg;
 253
 254         if ((objc < 3) || (objc > 5)) {
 255             Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?");
 256             return TCL_ERROR;
 257         }
 258         flags = 0;
 259         arg = 2;
 260         if ((objc == 4) || (objc == 5)) {
 261             if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) {
 262                 flags = TCL_CANCEL_UNWIND;
 263                 arg++;
 264             }
 265         }
 266         if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
 267             return TCL_ERROR;
 268         }
 269         arg++;
 270         if (arg < objc) {
 271             result = Tcl_GetString(objv[arg]);
 272         } else {
 273             result = NULL;
 274         }
 275         return ThreadCancel(interp, (Tcl_ThreadId) (size_t) id, result, flags);
 276     }
 277     case THREAD_CREATE: {
 278         const char *script;
 279         int joinable, len;
 280
 281         if (objc == 2) {
 282             /*
 283              * Neither joinable nor special script
 284              */
 285
 286             joinable = 0;
 287             script = "testthread wait";         /* Just enter event loop */
 288         } else if (objc == 3) {
 289             /*
 290              * Possibly -joinable, then no special script, no joinable, then
 291              * its a script.
 292              */
 293
 294             script = Tcl_GetStringFromObj(objv[2], &len);
 295
 296             if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
 297                     (0 == strncmp(script, "-joinable", len))) {
 298                 joinable = 1;
 299                 script = "testthread wait";     /* Just enter event loop */
 300             } else {
 301                 /*
 302                  * Remember the script
 303                  */
 304
 305                 joinable = 0;
 306             }
 307         } else if (objc == 4) {
 308             /*
 309              * Definitely a script available, but is the flag -joinable?
 310              */
 311
 312             script = Tcl_GetStringFromObj(objv[2], &len);
 313             joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
 314                     && (0 == strncmp(script, "-joinable", len)));
 315             script = Tcl_GetString(objv[3]);
 316         } else {
 317             Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
 318             return TCL_ERROR;
 319         }
 320         return ThreadCreate(interp, script, joinable);
 321     }
 322     case THREAD_EXIT:
 323         if (objc > 2) {
 324             Tcl_WrongNumArgs(interp, 2, objv, NULL);
 325             return TCL_ERROR;
 326         }
 327         ListRemove(NULL);
 328         Tcl_ExitThread(0);
 329         return TCL_OK;
 330     case THREAD_ID:
 331         if (objc == 2 || objc == 3) {
 332             Tcl_Obj *idObj;
 333
 334             /*
 335              * Check if they want the main thread id or the current thread id.
 336              */
 337
 338             if (objc == 2) {
 339                 idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
 340             } else if (objc == 3
 341                     && strcmp("-main", Tcl_GetString(objv[2])) == 0) {
 342                 Tcl_MutexLock(&threadMutex);
 343                 idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId);
 344                 Tcl_MutexUnlock(&threadMutex);
 345             } else {
 346                 Tcl_WrongNumArgs(interp, 2, objv, NULL);
 347                 return TCL_ERROR;
 348             }
 349
 350             Tcl_SetObjResult(interp, idObj);
 351             return TCL_OK;
 352         } else {
 353             Tcl_WrongNumArgs(interp, 2, objv, NULL);
 354             return TCL_ERROR;
 355         }
 356     case THREAD_JOIN: {
 357         Tcl_WideInt id;
 358         int result, status;
 359
 360         if (objc != 3) {
 361             Tcl_WrongNumArgs(interp, 2, objv, "id");
 362             return TCL_ERROR;
 363         }
 364         if (Tcl_GetWideIntFromObj(interp, objv[2], &id) != TCL_OK) {
 365             return TCL_ERROR;
 366         }
 367
 368         result = Tcl_JoinThread((Tcl_ThreadId)(size_t)id, &status);
 369         if (result == TCL_OK) {
 370             Tcl_SetIntObj(Tcl_GetObjResult(interp), status);
 371         } else {
 372             char buf[20];
 373
 374             sprintf(buf, "%" TCL_LL_MODIFIER "d", id);
 375             Tcl_AppendResult(interp, "cannot join thread ", buf, NULL);
 376         }
 377         return result;
 378     }
 379     case THREAD_NAMES:
 380         if (objc > 2) {
 381             Tcl_WrongNumArgs(interp, 2, objv, NULL);
 382             return TCL_ERROR;
 383         }
 384         return ThreadList(interp);
 385     case THREAD_SEND: {
 386         Tcl_WideInt id;
 387         const char *script;
 388         int wait, arg;
 389
 390         if ((objc != 4) && (objc != 5)) {
 391             Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
 392             return TCL_ERROR;
 393         }
 394         if (objc == 5) {
 395             if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
 396                 Tcl_WrongNumArgs(interp, 2, objv, "?-async? id script");
 397                 return TCL_ERROR;
 398             }
 399             wait = 0;
 400             arg = 3;
 401         } else {
 402             wait = 1;
 403             arg = 2;
 404         }
 405         if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
 406             return TCL_ERROR;
 407         }
 408         arg++;
 409         script = Tcl_GetString(objv[arg]);
 410         return ThreadSend(interp, (Tcl_ThreadId)(size_t)id, script, wait);
 411     }
 412     case THREAD_EVENT: {
 413         if (objc > 2) {
 414             Tcl_WrongNumArgs(interp, 2, objv, NULL);
 415             return TCL_ERROR;
 416         }
 417         Tcl_SetObjResult(interp, Tcl_NewIntObj(
 418                 Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)));
 419         return TCL_OK;
 420     }
 421     case THREAD_ERRORPROC: {
 422         /*
 423          * Arrange for this proc to handle thread death errors.
 424          */
 425
 426         const char *proc;
 427
 428         if (objc != 3) {
 429             Tcl_WrongNumArgs(interp, 2, objv, "proc");
 430             return TCL_ERROR;
 431         }
 432         Tcl_MutexLock(&threadMutex);
 433         errorThreadId = Tcl_GetCurrentThread();
 434         if (errorProcString) {
 435             ckfree(errorProcString);
 436         }
 437         proc = Tcl_GetString(objv[2]);
 438         errorProcString = ckalloc(strlen(proc) + 1);
 439         strcpy(errorProcString, proc);
 440         Tcl_MutexUnlock(&threadMutex);
 441         return TCL_OK;
 442     }
 443     case THREAD_WAIT:
 444         if (objc > 2) {
 445             Tcl_WrongNumArgs(interp, 2, objv, "");
 446             return TCL_ERROR;
 447         }
 448         while (1) {
 449             /*
 450              * If the script has been unwound, bail out immediately. This does
 451              * not follow the recommended guidelines for how extensions should
 452              * handle the script cancellation functionality because this is
 453              * not a "normal" extension. Most extensions do not have a command
 454              * that simply enters an infinite Tcl event loop. Normal
 455              * extensions should not specify the TCL_CANCEL_UNWIND when
 456              * calling Tcl_Canceled to check if the command has been canceled.
 457              */
 458
 459             if (Tcl_Canceled(interp,
 460                     TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
 461                 break;
 462             }
 463             (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
 464         }
 465
 466         /*
 467          * If we get to this point, we have been canceled by another thread,
 468          * which is considered to be an "error".
 469          */
 470
 471         ThreadErrorProc(interp);
 472         return TCL_OK;
 473     }
 474     return TCL_OK;
 475 }
 476 \f
 477 /*
 478  *----------------------------------------------------------------------
 479  *
 480  * ThreadCreate --
 481  *
 482  *      This procedure is invoked to create a thread containing an interp to
 483  *      run a script. This returns after the thread has started executing.
 484  *
 485  * Results:
 486  *      A standard Tcl result, which is the thread ID.
 487  *
 488  * Side effects:
 489  *      Create a thread.
 490  *
 491  *----------------------------------------------------------------------
 492  */
 493
 494         /* ARGSUSED */
 495 static int
 496 ThreadCreate(
 497     Tcl_Interp *interp,         /* Current interpreter. */
 498     const char *script,         /* Script to execute */
 499     int joinable)               /* Flag, joinable thread or not */
 500 {
 501     ThreadCtrl ctrl;
 502     Tcl_ThreadId id;
 503
 504     ctrl.script = script;
 505     ctrl.condWait = NULL;
 506     ctrl.flags = 0;
 507
 508     joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
 509
 510     Tcl_MutexLock(&threadMutex);
 511     if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
 512             TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
 513         Tcl_MutexUnlock(&threadMutex);
 514         Tcl_AppendResult(interp, "can't create a new thread", NULL);
 515         return TCL_ERROR;
 516     }
 517
 518     /*
 519      * Wait for the thread to start because it is using something on our stack!
 520      */
 521
 522     Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
 523     Tcl_MutexUnlock(&threadMutex);
 524     Tcl_ConditionFinalize(&ctrl.condWait);
 525     Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)(size_t)id));
 526     return TCL_OK;
 527 }
 528 \f
 529 /*
 530  *------------------------------------------------------------------------
 531  *
 532  * NewTestThread --
 533  *
 534  *      This routine is the "main()" for a new thread whose task is to execute
 535  *      a single Tcl script. The argument to this function is a pointer to a
 536  *      structure that contains the text of the TCL script to be executed.
 537  *
 538  *      Space to hold the script field of the ThreadControl structure passed
 539  *      in as the only argument was obtained from malloc() and must be freed
 540  *      by this function before it exits. Space to hold the ThreadControl
 541  *      structure itself is released by the calling function, and the two
 542  *      condition variables in the ThreadControl structure are destroyed by
 543  *      the calling function. The calling function will destroy the
 544  *      ThreadControl structure and the condition variable as soon as
 545  *      ctrlPtr->condWait is signaled, so this routine must make copies of any
 546  *      data it might need after that point.
 547  *
 548  * Results:
 549  *      None
 550  *
 551  * Side effects:
 552  *      A Tcl script is executed in a new thread.
 553  *
 554  *------------------------------------------------------------------------
 555  */
 556
 557 Tcl_ThreadCreateType
 558 NewTestThread(
 559     ClientData clientData)
 560 {
 561     ThreadCtrl *ctrlPtr = clientData;
 562     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 563     int result;
 564     char *threadEvalScript;
 565
 566     /*
 567      * Initialize the interpreter. This should be more general.
 568      */
 569
 570     tsdPtr->interp = Tcl_CreateInterp();
 571     result = Tcl_Init(tsdPtr->interp);
 572     if (result != TCL_OK) {
 573         ThreadErrorProc(tsdPtr->interp);
 574     }
 575
 576     /*
 577      * This is part of the test facility. Initialize _ALL_ test commands for
 578      * use by the new thread.
 579      */
 580
 581     result = Tcltest_Init(tsdPtr->interp);
 582     if (result != TCL_OK) {
 583         ThreadErrorProc(tsdPtr->interp);
 584     }
 585
 586     /*
 587      * Update the list of threads.
 588      */
 589
 590     Tcl_MutexLock(&threadMutex);
 591     ListUpdateInner(tsdPtr);
 592
 593     /*
 594      * We need to keep a pointer to the alloc'ed mem of the script we are
 595      * eval'ing, for the case that we exit during evaluation
 596      */
 597
 598     threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
 599     strcpy(threadEvalScript, ctrlPtr->script);
 600
 601     Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
 602
 603     /*
 604      * Notify the parent we are alive.
 605      */
 606
 607     Tcl_ConditionNotify(&ctrlPtr->condWait);
 608     Tcl_MutexUnlock(&threadMutex);
 609
 610     /*
 611      * Run the script.
 612      */
 613
 614     Tcl_Preserve(tsdPtr->interp);
 615     result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0);
 616     if (result != TCL_OK) {
 617         ThreadErrorProc(tsdPtr->interp);
 618     }
 619
 620     /*
 621      * Clean up.
 622      */
 623
 624     Tcl_DeleteInterp(tsdPtr->interp);
 625     Tcl_Release(tsdPtr->interp);
 626     ListRemove(tsdPtr);
 627     Tcl_ExitThread(result);
 628
 629     TCL_THREAD_CREATE_RETURN;
 630 }
 631 \f
 632 /*
 633  *------------------------------------------------------------------------
 634  *
 635  * ThreadErrorProc --
 636  *
 637  *      Send a message to the thread willing to hear about errors.
 638  *
 639  * Results:
 640  *      None
 641  *
 642  * Side effects:
 643  *      Send an event.
 644  *
 645  *------------------------------------------------------------------------
 646  */
 647
 648 static void
 649 ThreadErrorProc(
 650     Tcl_Interp *interp)         /* Interp that failed */
 651 {
 652     Tcl_Channel errChannel;
 653     const char *errorInfo, *argv[3];
 654     char *script;
 655     char buf[TCL_DOUBLE_SPACE+1];
 656
 657     sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
 658
 659     errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
 660     if (errorProcString == NULL) {
 661         errChannel = Tcl_GetStdChannel(TCL_STDERR);
 662         Tcl_WriteChars(errChannel, "Error from thread ", -1);
 663         Tcl_WriteChars(errChannel, buf, -1);
 664         Tcl_WriteChars(errChannel, "\n", 1);
 665         Tcl_WriteChars(errChannel, errorInfo, -1);
 666         Tcl_WriteChars(errChannel, "\n", 1);
 667     } else {
 668         argv[0] = errorProcString;
 669         argv[1] = buf;
 670         argv[2] = errorInfo;
 671         script = Tcl_Merge(3, argv);
 672         ThreadSend(interp, errorThreadId, script, 0);
 673         ckfree(script);
 674     }
 675 }
 676
 677 \f
 678 /*
 679  *------------------------------------------------------------------------
 680  *
 681  * ListUpdateInner --
 682  *
 683  *      Add the thread local storage to the list. This assumes the caller has
 684  *      obtained the mutex.
 685  *
 686  * Results:
 687  *      None
 688  *
 689  * Side effects:
 690  *      Add the thread local storage to its list.
 691  *
 692  *------------------------------------------------------------------------
 693  */
 694
 695 static void
 696 ListUpdateInner(
 697     ThreadSpecificData *tsdPtr)
 698 {
 699     if (tsdPtr == NULL) {
 700         tsdPtr = TCL_TSD_INIT(&dataKey);
 701     }
 702     tsdPtr->threadId = Tcl_GetCurrentThread();
 703     tsdPtr->nextPtr = threadList;
 704     if (threadList) {
 705         threadList->prevPtr = tsdPtr;
 706     }
 707     tsdPtr->prevPtr = NULL;
 708     threadList = tsdPtr;
 709 }
 710 \f
 711 /*
 712  *------------------------------------------------------------------------
 713  *
 714  * ListRemove --
 715  *
 716  *      Remove the thread local storage from its list. This grabs the mutex to
 717  *      protect the list.
 718  *
 719  * Results:
 720  *      None
 721  *
 722  * Side effects:
 723  *      Remove the thread local storage from its list.
 724  *
 725  *------------------------------------------------------------------------
 726  */
 727
 728 static void
 729 ListRemove(
 730     ThreadSpecificData *tsdPtr)
 731 {
 732     if (tsdPtr == NULL) {
 733         tsdPtr = TCL_TSD_INIT(&dataKey);
 734     }
 735     Tcl_MutexLock(&threadMutex);
 736     if (tsdPtr->prevPtr) {
 737         tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
 738     } else {
 739         threadList = tsdPtr->nextPtr;
 740     }
 741     if (tsdPtr->nextPtr) {
 742         tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
 743     }
 744     tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
 745     tsdPtr->interp = NULL;
 746     Tcl_MutexUnlock(&threadMutex);
 747 }
 748 \f
 749 /*
 750  *------------------------------------------------------------------------
 751  *
 752  * ThreadList --
 753  *
 754  *    Return a list of threads running Tcl interpreters.
 755  *
 756  * Results:
 757  *    A standard Tcl result.
 758  *
 759  * Side effects:
 760  *    None.
 761  *
 762  *------------------------------------------------------------------------
 763  */
 764 static int
 765 ThreadList(
 766     Tcl_Interp *interp)
 767 {
 768     ThreadSpecificData *tsdPtr;
 769     Tcl_Obj *listPtr;
 770
 771     listPtr = Tcl_NewListObj(0, NULL);
 772     Tcl_MutexLock(&threadMutex);
 773     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
 774         Tcl_ListObjAppendElement(interp, listPtr,
 775                 Tcl_NewWideIntObj((Tcl_WideInt)(size_t)tsdPtr->threadId));
 776     }
 777     Tcl_MutexUnlock(&threadMutex);
 778     Tcl_SetObjResult(interp, listPtr);
 779     return TCL_OK;
 780 }
 781 \f
 782 /*
 783  *------------------------------------------------------------------------
 784  *
 785  * ThreadSend --
 786  *
 787  *    Send a script to another thread.
 788  *
 789  * Results:
 790  *    A standard Tcl result.
 791  *
 792  * Side effects:
 793  *    None.
 794  *
 795  *------------------------------------------------------------------------
 796  */
 797
 798 static int
 799 ThreadSend(
 800     Tcl_Interp *interp,         /* The current interpreter. */
 801     Tcl_ThreadId id,            /* Thread Id of other interpreter. */
 802     const char *script,         /* The script to evaluate. */
 803     int wait)                   /* If 1, we block for the result. */
 804 {
 805     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 806     ThreadEvent *threadEventPtr;
 807     ThreadEventResult *resultPtr;
 808     int found, code;
 809     Tcl_ThreadId threadId = (Tcl_ThreadId) id;
 810
 811     /*
 812      * Verify the thread exists.
 813      */
 814
 815     Tcl_MutexLock(&threadMutex);
 816     found = 0;
 817     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
 818         if (tsdPtr->threadId == threadId) {
 819             found = 1;
 820             break;
 821         }
 822     }
 823     if (!found) {
 824         Tcl_MutexUnlock(&threadMutex);
 825         Tcl_AppendResult(interp, "invalid thread id", NULL);
 826         return TCL_ERROR;
 827     }
 828
 829     /*
 830      * Short circut sends to ourself. Ought to do something with -async, like
 831      * run in an idle handler.
 832      */
 833
 834     if (threadId == Tcl_GetCurrentThread()) {
 835         Tcl_MutexUnlock(&threadMutex);
 836         return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
 837     }
 838
 839     /*
 840      * Create the event for its event queue.
 841      */
 842
 843     threadEventPtr = ckalloc(sizeof(ThreadEvent));
 844     threadEventPtr->script = ckalloc(strlen(script) + 1);
 845     strcpy(threadEventPtr->script, script);
 846     if (!wait) {
 847         resultPtr = threadEventPtr->resultPtr = NULL;
 848     } else {
 849         resultPtr = ckalloc(sizeof(ThreadEventResult));
 850         threadEventPtr->resultPtr = resultPtr;
 851
 852         /*
 853          * Initialize the result fields.
 854          */
 855
 856         resultPtr->done = NULL;
 857         resultPtr->code = 0;
 858         resultPtr->result = NULL;
 859         resultPtr->errorInfo = NULL;
 860         resultPtr->errorCode = NULL;
 861
 862         /*
 863          * Maintain the cleanup list.
 864          */
 865
 866         resultPtr->srcThreadId = Tcl_GetCurrentThread();
 867         resultPtr->dstThreadId = threadId;
 868         resultPtr->eventPtr = threadEventPtr;
 869         resultPtr->nextPtr = resultList;
 870         if (resultList) {
 871             resultList->prevPtr = resultPtr;
 872         }
 873         resultPtr->prevPtr = NULL;
 874         resultList = resultPtr;
 875     }
 876
 877     /*
 878      * Queue the event and poke the other thread's notifier.
 879      */
 880
 881     threadEventPtr->event.proc = ThreadEventProc;
 882     Tcl_ThreadQueueEvent(threadId, (Tcl_Event *) threadEventPtr,
 883             TCL_QUEUE_TAIL);
 884     Tcl_ThreadAlert(threadId);
 885
 886     if (!wait) {
 887         Tcl_MutexUnlock(&threadMutex);
 888         return TCL_OK;
 889     }
 890
 891     /*
 892      * Block on the results and then get them.
 893      */
 894
 895     Tcl_ResetResult(interp);
 896     while (resultPtr->result == NULL) {
 897         Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
 898     }
 899
 900     /*
 901      * Unlink result from the result list.
 902      */
 903
 904     if (resultPtr->prevPtr) {
 905         resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
 906     } else {
 907         resultList = resultPtr->nextPtr;
 908     }
 909     if (resultPtr->nextPtr) {
 910         resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
 911     }
 912     resultPtr->eventPtr = NULL;
 913     resultPtr->nextPtr = NULL;
 914     resultPtr->prevPtr = NULL;
 915
 916     Tcl_MutexUnlock(&threadMutex);
 917
 918     if (resultPtr->code != TCL_OK) {
 919         if (resultPtr->errorCode) {
 920             Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
 921             ckfree(resultPtr->errorCode);
 922         }
 923         if (resultPtr->errorInfo) {
 924             Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
 925             ckfree(resultPtr->errorInfo);
 926         }
 927     }
 928     Tcl_AppendResult(interp, resultPtr->result, NULL);
 929     Tcl_ConditionFinalize(&resultPtr->done);
 930     code = resultPtr->code;
 931
 932     ckfree(resultPtr->result);
 933     ckfree(resultPtr);
 934
 935     return code;
 936 }
 937 \f
 938 /*
 939  *------------------------------------------------------------------------
 940  *
 941  * ThreadCancel --
 942  *
 943  *    Cancels a script in another thread.
 944  *
 945  * Results:
 946  *    A standard Tcl result.
 947  *
 948  * Side effects:
 949  *    None.
 950  *
 951  *------------------------------------------------------------------------
 952  */
 953
 954 static int
 955 ThreadCancel(
 956     Tcl_Interp *interp,         /* The current interpreter. */
 957     Tcl_ThreadId id,            /* Thread Id of other interpreter. */
 958     const char *result,         /* The result or NULL for default. */
 959     int flags)                  /* Flags for Tcl_CancelEval. */
 960 {
 961     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 962     int found;
 963     Tcl_ThreadId threadId = (Tcl_ThreadId) id;
 964
 965     /*
 966      * Verify the thread exists.
 967      */
 968
 969     Tcl_MutexLock(&threadMutex);
 970     found = 0;
 971     for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
 972         if (tsdPtr->threadId == threadId) {
 973             found = 1;
 974             break;
 975         }
 976     }
 977     if (!found) {
 978         Tcl_MutexUnlock(&threadMutex);
 979         Tcl_AppendResult(interp, "invalid thread id", NULL);
 980         return TCL_ERROR;
 981     }
 982
 983     /*
 984      * Since Tcl_CancelEval can be safely called from any thread,
 985      * we do it now.
 986      */
 987
 988     Tcl_MutexUnlock(&threadMutex);
 989     Tcl_ResetResult(interp);
 990     return Tcl_CancelEval(tsdPtr->interp,
 991         (result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
 992 }
 993 \f
 994 /*
 995  *------------------------------------------------------------------------
 996  *
 997  * ThreadEventProc --
 998  *
 999  *    Handle the event in the target thread.
1000  *
1001  * Results:
1002  *    Returns 1 to indicate that the event was processed.
1003  *
1004  * Side effects:
1005  *    Fills out the ThreadEventResult struct.
1006  *
1007  *------------------------------------------------------------------------
1008  */
1009
1010 static int
1011 ThreadEventProc(
1012     Tcl_Event *evPtr,           /* Really ThreadEvent */
1013     int mask)
1014 {
1015     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1016     ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
1017     ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
1018     Tcl_Interp *interp = tsdPtr->interp;
1019     int code;
1020     const char *result, *errorCode, *errorInfo;
1021
1022     if (interp == NULL) {
1023         code = TCL_ERROR;
1024         result = "no target interp!";
1025         errorCode = "THREAD";
1026         errorInfo = "";
1027     } else {
1028         Tcl_Preserve(interp);
1029         Tcl_ResetResult(interp);
1030         Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
1031         code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
1032         Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
1033         if (code != TCL_OK) {
1034             errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
1035             errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
1036         } else {
1037             errorCode = errorInfo = NULL;
1038         }
1039         result = Tcl_GetStringResult(interp);
1040     }
1041     ckfree(threadEventPtr->script);
1042     if (resultPtr) {
1043         Tcl_MutexLock(&threadMutex);
1044         resultPtr->code = code;
1045         resultPtr->result = ckalloc(strlen(result) + 1);
1046         strcpy(resultPtr->result, result);
1047         if (errorCode != NULL) {
1048             resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
1049             strcpy(resultPtr->errorCode, errorCode);
1050         }
1051         if (errorInfo != NULL) {
1052             resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
1053             strcpy(resultPtr->errorInfo, errorInfo);
1054         }
1055         Tcl_ConditionNotify(&resultPtr->done);
1056         Tcl_MutexUnlock(&threadMutex);
1057     }
1058     if (interp != NULL) {
1059         Tcl_Release(interp);
1060     }
1061     return 1;
1062 }
1063 \f
1064 /*
1065  *------------------------------------------------------------------------
1066  *
1067  * ThreadFreeProc --
1068  *
1069  *    This is called from when we are exiting and memory needs
1070  *    to be freed.
1071  *
1072  * Results:
1073  *    None.
1074  *
1075  * Side effects:
1076  *      Clears up mem specified in ClientData
1077  *
1078  *------------------------------------------------------------------------
1079  */
1080
1081      /* ARGSUSED */
1082 static void
1083 ThreadFreeProc(
1084     ClientData clientData)
1085 {
1086     if (clientData) {
1087         ckfree(clientData);
1088     }
1089 }
1090 \f
1091 /*
1092  *------------------------------------------------------------------------
1093  *
1094  * ThreadDeleteEvent --
1095  *
1096  *    This is called from the ThreadExitProc to delete memory related
1097  *    to events that we put on the queue.
1098  *
1099  * Results:
1100  *    1 it was our event and we want it removed, 0 otherwise.
1101  *
1102  * Side effects:
1103  *      It cleans up our events in the event queue for this thread.
1104  *
1105  *------------------------------------------------------------------------
1106  */
1107
1108      /* ARGSUSED */
1109 static int
1110 ThreadDeleteEvent(
1111     Tcl_Event *eventPtr,        /* Really ThreadEvent */
1112     ClientData clientData)      /* dummy */
1113 {
1114     if (eventPtr->proc == ThreadEventProc) {
1115         ckfree(((ThreadEvent *) eventPtr)->script);
1116         return 1;
1117     }
1118
1119     /*
1120      * If it was NULL, we were in the middle of servicing the event and it
1121      * should be removed
1122      */
1123
1124     return (eventPtr->proc == NULL);
1125 }
1126 \f
1127 /*
1128  *------------------------------------------------------------------------
1129  *
1130  * ThreadExitProc --
1131  *
1132  *    This is called when the thread exits.
1133  *
1134  * Results:
1135  *    None.
1136  *
1137  * Side effects:
1138  *      It unblocks anyone that is waiting on a send to this thread. It cleans
1139  *      up any events in the event queue for this thread.
1140  *
1141  *------------------------------------------------------------------------
1142  */
1143
1144      /* ARGSUSED */
1145 static void
1146 ThreadExitProc(
1147     ClientData clientData)
1148 {
1149     char *threadEvalScript = clientData;
1150     ThreadEventResult *resultPtr, *nextPtr;
1151     Tcl_ThreadId self = Tcl_GetCurrentThread();
1152     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1153
1154     if (tsdPtr->interp != NULL) {
1155         ListRemove(tsdPtr);
1156     }
1157
1158     Tcl_MutexLock(&threadMutex);
1159
1160     if (self == errorThreadId) {
1161         if (errorProcString) {  /* Extra safety */
1162             ckfree(errorProcString);
1163             errorProcString = NULL;
1164         }
1165         errorThreadId = 0;
1166     }
1167
1168     if (threadEvalScript) {
1169         ckfree(threadEvalScript);
1170         threadEvalScript = NULL;
1171     }
1172     Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL);
1173
1174     for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
1175         nextPtr = resultPtr->nextPtr;
1176         if (resultPtr->srcThreadId == self) {
1177             /*
1178              * We are going away. By freeing up the result we signal to the
1179              * other thread we don't care about the result.
1180              */
1181
1182             if (resultPtr->prevPtr) {
1183                 resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
1184             } else {
1185                 resultList = resultPtr->nextPtr;
1186             }
1187             if (resultPtr->nextPtr) {
1188                 resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
1189             }
1190             resultPtr->nextPtr = resultPtr->prevPtr = 0;
1191             resultPtr->eventPtr->resultPtr = NULL;
1192             ckfree(resultPtr);
1193         } else if (resultPtr->dstThreadId == self) {
1194             /*
1195              * Dang. The target is going away. Unblock the caller. The result
1196              * string must be dynamically allocated because the main thread is
1197              * going to call free on it.
1198              */
1199
1200             const char *msg = "target thread died";
1201
1202             resultPtr->result = ckalloc(strlen(msg) + 1);
1203             strcpy(resultPtr->result, msg);
1204             resultPtr->code = TCL_ERROR;
1205             Tcl_ConditionNotify(&resultPtr->done);
1206         }
1207     }
1208     Tcl_MutexUnlock(&threadMutex);
1209 }
1210 #endif /* TCL_THREADS */
1211 \f
1212 /*
1213  * Local Variables:
1214  * mode: c
1215  * c-basic-offset: 4
1216  * fill-column: 78
1217  * End:
1218  */