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