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 */ 16 17#include "tclInt.h" 18 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 */ 30 31typedef 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; 38static Tcl_ThreadDataKey dataKey; 39 40/* 41 * This list is used to list all threads that have interpreters. 42 * This is protected by threadMutex. 43 */ 44 45static struct ThreadSpecificData *threadList; 46 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 */ 52 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 */ 58 59typedef 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; 71 72/* 73 * This is the event used to send scripts to other threads. 74 */ 75 76typedef 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; 83 84typedef 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; 95 96} ThreadEventResult; 97 98static ThreadEventResult *resultList; 99 100/* 101 * This is for simple error handling when a thread script exits badly. 102 */ 103 104static Tcl_ThreadId errorThreadId; 105static char *errorProcString; 106 107/* 108 * Access to the list of threads and to the thread send results is 109 * guarded by this mutex. 110 */ 111 112TCL_DECLARE_MUTEX(threadMutex) 113 114#undef TCL_STORAGE_CLASS 115#define TCL_STORAGE_CLASS DLLEXPORT 116 117EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); 118EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData, 119 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); 120EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp, 121 char *script, int joinable)); 122EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp)); 123EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id, 124 char *script, int wait)); 125 126#undef TCL_STORAGE_CLASS 127#define TCL_STORAGE_CLASS DLLIMPORT 128 129Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData)); 130static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); 131static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); 132static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask)); 133static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp)); 134static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData)); 135static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr, 136 ClientData clientData)); 137static void ThreadExitProc _ANSI_ARGS_((ClientData clientData)); 138 139 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 */ 155 156int 157TclThread_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} 168 169 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 */ 195 196 /* ARGSUSED */ 197int 198Tcl_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}; 211 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 } 220 221 /* 222 * Make sure the initial thread is on the list before doing anything. 223 */ 224 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 } 232 233 switch ((enum options)option) { 234 case THREAD_CREATE: { 235 char *script; 236 int joinable, len; 237 238 if (objc == 2) { 239 /* Neither joinable nor special script 240 */ 241 242 joinable = 0; 243 script = "testthread wait"; /* Just enter the event loop */ 244 245 } else if (objc == 3) { 246 /* Possibly -joinable, then no special script, 247 * no joinable, then its a script. 248 */ 249 250 script = Tcl_GetString(objv[2]); 251 len = strlen (script); 252 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 */ 267 268 script = Tcl_GetString(objv[2]); 269 len = strlen (script); 270 271 joinable = ((len > 1) && 272 (script [0] == '-') && (script [1] == 'j') && 273 (0 == strncmp (script, "-joinable", (size_t) len))); 274 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; 303 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 } 311 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; 333 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 */ 365 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} 385 386 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 */ 403 404 /* ARGSUSED */ 405int 406TclCreateThread(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; 413 414 ctrl.script = script; 415 ctrl.condWait = NULL; 416 ctrl.flags = 0; 417 418 joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS; 419 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 } 428 429 /* 430 * Wait for the thread to start because it is using something on our stack! 431 */ 432 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} 439 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 */ 468Tcl_ThreadCreateType 469NewTestThread(clientData) 470 ClientData clientData; 471{ 472 ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData; 473 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 474 int result; 475 char *threadEvalScript; 476 477 /* 478 * Initialize the interpreter. This should be more general. 479 */ 480 481 tsdPtr->interp = Tcl_CreateInterp(); 482 result = Tcl_Init(tsdPtr->interp); 483 result = TclThread_Init(tsdPtr->interp); 484 485 /* 486 * Update the list of threads. 487 */ 488 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); 497 498 Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript); 499 500 /* 501 * Notify the parent we are alive. 502 */ 503 504 Tcl_ConditionNotify(&ctrlPtr->condWait); 505 Tcl_MutexUnlock(&threadMutex); 506 507 /* 508 * Run the script. 509 */ 510 511 Tcl_Preserve((ClientData) tsdPtr->interp); 512 result = Tcl_Eval(tsdPtr->interp, threadEvalScript); 513 if (result != TCL_OK) { 514 ThreadErrorProc(tsdPtr->interp); 515 } 516 517 /* 518 * Clean up. 519 */ 520 521 ListRemove(tsdPtr); 522 Tcl_Release((ClientData) tsdPtr->interp); 523 Tcl_DeleteInterp(tsdPtr->interp); 524 Tcl_ExitThread(result); 525 526 TCL_THREAD_CREATE_RETURN; 527} 528 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 */ 544static void 545ThreadErrorProc(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()); 553 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} 571 572 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 */ 589static void 590ListUpdateInner(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} 604 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 */ 621static void 622ListRemove(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} 640 641 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 */ 657int 658TclThreadList(interp) 659 Tcl_Interp *interp; 660{ 661 ThreadSpecificData *tsdPtr; 662 Tcl_Obj *listPtr; 663 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} 674 675 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 */ 691int 692TclThreadSend(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; 703 704 /* 705 * Verify the thread exists. 706 */ 707 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 } 721 722 /* 723 * Short circut sends to ourself. Ought to do something with -async, 724 * like run in an idle handler. 725 */ 726 727 if (threadId == Tcl_GetCurrentThread()) { 728 Tcl_MutexUnlock(&threadMutex); 729 return Tcl_GlobalEval(interp, script); 730 } 731 732 /* 733 * Create the event for its event queue. 734 */ 735 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; 744 745 /* 746 * Initialize the result fields. 747 */ 748 749 resultPtr->done = NULL; 750 resultPtr->code = 0; 751 resultPtr->result = NULL; 752 resultPtr->errorInfo = NULL; 753 resultPtr->errorCode = NULL; 754 755 /* 756 * Maintain the cleanup list. 757 */ 758 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 } 769 770 /* 771 * Queue the event and poke the other thread's notifier. 772 */ 773 774 threadEventPtr->event.proc = ThreadEventProc; 775 Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr, 776 TCL_QUEUE_TAIL); 777 Tcl_ThreadAlert(threadId); 778 779 if (!wait) { 780 Tcl_MutexUnlock(&threadMutex); 781 return TCL_OK; 782 } 783 784 /* 785 * Block on the results and then get them. 786 */ 787 788 Tcl_ResetResult(interp); 789 while (resultPtr->result == NULL) { 790 Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); 791 } 792 793 /* 794 * Unlink result from the result list. 795 */ 796 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; 808 809 Tcl_MutexUnlock(&threadMutex); 810 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; 824 825 ckfree((char *) resultPtr); 826 827 return code; 828} 829 830 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 */ 846static int 847ThreadEventProc(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; 857 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} 901 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 */ 919static void 920ThreadFreeProc(clientData) 921 ClientData clientData; 922{ 923 if (clientData) { 924 ckfree((char *) clientData); 925 } 926} 927 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 */ 945static int 946ThreadDeleteEvent(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} 960 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 */ 978static void 979ThreadExitProc(clientData) 980 ClientData clientData; 981{ 982 char *threadEvalScript = (char *) clientData; 983 ThreadEventResult *resultPtr, *nextPtr; 984 Tcl_ThreadId self = Tcl_GetCurrentThread(); 985 986 Tcl_MutexLock(&threadMutex); 987 988 if (threadEvalScript) { 989 ckfree((char *) threadEvalScript); 990 threadEvalScript = NULL; 991 } 992 Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL); 993 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 */ 1018 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} 1028 1029#endif /* TCL_THREADS */ 1030