1/* 2 * threadCmd.c -- 3 * 4 * This file implements the Tcl thread commands that allow script 5 * level access to threading. It will not load into a core that was 6 * not compiled for thread support. 7 * 8 * See http://www.tcl.tk/doc/howto/thread_model.html 9 * 10 * Some of this code is based on work done by Richard Hipp on behalf of 11 * Conservation Through Innovation, Limited, with their permission. 12 * 13 * Copyright (c) 1998 by Sun Microsystems, Inc. 14 * Copyright (c) 1999,2000 by Scriptics Corporation. 15 * Copyright (c) 2002 by Zoran Vasiljevic. 16 * 17 * See the file "license.terms" for information on usage and redistribution 18 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 19 * 20 * RCS: @(#) $Id: threadCmd.c,v 1.106 2010/04/02 16:49:58 vasiljevic Exp $ 21 * ---------------------------------------------------------------------------- 22 */ 23 24#include "tclThread.h" 25 26#ifdef NS_AOLSERVER 27# include "aolstub.cpp" 28#endif 29 30/* 31 * Access to the list of threads and to the thread send results 32 * (defined below) is guarded by this mutex. 33 */ 34 35TCL_DECLARE_MUTEX(threadMutex) 36 37/* 38 * Each thread has an single instance of the following structure. There 39 * is one instance of this structure per thread even if that thread contains 40 * multiple interpreters. The interpreter identified by this structure is 41 * the main interpreter for the thread. The main interpreter is the one that 42 * will process any messages received by a thread. Any interpreter can send 43 * messages but only the main interpreter can receive them, unless you're 44 * not doing asynchronous script backfiring. In such cases the caller might 45 * signal the thread to which interpreter the result should be delivered. 46 */ 47 48typedef struct ThreadSpecificData { 49 Tcl_ThreadId threadId; /* The real ID of this thread */ 50 Tcl_Interp *interp; /* Main interp for this thread */ 51 Tcl_Condition doOneEvent; /* Signalled just before running 52 an event from the event loop */ 53 int flags; /* One of the ThreadFlags below */ 54 int refCount; /* Used for thread reservation */ 55 int eventsPending; /* # of unprocessed events */ 56 int maxEventsCount; /* Maximum # of pending events */ 57 struct ThreadEventResult *result; 58 struct ThreadSpecificData *nextPtr; 59 struct ThreadSpecificData *prevPtr; 60} ThreadSpecificData; 61 62static Tcl_ThreadDataKey dataKey; 63 64#define THREAD_FLAGS_NONE 0 /* None */ 65#define THREAD_FLAGS_STOPPED 1 /* Thread is being stopped */ 66#define THREAD_FLAGS_INERROR 2 /* Thread is in error */ 67#define THREAD_FLAGS_UNWINDONERROR 4 /* Thread unwinds on script error */ 68 69#define THREAD_RESERVE 1 /* Reserves the thread */ 70#define THREAD_RELEASE 2 /* Releases the thread */ 71 72/* 73 * Length of storage for building the Tcl handle for the thread. 74 */ 75 76#define THREAD_HNDLPREFIX "tid" 77#define THREAD_HNDLMAXLEN 32 78 79/* 80 * This list is used to list all threads that have interpreters. 81 */ 82 83static struct ThreadSpecificData *threadList = NULL; 84 85/* 86 * Used to represent the empty result. 87 */ 88 89static char *threadEmptyResult = (char *)""; 90 91/* 92 * An instance of the following structure contains all information that is 93 * passed into a new thread when the thread is created using either the 94 * "thread create" Tcl command or the ThreadCreate() C function. 95 */ 96 97typedef struct ThreadCtrl { 98 char *script; /* Script to execute */ 99 int flags; /* Initial value of the "flags" 100 * field in ThreadSpecificData */ 101 Tcl_Condition condWait; /* Condition variable used to 102 * sync parent and child threads */ 103 ClientData cd; /* Opaque ptr to pass to thread */ 104} ThreadCtrl; 105 106/* 107 * Structure holding result of the command executed in target thread. 108 */ 109 110typedef struct ThreadEventResult { 111 Tcl_Condition done; /* Set when the script completes */ 112 int code; /* Return value of the function */ 113 char *result; /* Result from the function */ 114 char *errorInfo; /* Copy of errorInfo variable */ 115 char *errorCode; /* Copy of errorCode variable */ 116 Tcl_ThreadId srcThreadId; /* Id of sender, if it dies */ 117 Tcl_ThreadId dstThreadId; /* Id of target, if it dies */ 118 struct ThreadEvent *eventPtr; /* Back pointer */ 119 struct ThreadEventResult *nextPtr; /* List for cleanup */ 120 struct ThreadEventResult *prevPtr; 121} ThreadEventResult; 122 123/* 124 * This list links all active ThreadEventResult structures. This way 125 * an exiting thread can inform all threads waiting on jobs posted to 126 * his event queue that it is dying, so they might stop waiting. 127 */ 128 129static ThreadEventResult *resultList; 130 131/* 132 * This is the event used to send commands to other threads. 133 */ 134 135typedef struct ThreadEvent { 136 Tcl_Event event; /* Must be first */ 137 struct ThreadSendData *sendData; /* See below */ 138 struct ThreadClbkData *clbkData; /* See below */ 139 struct ThreadEventResult *resultPtr; /* To communicate the result back. 140 * NULL if we don't care about it */ 141} ThreadEvent; 142 143typedef int (ThreadSendProc) _ANSI_ARGS_((Tcl_Interp*, ClientData)); 144typedef void (ThreadSendFree) _ANSI_ARGS_((ClientData)); 145 146static ThreadSendProc ThreadSendEval; /* Does a regular Tcl_Eval */ 147static ThreadSendProc ThreadClbkSetVar; /* Sets the named variable */ 148 149/* 150 * These structures are used to communicate commands between source and target 151 * threads. The ThreadSendData is used for source->target command passing, 152 * while the ThreadClbkData is used for doing asynchronous callbacks. 153 * 154 * Important: structures below must have first three elements indentical! 155 */ 156 157typedef struct ThreadSendData { 158 ThreadSendProc *execProc; /* Func to exec in remote thread */ 159 ClientData clientData; /* Ptr to pass to send function */ 160 ThreadSendFree *freeProc; /* Function to free client data */ 161 /* ---- */ 162 Tcl_Interp *interp; /* Interp to run the command */ 163} ThreadSendData; 164 165typedef struct ThreadClbkData { 166 ThreadSendProc *execProc; /* The callback function */ 167 ClientData clientData; /* Ptr to pass to clbk function */ 168 ThreadSendFree *freeProc; /* Function to free client data */ 169 /* ---- */ 170 Tcl_Interp *interp; /* Interp to run the command */ 171 Tcl_ThreadId threadId; /* Thread where to post callback */ 172 ThreadEventResult result; /* Returns result asynchronously */ 173} ThreadClbkData; 174 175/* 176 * Event used to transfer a channel between threads. 177 */ 178typedef struct TransferEvent { 179 Tcl_Event event; /* Must be first */ 180 Tcl_Channel chan; /* The channel to transfer */ 181 struct TransferResult *resultPtr; /* To communicate the result */ 182} TransferEvent; 183 184typedef struct TransferResult { 185 Tcl_Condition done; /* Set when transfer is done */ 186 int resultCode; /* Set to TCL_OK or TCL_ERROR when 187 the transfer is done. Def = -1 */ 188 char *resultMsg; /* Initialized to NULL. Set to a 189 allocated string by the targer 190 thread in case of an error */ 191 Tcl_ThreadId srcThreadId; /* Id of src thread, if it dies */ 192 Tcl_ThreadId dstThreadId; /* Id of tgt thread, if it dies */ 193 struct TransferEvent *eventPtr; /* Back pointer */ 194 struct TransferResult *nextPtr; /* Next in the linked list */ 195 struct TransferResult *prevPtr; /* Previous in the linked list */ 196} TransferResult; 197 198static TransferResult *transferList; 199 200/* 201 * This is for simple error handling when a thread script exits badly. 202 */ 203 204static Tcl_ThreadId errorThreadId; /* Id of thread to post error message */ 205static char *errorProcString; /* Tcl script to run when reporting error */ 206 207/* 208 * Definition of flags for ThreadSend. 209 */ 210 211#define THREAD_SEND_WAIT 1<<1 212#define THREAD_SEND_HEAD 1<<2 213 214#ifdef BUILD_thread 215# undef TCL_STORAGE_CLASS 216# define TCL_STORAGE_CLASS DLLEXPORT 217#endif 218 219/* 220 * Miscelaneous functions used within this file 221 */ 222 223static Tcl_EventDeleteProc ThreadDeleteEvent; 224 225static Tcl_ThreadCreateType 226NewThread _ANSI_ARGS_((ClientData clientData)); 227 228static ThreadSpecificData* 229ThreadExistsInner _ANSI_ARGS_((Tcl_ThreadId id)); 230 231static int 232ThreadInit _ANSI_ARGS_((Tcl_Interp *interp)); 233 234static int 235ThreadCreate _ANSI_ARGS_((Tcl_Interp *interp, 236 const char *script, 237 int stacksize, 238 int flags, 239 int preserve)); 240static int 241ThreadSend _ANSI_ARGS_((Tcl_Interp *interp, 242 Tcl_ThreadId id, 243 ThreadSendData *sendPtr, 244 ThreadClbkData *clbkPtr, 245 int flags)); 246static void 247ThreadSetResult _ANSI_ARGS_((Tcl_Interp *interp, 248 int code, 249 ThreadEventResult *resultPtr)); 250static int 251ThreadGetOption _ANSI_ARGS_((Tcl_Interp *interp, 252 Tcl_ThreadId id, 253 char *option, 254 Tcl_DString *ds)); 255static int 256ThreadSetOption _ANSI_ARGS_((Tcl_Interp *interp, 257 Tcl_ThreadId id, 258 char *option, 259 char *value)); 260static int 261ThreadReserve _ANSI_ARGS_((Tcl_Interp *interp, 262 Tcl_ThreadId id, 263 int operation, 264 int wait)); 265static int 266ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, 267 int mask)); 268static int 269ThreadWait _ANSI_ARGS_((void)); 270 271static int 272ThreadExists _ANSI_ARGS_((Tcl_ThreadId id)); 273 274static int 275ThreadList _ANSI_ARGS_((Tcl_Interp *interp, 276 Tcl_ThreadId **thrIdArray)); 277static void 278ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp)); 279 280static void 281ThreadFreeProc _ANSI_ARGS_((ClientData clientData)); 282 283static void 284ThreadIdleProc _ANSI_ARGS_((ClientData clientData)); 285 286static void 287ThreadExitProc _ANSI_ARGS_((ClientData clientData)); 288 289static void 290ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); 291 292static void 293ListRemoveInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); 294 295static void 296ListUpdate _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); 297 298static void 299ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr)); 300 301static int 302ThreadJoin _ANSI_ARGS_((Tcl_Interp *interp, 303 Tcl_ThreadId id)); 304static int 305ThreadTransfer _ANSI_ARGS_((Tcl_Interp *interp, 306 Tcl_ThreadId id, 307 Tcl_Channel chan)); 308static int 309ThreadDetach _ANSI_ARGS_((Tcl_Interp *interp, 310 Tcl_Channel chan)); 311static int 312ThreadAttach _ANSI_ARGS_((Tcl_Interp *interp, 313 char *chanName)); 314static int 315TransferEventProc _ANSI_ARGS_((Tcl_Event *evPtr, 316 int mask)); 317 318static void 319ThreadGetHandle _ANSI_ARGS_((Tcl_ThreadId, 320 char *handlePtr)); 321 322static int 323ThreadGetId _ANSI_ARGS_((Tcl_Interp *interp, 324 Tcl_Obj *handleObj, 325 Tcl_ThreadId *thrIdPtr)); 326static void 327ErrorNoSuchThread _ANSI_ARGS_((Tcl_Interp *interp, 328 Tcl_ThreadId thrId)); 329static void 330ThreadCutChannel _ANSI_ARGS_((Tcl_Interp *interp, 331 Tcl_Channel channel)); 332 333/* 334 * Functions implementing Tcl commands 335 */ 336 337static Tcl_ObjCmdProc ThreadCreateObjCmd; 338static Tcl_ObjCmdProc ThreadReserveObjCmd; 339static Tcl_ObjCmdProc ThreadReleaseObjCmd; 340static Tcl_ObjCmdProc ThreadSendObjCmd; 341static Tcl_ObjCmdProc ThreadBroadcastObjCmd; 342static Tcl_ObjCmdProc ThreadUnwindObjCmd; 343static Tcl_ObjCmdProc ThreadExitObjCmd; 344static Tcl_ObjCmdProc ThreadIdObjCmd; 345static Tcl_ObjCmdProc ThreadNamesObjCmd; 346static Tcl_ObjCmdProc ThreadWaitObjCmd; 347static Tcl_ObjCmdProc ThreadExistsObjCmd; 348static Tcl_ObjCmdProc ThreadConfigureObjCmd; 349static Tcl_ObjCmdProc ThreadErrorProcObjCmd; 350static Tcl_ObjCmdProc ThreadJoinObjCmd; 351static Tcl_ObjCmdProc ThreadTransferObjCmd; 352static Tcl_ObjCmdProc ThreadDetachObjCmd; 353static Tcl_ObjCmdProc ThreadAttachObjCmd; 354 355static int 356ThreadInit(interp) 357 Tcl_Interp *interp; /* The current Tcl interpreter */ 358{ 359 Tcl_Obj *boolObjPtr; 360 const char *msg; 361 int boolVar; 362 363 if (Tcl_InitStubs(interp, "8.4", 0) == NULL) { 364 return TCL_ERROR; 365 } 366 367 boolObjPtr = Tcl_GetVar2Ex(interp, "::tcl_platform", "threaded", 0); 368 369 if (boolObjPtr == NULL 370 || Tcl_GetBooleanFromObj(interp, boolObjPtr, &boolVar) != TCL_OK 371 || boolVar == 0) { 372 msg = "Tcl core wasn't compiled for threading."; 373 Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); 374 return TCL_ERROR; 375 } 376 377 /* 378 * We seem to have a Tcl core compiled with threads enabled. 379 */ 380 381 TCL_CMD(interp, THREAD_CMD_PREFIX"create", ThreadCreateObjCmd); 382 TCL_CMD(interp, THREAD_CMD_PREFIX"send", ThreadSendObjCmd); 383 TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd); 384 TCL_CMD(interp, THREAD_CMD_PREFIX"exit", ThreadExitObjCmd); 385 TCL_CMD(interp, THREAD_CMD_PREFIX"unwind", ThreadUnwindObjCmd); 386 TCL_CMD(interp, THREAD_CMD_PREFIX"id", ThreadIdObjCmd); 387 TCL_CMD(interp, THREAD_CMD_PREFIX"names", ThreadNamesObjCmd); 388 TCL_CMD(interp, THREAD_CMD_PREFIX"exists", ThreadExistsObjCmd); 389 TCL_CMD(interp, THREAD_CMD_PREFIX"wait", ThreadWaitObjCmd); 390 TCL_CMD(interp, THREAD_CMD_PREFIX"configure", ThreadConfigureObjCmd); 391 TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd); 392 TCL_CMD(interp, THREAD_CMD_PREFIX"preserve", ThreadReserveObjCmd); 393 TCL_CMD(interp, THREAD_CMD_PREFIX"release", ThreadReleaseObjCmd); 394 TCL_CMD(interp, THREAD_CMD_PREFIX"join", ThreadJoinObjCmd); 395 TCL_CMD(interp, THREAD_CMD_PREFIX"transfer", ThreadTransferObjCmd); 396 TCL_CMD(interp, THREAD_CMD_PREFIX"detach", ThreadDetachObjCmd); 397 TCL_CMD(interp, THREAD_CMD_PREFIX"attach", ThreadAttachObjCmd); 398 399 /* 400 * Add shared variable commands 401 */ 402 403 Sv_Init(interp); 404 405 /* 406 * Add commands to access thread 407 * synchronization primitives. 408 */ 409 410 Sp_Init(interp); 411 412 /* 413 * Add threadpool commands. 414 */ 415 416 Tpool_Init(interp); 417 418 return TCL_OK; 419} 420 421 422/* 423 *---------------------------------------------------------------------- 424 * 425 * Thread_Init -- 426 * 427 * Initialize the thread commands. 428 * 429 * Results: 430 * TCL_OK if the package was properly initialized. 431 * 432 * Side effects: 433 * Adds package commands to the current interp. 434 * 435 *---------------------------------------------------------------------- 436 */ 437 438EXTERN int 439Thread_Init(interp) 440 Tcl_Interp *interp; /* The current Tcl interpreter */ 441{ 442 int status = ThreadInit(interp); 443 444 if (status != TCL_OK) { 445 return status; 446 } 447 448 return Tcl_PkgProvide(interp, "Thread", PACKAGE_VERSION); 449} 450 451/* 452 *---------------------------------------------------------------------- 453 * 454 * Thread_SafeInit -- 455 * 456 * This function is called from within initialization of the safe 457 * Tcl interpreter. 458 * 459 * Results: 460 * Standard Tcl result 461 * 462 * Side effects: 463 * Commands added to the current interpreter, 464 * 465 *---------------------------------------------------------------------- 466 */ 467 468EXTERN int 469Thread_SafeInit(interp) 470 Tcl_Interp *interp; 471{ 472 return Thread_Init(interp); 473} 474 475/* 476 *---------------------------------------------------------------------- 477 * 478 * Init -- 479 * 480 * Make sure internal list of threads references the current thread. 481 * 482 * Results: 483 * None 484 * 485 * Side effects: 486 * The list of threads is initialized to include the current thread. 487 * 488 *---------------------------------------------------------------------- 489 */ 490 491static void 492Init(interp) 493 Tcl_Interp *interp; /* Current interpreter. */ 494{ 495 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 496 497 if (tsdPtr->interp == (Tcl_Interp*)NULL) { 498 memset(tsdPtr, 0, sizeof(ThreadSpecificData)); 499 tsdPtr->interp = interp; 500 ListUpdate(tsdPtr); 501 Tcl_CreateThreadExitHandler(ThreadExitProc, 502 (ClientData)threadEmptyResult); 503 } 504} 505 506/* 507 *---------------------------------------------------------------------- 508 * 509 * ThreadCreateObjCmd -- 510 * 511 * This procedure is invoked to process the "thread::create" Tcl 512 * command. See the user documentation for details on what it does. 513 * 514 * Results: 515 * A standard Tcl result. 516 * 517 * Side effects: 518 * See the user documentation. 519 * 520 *---------------------------------------------------------------------- 521 */ 522 523static int 524ThreadCreateObjCmd(dummy, interp, objc, objv) 525 ClientData dummy; /* Not used. */ 526 Tcl_Interp *interp; /* Current interpreter. */ 527 int objc; /* Number of arguments. */ 528 Tcl_Obj *const objv[]; /* Argument objects. */ 529{ 530 int argc, rsrv = 0; 531 const char *arg, *script; 532 int flags = TCL_THREAD_NOFLAGS; 533 534 Init(interp); 535 536 /* 537 * Syntax: thread::create ?-joinable? ?-preserved? ?script? 538 */ 539 540 script = THREAD_CMD_PREFIX"wait"; 541 542 for (argc = 1; argc < objc; argc++) { 543 arg = Tcl_GetStringFromObj(objv[argc], NULL); 544 if (OPT_CMP(arg, "--")) { 545 argc++; 546 if ((argc + 1) == objc) { 547 script = Tcl_GetStringFromObj(objv[argc], NULL); 548 } else { 549 goto usage; 550 } 551 break; 552 } else if (OPT_CMP(arg, "-joinable")) { 553 flags |= TCL_THREAD_JOINABLE; 554 } else if (OPT_CMP(arg, "-preserved")) { 555 rsrv = 1; 556 } else if ((argc + 1) == objc) { 557 script = Tcl_GetStringFromObj(objv[argc], NULL); 558 } else { 559 goto usage; 560 } 561 } 562 563 return ThreadCreate(interp, script, TCL_THREAD_STACK_DEFAULT, flags, rsrv); 564 565 usage: 566 Tcl_WrongNumArgs(interp, 1, objv, "?-joinable? ?script?"); 567 return TCL_ERROR; 568} 569 570/* 571 *---------------------------------------------------------------------- 572 * 573 * ThreadReserveObjCmd -- 574 * 575 * This procedure is invoked to process the "thread::preserve" and 576 * "thread::release" Tcl commands, depending on the flag passed by 577 * the ClientData argument. See the user documentation for details 578 * on what those command do. 579 * 580 * Results: 581 * A standard Tcl result. 582 * 583 * Side effects: 584 * See the user documentation. 585 * 586 *---------------------------------------------------------------------- 587 */ 588 589static int 590ThreadReserveObjCmd(dummy, interp, objc, objv) 591 ClientData dummy; /* Not used. */ 592 Tcl_Interp *interp; /* Current interpreter. */ 593 int objc; /* Number of arguments. */ 594 Tcl_Obj *const objv[]; /* Argument objects. */ 595{ 596 Tcl_ThreadId thrId = (Tcl_ThreadId)0; 597 598 Init(interp); 599 600 if (objc > 2) { 601 Tcl_WrongNumArgs(interp, 1, objv, "?threadId?"); 602 return TCL_ERROR; 603 } 604 if (objc == 2) { 605 if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { 606 return TCL_ERROR; 607 } 608 } 609 610 return ThreadReserve(interp, thrId, THREAD_RESERVE, 0); 611} 612 613/* 614 *---------------------------------------------------------------------- 615 * 616 * ThreadReleaseObjCmd -- 617 * 618 * This procedure is invoked to process the "thread::release" Tcl 619 * command. See the user documentation for details on what this 620 * command does. 621 * 622 * Results: 623 * A standard Tcl result. 624 * 625 * Side effects: 626 * See the user documentation. 627 * 628 *---------------------------------------------------------------------- 629 */ 630 631static int 632ThreadReleaseObjCmd(dummy, interp, objc, objv) 633 ClientData dummy; /* Not used. */ 634 Tcl_Interp *interp; /* Current interpreter. */ 635 int objc; /* Number of arguments. */ 636 Tcl_Obj *const objv[]; /* Argument objects. */ 637{ 638 int wait = 0; 639 Tcl_ThreadId thrId = (Tcl_ThreadId)0; 640 641 Init(interp); 642 643 if (objc > 3) { 644 Tcl_WrongNumArgs(interp, 1, objv, "?-wait? ?threadId?"); 645 return TCL_ERROR; 646 } 647 if (objc > 1) { 648 if (OPT_CMP(Tcl_GetString(objv[1]), "-wait")) { 649 wait = 1; 650 if (ThreadGetId(interp, objv[2], &thrId) != TCL_OK) { 651 return TCL_ERROR; 652 } 653 } else if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { 654 return TCL_ERROR; 655 } 656 } 657 658 return ThreadReserve(interp, thrId, THREAD_RELEASE, wait); 659} 660 661/* 662 *---------------------------------------------------------------------- 663 * 664 * ThreadUnwindObjCmd -- 665 * 666 * This procedure is invoked to process the "thread::unwind" Tcl 667 * command. See the user documentation for details on what it does. 668 * 669 * Results: 670 * A standard Tcl result. 671 * 672 * Side effects: 673 * See the user documentation. 674 * 675 *---------------------------------------------------------------------- 676 */ 677 678static int 679ThreadUnwindObjCmd(dummy, interp, objc, objv) 680 ClientData dummy; /* Not used. */ 681 Tcl_Interp *interp; /* Current interpreter. */ 682 int objc; /* Number of arguments. */ 683 Tcl_Obj *const objv[]; /* Argument objects. */ 684{ 685 Init(interp); 686 687 if (objc > 1) { 688 Tcl_WrongNumArgs(interp, 1, objv, NULL); 689 return TCL_ERROR; 690 } 691 692 return ThreadReserve(interp, 0, THREAD_RELEASE, 0); 693} 694 695/* 696 *---------------------------------------------------------------------- 697 * 698 * ThreadExitObjCmd -- 699 * 700 * This procedure is invoked to process the "thread::exit" Tcl 701 * command. This causes an unconditional close of the thread 702 * and is GUARENTEED to cause memory leaks. Use this with caution. 703 * 704 * Results: 705 * Doesn't actually return. 706 * 707 * Side effects: 708 * Lots. improper clean up of resources. 709 * 710 *---------------------------------------------------------------------- 711 */ 712 713static int 714ThreadExitObjCmd(dummy, interp, objc, objv) 715 ClientData dummy; /* Not used. */ 716 Tcl_Interp *interp; /* Current interpreter. */ 717 int objc; /* Number of arguments. */ 718 Tcl_Obj *const objv[]; /* Argument objects. */ 719{ 720 721 Init(interp); 722 ListRemove(NULL); 723 724 Tcl_ExitThread(666); 725 726 return TCL_OK; /* NOT REACHED */ 727} 728 729/* 730 *---------------------------------------------------------------------- 731 * 732 * ThreadIdObjCmd -- 733 * 734 * This procedure is invoked to process the "thread::id" Tcl command. 735 * This returns the ID of the current thread. 736 * 737 * Results: 738 * A standard Tcl result. 739 * 740 * Side effects: 741 * None. 742 * 743 *---------------------------------------------------------------------- 744 */ 745 746static int 747ThreadIdObjCmd(dummy, interp, objc, objv) 748 ClientData dummy; /* Not used. */ 749 Tcl_Interp *interp; /* Current interpreter. */ 750 int objc; /* Number of arguments. */ 751 Tcl_Obj *const objv[]; /* Argument objects. */ 752{ 753 char thrHandle[THREAD_HNDLMAXLEN]; 754 755 Init(interp); 756 757 if (objc > 1) { 758 Tcl_WrongNumArgs(interp, 1, objv, NULL); 759 return TCL_ERROR; 760 } 761 762 ThreadGetHandle(Tcl_GetCurrentThread(), thrHandle); 763 Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1)); 764 765 return TCL_OK; 766} 767 768/* 769 *---------------------------------------------------------------------- 770 * 771 * ThreadNamesObjCmd -- 772 * 773 * This procedure is invoked to process the "thread::names" Tcl 774 * command. This returns a list of all known thread IDs. 775 * These are only threads created via this module (e.g., not 776 * driver threads or the notifier). 777 * 778 * Results: 779 * A standard Tcl result. 780 * 781 * Side effects: 782 * None. 783 * 784 *---------------------------------------------------------------------- 785 */ 786 787static int 788ThreadNamesObjCmd(dummy, interp, objc, objv) 789 ClientData dummy; /* Not used. */ 790 Tcl_Interp *interp; /* Current interpreter. */ 791 int objc; /* Number of arguments. */ 792 Tcl_Obj *const objv[]; /* Argument objects. */ 793{ 794 int ii, length; 795 char *result, thrHandle[THREAD_HNDLMAXLEN]; 796 Tcl_ThreadId *thrIdArray; 797 Tcl_DString threadNames; 798 799 Init(interp); 800 801 if (objc > 1) { 802 Tcl_WrongNumArgs(interp, 1, objv, NULL); 803 return TCL_ERROR; 804 } 805 806 length = ThreadList(interp, &thrIdArray); 807 808 if (length == 0) { 809 return TCL_OK; 810 } 811 812 Tcl_DStringInit(&threadNames); 813 814 for (ii = 0; ii < length; ii++) { 815 ThreadGetHandle(thrIdArray[ii], thrHandle); 816 Tcl_DStringAppendElement(&threadNames, thrHandle); 817 } 818 819 length = Tcl_DStringLength(&threadNames); 820 result = Tcl_DStringValue(&threadNames); 821 822 Tcl_SetObjResult(interp, Tcl_NewStringObj(result, length)); 823 824 Tcl_DStringFree(&threadNames); 825 Tcl_Free((char*)thrIdArray); 826 827 return TCL_OK; 828} 829 830/* 831 *---------------------------------------------------------------------- 832 * 833 * ThreadSendObjCmd -- 834 * 835 * This procedure is invoked to process the "thread::send" Tcl 836 * command. This sends a script to another thread for execution. 837 * 838 * Results: 839 * A standard Tcl result. 840 * 841 * Side effects: 842 * None. 843 * 844 *---------------------------------------------------------------------- 845 */ 846 847static int 848ThreadSendObjCmd(dummy, interp, objc, objv) 849 ClientData dummy; /* Not used. */ 850 Tcl_Interp *interp; /* Current interpreter. */ 851 int objc; /* Number of arguments. */ 852 Tcl_Obj *const objv[]; /* Argument objects. */ 853{ 854 int ret, len, vlen = 0, ii = 0, flags = 0; 855 Tcl_ThreadId thrId; 856 const char *script, *arg, *var = NULL; 857 858 ThreadClbkData *clbkPtr = NULL; 859 ThreadSendData *sendPtr = NULL; 860 861 Init(interp); 862 863 /* 864 * Syntax: thread::send ?-async? ?-head? threadId script ?varName? 865 */ 866 867 if (objc < 3 || objc > 6) { 868 goto usage; 869 } 870 871 flags = THREAD_SEND_WAIT; 872 873 for (ii = 1; ii < objc; ii++) { 874 arg = Tcl_GetStringFromObj(objv[ii], NULL); 875 if (OPT_CMP(arg, "-async")) { 876 flags &= ~THREAD_SEND_WAIT; 877 } else if (OPT_CMP(arg, "-head")) { 878 flags |= THREAD_SEND_HEAD; 879 } else { 880 break; 881 } 882 } 883 if (ii >= objc) { 884 goto usage; 885 } 886 if (ThreadGetId(interp, objv[ii], &thrId) != TCL_OK) { 887 return TCL_ERROR; 888 } 889 if (++ii >= objc) { 890 goto usage; 891 } 892 893 script = Tcl_GetStringFromObj(objv[ii], &len); 894 if (++ii < objc) { 895 var = Tcl_GetStringFromObj(objv[ii], &vlen); 896 } 897 if (var && (flags & THREAD_SEND_WAIT) == 0) { 898 if (thrId == Tcl_GetCurrentThread()) { 899 /* 900 * FIXME: Do something for callbacks to self 901 */ 902 Tcl_SetResult(interp, "can't notify self", TCL_STATIC); 903 return TCL_ERROR; 904 } 905 906 /* 907 * Prepare record for the callback. This is asynchronously 908 * posted back to us when the target thread finishes processing. 909 * We should do a vwait on the "var" to get notified. 910 */ 911 912 clbkPtr = (ThreadClbkData*)Tcl_Alloc(sizeof(ThreadClbkData)); 913 clbkPtr->execProc = ThreadClbkSetVar; 914 clbkPtr->freeProc = (ThreadSendFree*)Tcl_Free; 915 clbkPtr->interp = interp; 916 clbkPtr->threadId = Tcl_GetCurrentThread(); 917 clbkPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+vlen), var); 918 } 919 920 /* 921 * Prepare job record for the target thread 922 */ 923 924 sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData)); 925 sendPtr->interp = NULL; /* Signal to use thread main interp */ 926 sendPtr->execProc = ThreadSendEval; 927 sendPtr->freeProc = (ThreadSendFree*)Tcl_Free; 928 sendPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+len), script); 929 930 ret = ThreadSend(interp, thrId, sendPtr, clbkPtr, flags); 931 932 if (var && (flags & THREAD_SEND_WAIT)) { 933 934 /* 935 * Leave job's result in passed variable 936 * and return the code, like "catch" does. 937 */ 938 939 Tcl_Obj *resultObj = Tcl_GetObjResult(interp); 940 if (!Tcl_SetVar2Ex(interp, var, NULL, resultObj, TCL_LEAVE_ERR_MSG)) { 941 return TCL_ERROR; 942 } 943 Tcl_SetObjResult(interp, Tcl_NewIntObj(ret)); 944 return TCL_OK; 945 } 946 947 return ret; 948 949usage: 950 Tcl_WrongNumArgs(interp,1,objv,"?-async? ?-head? id script ?varName?"); 951 return TCL_ERROR; 952} 953 954/* 955 *---------------------------------------------------------------------- 956 * 957 * ThreadBroadcastObjCmd -- 958 * 959 * This procedure is invoked to process the "thread::broadcast" Tcl 960 * command. This asynchronously sends a script to all known threads. 961 * 962 * Results: 963 * A standard Tcl result. 964 * 965 * Side effects: 966 * Script is sent to all known threads except the caller thread. 967 * 968 *---------------------------------------------------------------------- 969 */ 970 971static int 972ThreadBroadcastObjCmd(dummy, interp, objc, objv) 973 ClientData dummy; /* Not used. */ 974 Tcl_Interp *interp; /* Current interpreter. */ 975 int objc; /* Number of arguments. */ 976 Tcl_Obj *const objv[]; /* Argument objects. */ 977{ 978 int ii, len, nthreads; 979 const char *script; 980 Tcl_ThreadId *thrIdArray; 981 ThreadSendData *sendPtr, job; 982 983 Init(interp); 984 985 if (objc != 2) { 986 Tcl_WrongNumArgs(interp, 1, objv, "script"); 987 return TCL_ERROR; 988 } 989 990 script = Tcl_GetStringFromObj(objv[1], &len); 991 992 /* 993 * Get the list of known threads. Note that this one may 994 * actually change (thread may exit or otherwise cease to 995 * exist) while we circle in the loop below. We really do 996 * not care about that here since we don't return any 997 * script results to the caller. 998 */ 999 1000 nthreads = ThreadList(interp, &thrIdArray); 1001 1002 if (nthreads == 0) { 1003 return TCL_OK; 1004 } 1005 1006 /* 1007 * Prepare the structure with the job description 1008 * to be sent asynchronously to each known thread. 1009 */ 1010 1011 job.interp = NULL; /* Signal to use thread's main interp */ 1012 job.execProc = ThreadSendEval; 1013 job.freeProc = (ThreadSendFree*)Tcl_Free; 1014 job.clientData = NULL; 1015 1016 /* 1017 * Now, circle this list and send each thread the script. 1018 * This is sent asynchronously, since we do not care what 1019 * are they going to do with it. Also, the event is queued 1020 * to the head of the event queue (as out-of-band message). 1021 */ 1022 1023 for (ii = 0; ii < nthreads; ii++) { 1024 if (thrIdArray[ii] == Tcl_GetCurrentThread()) { 1025 continue; /* Do not broadcast self */ 1026 } 1027 sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData)); 1028 *sendPtr = job; 1029 sendPtr->clientData = (ClientData)strcpy(Tcl_Alloc(1+len), script); 1030 ThreadSend(interp, thrIdArray[ii], sendPtr, NULL, THREAD_SEND_HEAD); 1031 } 1032 1033 Tcl_Free((char*)thrIdArray); 1034 Tcl_ResetResult(interp); 1035 1036 return TCL_OK; 1037} 1038 1039/* 1040 *---------------------------------------------------------------------- 1041 * 1042 * ThreadWaitObjCmd -- 1043 * 1044 * This procedure is invoked to process the "thread::wait" Tcl 1045 * command. This enters the event loop. 1046 * 1047 * Results: 1048 * Standard Tcl result. 1049 * 1050 * Side effects: 1051 * Enters the event loop. 1052 * 1053 *---------------------------------------------------------------------- 1054 */ 1055 1056static int 1057ThreadWaitObjCmd(dummy, interp, objc, objv) 1058 ClientData dummy; /* Not used. */ 1059 Tcl_Interp *interp; /* Current interpreter. */ 1060 int objc; /* Number of arguments. */ 1061 Tcl_Obj *const objv[]; /* Argument objects. */ 1062{ 1063 Init(interp); 1064 1065 if (objc > 1) { 1066 Tcl_WrongNumArgs(interp, 1, objv, NULL); 1067 return TCL_ERROR; 1068 } 1069 1070 return ThreadWait(); 1071} 1072 1073/* 1074 *---------------------------------------------------------------------- 1075 * 1076 * ThreadErrorProcObjCmd -- 1077 * 1078 * This procedure is invoked to process the "thread::errorproc" 1079 * command. This registers a procedure to handle thread errors. 1080 * Empty string as the name of the procedure will reset the 1081 * default behaviour, which is writing to standard error channel. 1082 * 1083 * Results: 1084 * A standard Tcl result. 1085 * 1086 * Side effects: 1087 * Registers an errorproc. 1088 * 1089 *---------------------------------------------------------------------- 1090 */ 1091 1092static int 1093ThreadErrorProcObjCmd(dummy, interp, objc, objv) 1094 ClientData dummy; /* Not used. */ 1095 Tcl_Interp *interp; /* Current interpreter. */ 1096 int objc; /* Number of arguments. */ 1097 Tcl_Obj *const objv[]; /* Argument objects. */ 1098{ 1099 int len; 1100 char *proc; 1101 1102 Init(interp); 1103 1104 if (objc > 2) { 1105 Tcl_WrongNumArgs(interp, 1, objv, "?proc?"); 1106 return TCL_ERROR; 1107 } 1108 Tcl_MutexLock(&threadMutex); 1109 if (objc == 1) { 1110 if (errorProcString) { 1111 Tcl_SetResult(interp, errorProcString, TCL_VOLATILE); 1112 } 1113 } else { 1114 errorThreadId = Tcl_GetCurrentThread(); 1115 if (errorProcString) { 1116 Tcl_Free(errorProcString); 1117 } 1118 proc = Tcl_GetStringFromObj(objv[1], &len); 1119 if (len == 0) { 1120 errorProcString = NULL; 1121 } else { 1122 errorProcString = Tcl_Alloc(1+strlen(proc)); 1123 strcpy(errorProcString, proc); 1124 } 1125 } 1126 Tcl_MutexUnlock(&threadMutex); 1127 1128 return TCL_OK; 1129} 1130 1131/* 1132 *---------------------------------------------------------------------- 1133 * 1134 * ThreadJoinObjCmd -- 1135 * 1136 * This procedure is invoked to process the "thread::join" Tcl 1137 * command. See the user documentation for details on what it does. 1138 * 1139 * Results: 1140 * A standard Tcl result. 1141 * 1142 * Side effects: 1143 * See the user documentation. 1144 * 1145 *---------------------------------------------------------------------- 1146 */ 1147 1148static int 1149ThreadJoinObjCmd(dummy, interp, objc, objv) 1150 ClientData dummy; /* Not used. */ 1151 Tcl_Interp *interp; /* Current interpreter. */ 1152 int objc; /* Number of arguments. */ 1153 Tcl_Obj *const objv[]; /* Argument objects. */ 1154{ 1155 Tcl_ThreadId thrId; 1156 1157 Init(interp); 1158 1159 /* 1160 * Syntax of 'join': id 1161 */ 1162 1163 if (objc != 2) { 1164 Tcl_WrongNumArgs(interp, 1, objv, "id"); 1165 return TCL_ERROR; 1166 } 1167 1168 if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { 1169 return TCL_ERROR; 1170 } 1171 1172 return ThreadJoin(interp, thrId); 1173} 1174 1175/* 1176 *---------------------------------------------------------------------- 1177 * 1178 * ThreadTransferObjCmd -- 1179 * 1180 * This procedure is invoked to process the "thread::transfer" Tcl 1181 * command. See the user documentation for details on what it does. 1182 * 1183 * Results: 1184 * A standard Tcl result. 1185 * 1186 * Side effects: 1187 * See the user documentation. 1188 * 1189 *---------------------------------------------------------------------- 1190 */ 1191 1192static int 1193ThreadTransferObjCmd(dummy, interp, objc, objv) 1194 ClientData dummy; /* Not used. */ 1195 Tcl_Interp *interp; /* Current interpreter. */ 1196 int objc; /* Number of arguments. */ 1197 Tcl_Obj *const objv[]; /* Argument objects. */ 1198{ 1199 1200 Tcl_ThreadId thrId; 1201 Tcl_Channel chan; 1202 1203 Init(interp); 1204 1205 /* 1206 * Syntax of 'transfer': id channel 1207 */ 1208 1209 if (objc != 3) { 1210 Tcl_WrongNumArgs(interp, 1, objv, "id channel"); 1211 return TCL_ERROR; 1212 } 1213 if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { 1214 return TCL_ERROR; 1215 } 1216 1217 chan = Tcl_GetChannel(interp, Tcl_GetString(objv[2]), NULL); 1218 if (chan == (Tcl_Channel)NULL) { 1219 return TCL_ERROR; 1220 } 1221 1222 return ThreadTransfer(interp, thrId, Tcl_GetTopChannel(chan)); 1223} 1224 1225/* 1226 *---------------------------------------------------------------------- 1227 * 1228 * ThreadDetachObjCmd -- 1229 * 1230 * This procedure is invoked to process the "thread::detach" Tcl 1231 * command. See the user documentation for details on what it does. 1232 * 1233 * Results: 1234 * A standard Tcl result. 1235 * 1236 * Side effects: 1237 * See the user documentation. 1238 * 1239 *---------------------------------------------------------------------- 1240 */ 1241 1242static int 1243ThreadDetachObjCmd(dummy, interp, objc, objv) 1244 ClientData dummy; /* Not used. */ 1245 Tcl_Interp *interp; /* Current interpreter. */ 1246 int objc; /* Number of arguments. */ 1247 Tcl_Obj *const objv[]; /* Argument objects. */ 1248{ 1249 Tcl_Channel chan; 1250 1251 Init(interp); 1252 1253 /* 1254 * Syntax: thread::detach channel 1255 */ 1256 1257 if (objc != 2) { 1258 Tcl_WrongNumArgs(interp, 1, objv, "channel"); 1259 return TCL_ERROR; 1260 } 1261 1262 chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); 1263 if (chan == (Tcl_Channel)NULL) { 1264 return TCL_ERROR; 1265 } 1266 1267 return ThreadDetach(interp, Tcl_GetTopChannel(chan)); 1268} 1269 1270/* 1271 *---------------------------------------------------------------------- 1272 * 1273 * ThreadAttachObjCmd -- 1274 * 1275 * This procedure is invoked to process the "thread::attach" Tcl 1276 * command. See the user documentation for details on what it does. 1277 * 1278 * Results: 1279 * A standard Tcl result. 1280 * 1281 * Side effects: 1282 * See the user documentation. 1283 * 1284 *---------------------------------------------------------------------- 1285 */ 1286 1287static int 1288ThreadAttachObjCmd(dummy, interp, objc, objv) 1289 ClientData dummy; /* Not used. */ 1290 Tcl_Interp *interp; /* Current interpreter. */ 1291 int objc; /* Number of arguments. */ 1292 Tcl_Obj *const objv[]; /* Argument objects. */ 1293{ 1294 char *chanName; 1295 1296 Init(interp); 1297 1298 /* 1299 * Syntax: thread::attach channel 1300 */ 1301 1302 if (objc != 2) { 1303 Tcl_WrongNumArgs(interp, 1, objv, "channel"); 1304 return TCL_ERROR; 1305 } 1306 1307 chanName = Tcl_GetString(objv[1]); 1308 if (Tcl_IsChannelExisting(chanName)) { 1309 return TCL_OK; 1310 } 1311 1312 return ThreadAttach(interp, chanName); 1313} 1314 1315/* 1316 *---------------------------------------------------------------------- 1317 * 1318 * ThreadExistsObjCmd -- 1319 * 1320 * This procedure is invoked to process the "thread::exists" Tcl 1321 * command. See the user documentation for details on what it does. 1322 * 1323 * Results: 1324 * A standard Tcl result. 1325 * 1326 * Side effects: 1327 * See the user documentation. 1328 * 1329 *---------------------------------------------------------------------- 1330 */ 1331 1332static int 1333ThreadExistsObjCmd(dummy, interp, objc, objv) 1334 ClientData dummy; /* Not used. */ 1335 Tcl_Interp *interp; /* Current interpreter. */ 1336 int objc; /* Number of arguments. */ 1337 Tcl_Obj *const objv[]; /* Argument objects. */ 1338{ 1339 Tcl_ThreadId thrId; 1340 1341 Init(interp); 1342 1343 if (objc != 2) { 1344 Tcl_WrongNumArgs(interp, 1, objv, "id"); 1345 return TCL_ERROR; 1346 } 1347 1348 if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { 1349 return TCL_ERROR; 1350 } 1351 1352 Tcl_SetBooleanObj(Tcl_GetObjResult(interp), ThreadExists(thrId)); 1353 1354 return TCL_OK; 1355} 1356 1357/* 1358 *---------------------------------------------------------------------- 1359 * 1360 * ThreadConfigureObjCmd -- 1361 * 1362 * This procedure is invoked to process the Tcl "thread::configure" 1363 * command. See the user documentation for details on what it does. 1364 * 1365 * Results: 1366 * A standard Tcl result. 1367 * 1368 * Side effects: 1369 * None. 1370 *---------------------------------------------------------------------- 1371 */ 1372static int 1373ThreadConfigureObjCmd(dummy, interp, objc, objv) 1374 ClientData dummy; /* Not used. */ 1375 Tcl_Interp *interp; /* Current interpreter. */ 1376 int objc; /* Number of arguments. */ 1377 Tcl_Obj *const objv[]; /* Argument objects. */ 1378{ 1379 char *option, *value; 1380 Tcl_ThreadId thrId; /* Id of the thread to configure */ 1381 int i; /* Iterate over arg-value pairs. */ 1382 Tcl_DString ds; /* DString to hold result of 1383 * calling GetThreadOption. */ 1384 1385 if (objc < 2 || (objc % 2 == 1 && objc != 3)) { 1386 Tcl_WrongNumArgs(interp, 1, objv, "threadlId ?optionName? " 1387 "?value? ?optionName value?..."); 1388 return TCL_ERROR; 1389 } 1390 1391 Init(interp); 1392 1393 if (ThreadGetId(interp, objv[1], &thrId) != TCL_OK) { 1394 return TCL_ERROR; 1395 } 1396 if (objc == 2) { 1397 Tcl_DStringInit(&ds); 1398 if (ThreadGetOption(interp, thrId, NULL, &ds) != TCL_OK) { 1399 Tcl_DStringFree(&ds); 1400 return TCL_ERROR; 1401 } 1402 Tcl_DStringResult(interp, &ds); 1403 return TCL_OK; 1404 } 1405 if (objc == 3) { 1406 Tcl_DStringInit(&ds); 1407 option = Tcl_GetString(objv[2]); 1408 if (ThreadGetOption(interp, thrId, option, &ds) != TCL_OK) { 1409 Tcl_DStringFree(&ds); 1410 return TCL_ERROR; 1411 } 1412 Tcl_DStringResult(interp, &ds); 1413 return TCL_OK; 1414 } 1415 for (i = 3; i < objc; i += 2) { 1416 option = Tcl_GetString(objv[i-1]); 1417 value = Tcl_GetString(objv[i]); 1418 if (ThreadSetOption(interp, thrId, option, value) != TCL_OK) { 1419 return TCL_ERROR; 1420 } 1421 } 1422 1423 return TCL_OK; 1424} 1425 1426/* 1427 *---------------------------------------------------------------------- 1428 * 1429 * ThreadSendEval -- 1430 * 1431 * Evaluates Tcl script passed from source to target thread. 1432 * 1433 * Results: 1434 * A standard Tcl result. 1435 * 1436 * Side effects: 1437 * 1438 *---------------------------------------------------------------------- 1439 */ 1440 1441static int 1442ThreadSendEval(interp, clientData) 1443 Tcl_Interp *interp; 1444 ClientData clientData; 1445{ 1446 ThreadSendData *sendPtr = (ThreadSendData*)clientData; 1447 char *script = (char*)sendPtr->clientData; 1448 1449 return Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL); 1450} 1451 1452/* 1453 *---------------------------------------------------------------------- 1454 * 1455 * ThreadClbkSetVar -- 1456 * 1457 * Sets the Tcl variable in the source thread, as the result 1458 * of the asynchronous callback. 1459 * 1460 * Results: 1461 * A standard Tcl result. 1462 * 1463 * Side effects: 1464 * New Tcl variable may be created 1465 * 1466 *---------------------------------------------------------------------- 1467 */ 1468 1469static int 1470ThreadClbkSetVar(interp, clientData) 1471 Tcl_Interp *interp; 1472 ClientData clientData; 1473{ 1474 ThreadClbkData *clbkPtr = (ThreadClbkData*)clientData; 1475 const char *var = (const char *)clbkPtr->clientData; 1476 Tcl_Obj *valObj; 1477 ThreadEventResult *resultPtr = &clbkPtr->result; 1478 1479 /* 1480 * Get the result of the posted command. 1481 * We will use it to fill-in the result variable. 1482 */ 1483 1484 valObj = Tcl_NewStringObj(resultPtr->result, -1); 1485 if (resultPtr->result != threadEmptyResult) { 1486 Tcl_Free(resultPtr->result); 1487 } 1488 1489 /* 1490 * Set the result variable 1491 */ 1492 1493 if (Tcl_SetVar2Ex(interp, var, NULL, valObj, 1494 TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) { 1495 return TCL_ERROR; 1496 } 1497 1498 /* 1499 * In case of error, trigger the bgerror mechansim 1500 */ 1501 1502 if (resultPtr->code == TCL_ERROR) { 1503 if (resultPtr->errorCode) { 1504 var = "errorCode"; 1505 Tcl_SetVar(interp, var, resultPtr->errorCode, TCL_GLOBAL_ONLY); 1506 Tcl_Free((char*)resultPtr->errorCode); 1507 } 1508 if (resultPtr->errorInfo) { 1509 var = "errorInfo"; 1510 Tcl_SetVar(interp, var, resultPtr->errorInfo, TCL_GLOBAL_ONLY); 1511 Tcl_Free((char*)resultPtr->errorInfo); 1512 } 1513 Tcl_SetObjResult(interp, valObj); 1514 Tcl_BackgroundError(interp); 1515 } 1516 1517 return TCL_OK; 1518} 1519 1520/* 1521 *---------------------------------------------------------------------- 1522 * 1523 * ThreadCreate -- 1524 * 1525 * This procedure is invoked to create a thread containing an 1526 * interp to run a script. This returns after the thread has 1527 * started executing. 1528 * 1529 * Results: 1530 * A standard Tcl result, which is the thread ID. 1531 * 1532 * Side effects: 1533 * Create a thread. 1534 * 1535 *---------------------------------------------------------------------- 1536 */ 1537 1538static int 1539ThreadCreate(interp, script, stacksize, flags, preserve) 1540 Tcl_Interp *interp; /* Current interpreter. */ 1541 const char *script; /* Script to evaluate */ 1542 int stacksize; /* Zero for default size */ 1543 int flags; /* Zero for no flags */ 1544 int preserve; /* If true, reserve the thread */ 1545{ 1546 char thrHandle[THREAD_HNDLMAXLEN]; 1547 ThreadCtrl ctrl; 1548 Tcl_ThreadId thrId; 1549 1550#ifdef NS_AOLSERVER 1551 ctrl.cd = Tcl_GetAssocData(interp, "thread:nsd", NULL); 1552#endif 1553 ctrl.script = (char *)script; 1554 ctrl.condWait = NULL; 1555 ctrl.flags = 0; 1556 1557 Tcl_MutexLock(&threadMutex); 1558 if (Tcl_CreateThread(&thrId, NewThread, (ClientData)&ctrl, 1559 stacksize, flags) != TCL_OK) { 1560 Tcl_MutexUnlock(&threadMutex); 1561 Tcl_SetResult(interp, "can't create a new thread", TCL_STATIC); 1562 return TCL_ERROR; 1563 } 1564 1565 /* 1566 * Wait for the thread to start because it is using 1567 * the ThreadCtrl argument which is on our stack. 1568 */ 1569 1570 while (ctrl.script != NULL) { 1571 Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL); 1572 } 1573 if (preserve) { 1574 ThreadSpecificData *tsdPtr = ThreadExistsInner(thrId); 1575 if (tsdPtr == (ThreadSpecificData*)NULL) { 1576 Tcl_MutexUnlock(&threadMutex); 1577 Tcl_ConditionFinalize(&ctrl.condWait); 1578 ErrorNoSuchThread(interp, thrId); 1579 return TCL_ERROR; 1580 } 1581 tsdPtr->refCount++; 1582 } 1583 1584 Tcl_MutexUnlock(&threadMutex); 1585 Tcl_ConditionFinalize(&ctrl.condWait); 1586 1587 ThreadGetHandle(thrId, thrHandle); 1588 Tcl_SetObjResult(interp, Tcl_NewStringObj(thrHandle, -1)); 1589 1590 return TCL_OK; 1591} 1592 1593/* 1594 *---------------------------------------------------------------------- 1595 * 1596 * NewThread -- 1597 * 1598 * This routine is the "main()" for a new thread whose task is to 1599 * execute a single TCL script. The argument to this function is 1600 * a pointer to a structure that contains the text of the Tcl script 1601 * to be executed, plus some synchronization primitives. Those are 1602 * used so the caller gets signalized when the new thread has 1603 * done its initialization. 1604 * 1605 * Space to hold the ThreadControl structure itself is reserved on 1606 * the stack of the calling function. The two condition variables 1607 * in the ThreadControl structure are destroyed by the calling 1608 * function as well. The calling function will destroy the 1609 * ThreadControl structure and the condition variable as soon as 1610 * ctrlPtr->condWait is signaled, so this routine must make copies 1611 * of any data it might need after that point. 1612 * 1613 * Results: 1614 * none 1615 * 1616 * Side effects: 1617 * A Tcl script is executed in a new thread. 1618 * 1619 *---------------------------------------------------------------------- 1620 */ 1621 1622Tcl_ThreadCreateType 1623NewThread(clientData) 1624 ClientData clientData; 1625{ 1626 ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData; 1627 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1628 Tcl_Interp *interp; 1629 int result = TCL_OK, scriptLen; 1630 char *evalScript; 1631 1632 /* 1633 * Initialize the interpreter. The bad thing here is that we 1634 * assume that initialization of the Tcl interp will be 1635 * error free, which it may not. In the future we must recover 1636 * from this and exit gracefully (this is not that easy as 1637 * it seems on the first glance...) 1638 */ 1639 1640#ifdef NS_AOLSERVER 1641 struct mydata *md = (struct mydata*)ctrlPtr->cd; 1642 Ns_ThreadSetName("-tclthread-"); 1643 interp = (Tcl_Interp*)Ns_TclAllocateInterp(md ? md->server : NULL); 1644#else 1645 interp = Tcl_CreateInterp(); 1646 result = Tcl_Init(interp); 1647#endif 1648 1649#if !defined(NS_AOLSERVER) || (defined(NS_MAJOR_VERSION) && NS_MAJOR_VERSION >= 4) 1650 result = Thread_Init(interp); 1651#endif 1652 1653 tsdPtr->interp = interp; 1654 1655 Tcl_MutexLock(&threadMutex); 1656 1657 /* 1658 * Update the list of threads. 1659 */ 1660 1661 ListUpdateInner(tsdPtr); 1662 1663 /* 1664 * We need to keep a pointer to the alloc'ed mem of the script 1665 * we are eval'ing, for the case that we exit during evaluation 1666 */ 1667 1668 scriptLen = strlen(ctrlPtr->script); 1669 evalScript = strcpy((char*)Tcl_Alloc(scriptLen+1), ctrlPtr->script); 1670 Tcl_CreateThreadExitHandler(ThreadExitProc,(ClientData)evalScript); 1671 1672 /* 1673 * Notify the parent we are alive. 1674 */ 1675 1676 ctrlPtr->script = NULL; 1677 Tcl_ConditionNotify(&ctrlPtr->condWait); 1678 1679 Tcl_MutexUnlock(&threadMutex); 1680 1681 /* 1682 * Run the script. 1683 */ 1684 1685 Tcl_Preserve((ClientData)tsdPtr->interp); 1686 result = Tcl_EvalEx(tsdPtr->interp, evalScript,scriptLen,TCL_EVAL_GLOBAL); 1687 if (result != TCL_OK) { 1688 ThreadErrorProc(tsdPtr->interp); 1689 } 1690 1691 /* 1692 * Clean up. Note: add something like TlistRemove for the transfer list. 1693 */ 1694 1695 if (tsdPtr->doOneEvent) { 1696 Tcl_ConditionFinalize(&tsdPtr->doOneEvent); 1697 } 1698 1699 ListRemove(tsdPtr); 1700 1701 /* 1702 * It is up to all other extensions, including Tk, to be responsible 1703 * for their own events when they receive their Tcl_CallWhenDeleted 1704 * notice when we delete this interp. 1705 */ 1706 1707#ifdef NS_AOLSERVER 1708 Ns_TclMarkForDelete(tsdPtr->interp); 1709 Ns_TclDeAllocateInterp(tsdPtr->interp); 1710#else 1711 Tcl_DeleteInterp(tsdPtr->interp); 1712#endif 1713 Tcl_Release((ClientData)tsdPtr->interp); 1714 1715 /* 1716 * Tcl_ExitThread calls Tcl_FinalizeThread() indirectly which calls 1717 * ThreadExitHandlers and cleans the notifier as well as other sub- 1718 * systems that save thread state data. 1719 */ 1720 1721 Tcl_ExitThread(result); 1722 1723 TCL_THREAD_CREATE_RETURN; 1724} 1725 1726/* 1727 *---------------------------------------------------------------------- 1728 * 1729 * ThreadErrorProc -- 1730 * 1731 * Send a message to the thread willing to hear about errors. 1732 * 1733 * Results: 1734 * None 1735 * 1736 * Side effects: 1737 * Send an event. 1738 * 1739 *---------------------------------------------------------------------- 1740 */ 1741 1742static void 1743ThreadErrorProc(interp) 1744 Tcl_Interp *interp; /* Interp that failed */ 1745{ 1746 ThreadSendData *sendPtr; 1747 const char *argv[3]; 1748 char buf[THREAD_HNDLMAXLEN]; 1749 const char *errorInfo; 1750 1751 errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); 1752 if (errorInfo == NULL) { 1753 errorInfo = ""; 1754 } 1755 1756 if (errorProcString == NULL) { 1757#ifdef NS_AOLSERVER 1758 Ns_Log(Error, "%s\n%s", Tcl_GetStringResult(interp), errorInfo); 1759#else 1760 Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); 1761 if (errChannel == NULL) { 1762 /* Fixes the [#634845] bug; credits to 1763 * Wojciech Kocjan <wojciech@kocjan.org> */ 1764 return; 1765 } 1766 ThreadGetHandle(Tcl_GetCurrentThread(), buf); 1767 Tcl_WriteChars(errChannel, "Error from thread ", -1); 1768 Tcl_WriteChars(errChannel, buf, -1); 1769 Tcl_WriteChars(errChannel, "\n", 1); 1770 Tcl_WriteChars(errChannel, errorInfo, -1); 1771 Tcl_WriteChars(errChannel, "\n", 1); 1772#endif 1773 } else { 1774 ThreadGetHandle(Tcl_GetCurrentThread(), buf); 1775 argv[0] = errorProcString; 1776 argv[1] = buf; 1777 argv[2] = errorInfo; 1778 1779 sendPtr = (ThreadSendData*)Tcl_Alloc(sizeof(ThreadSendData)); 1780 sendPtr->execProc = ThreadSendEval; 1781 sendPtr->freeProc = (ThreadSendFree*)Tcl_Free; 1782 sendPtr->clientData = (ClientData) Tcl_Merge(3, argv); 1783 sendPtr->interp = NULL; 1784 1785 ThreadSend(interp, errorThreadId, sendPtr, NULL, 0); 1786 } 1787} 1788 1789/* 1790 *---------------------------------------------------------------------- 1791 * 1792 * ListUpdate -- 1793 * 1794 * Add the thread local storage to the list. This grabs the 1795 * mutex to protect the list. 1796 * 1797 * Results: 1798 * None 1799 * 1800 * Side effects: 1801 * None. 1802 * 1803 *---------------------------------------------------------------------- 1804 */ 1805 1806static void 1807ListUpdate(tsdPtr) 1808 ThreadSpecificData *tsdPtr; 1809{ 1810 if (tsdPtr == NULL) { 1811 tsdPtr = TCL_TSD_INIT(&dataKey); 1812 } 1813 1814 Tcl_MutexLock(&threadMutex); 1815 ListUpdateInner(tsdPtr); 1816 Tcl_MutexUnlock(&threadMutex); 1817} 1818 1819/* 1820 *---------------------------------------------------------------------- 1821 * 1822 * ListUpdateInner -- 1823 * 1824 * Add the thread local storage to the list. This assumes the caller 1825 * has obtained the threadMutex. 1826 * 1827 * Results: 1828 * None 1829 * 1830 * Side effects: 1831 * Add the thread local storage to its list. 1832 * 1833 *---------------------------------------------------------------------- 1834 */ 1835 1836static void 1837ListUpdateInner(tsdPtr) 1838 ThreadSpecificData *tsdPtr; 1839{ 1840 if (threadList) { 1841 threadList->prevPtr = tsdPtr; 1842 } 1843 1844 tsdPtr->nextPtr = threadList; 1845 tsdPtr->prevPtr = NULL; 1846 tsdPtr->threadId = Tcl_GetCurrentThread(); 1847 1848 threadList = tsdPtr; 1849} 1850 1851/* 1852 *---------------------------------------------------------------------- 1853 * 1854 * ListRemove -- 1855 * 1856 * Remove the thread local storage from its list. This grabs the 1857 * mutex to protect the list. 1858 * 1859 * Results: 1860 * None 1861 * 1862 * Side effects: 1863 * Remove the thread local storage from its list. 1864 * 1865 *---------------------------------------------------------------------- 1866 */ 1867 1868static void 1869ListRemove(tsdPtr) 1870 ThreadSpecificData *tsdPtr; 1871{ 1872 if (tsdPtr == NULL) { 1873 tsdPtr = TCL_TSD_INIT(&dataKey); 1874 } 1875 1876 Tcl_MutexLock(&threadMutex); 1877 ListRemoveInner(tsdPtr); 1878 Tcl_MutexUnlock(&threadMutex); 1879} 1880 1881/* 1882 *---------------------------------------------------------------------- 1883 * 1884 * ListRemoveInner -- 1885 * 1886 * Remove the thread local storage from its list. 1887 * 1888 * Results: 1889 * None 1890 * 1891 * Side effects: 1892 * Remove the thread local storage from its list. 1893 * 1894 *---------------------------------------------------------------------- 1895 */ 1896 1897static void 1898ListRemoveInner(tsdPtr) 1899 ThreadSpecificData *tsdPtr; 1900{ 1901 if (tsdPtr->prevPtr || tsdPtr->nextPtr) { 1902 if (tsdPtr->prevPtr) { 1903 tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; 1904 } else { 1905 threadList = tsdPtr->nextPtr; 1906 } 1907 if (tsdPtr->nextPtr) { 1908 tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; 1909 } 1910 tsdPtr->nextPtr = NULL; 1911 tsdPtr->prevPtr = NULL; 1912 } else if (tsdPtr == threadList) { 1913 threadList = NULL; 1914 } 1915} 1916 1917/* 1918 *---------------------------------------------------------------------- 1919 * 1920 * ThreadList -- 1921 * 1922 * Return a list of threads running Tcl interpreters. 1923 * 1924 * Results: 1925 * Number of threads. 1926 * 1927 * Side effects: 1928 * None. 1929 * 1930 *---------------------------------------------------------------------- 1931 */ 1932 1933static int 1934ThreadList(interp, thrIdArray) 1935 Tcl_Interp *interp; 1936 Tcl_ThreadId **thrIdArray; 1937{ 1938 int ii, count = 0; 1939 ThreadSpecificData *tsdPtr; 1940 1941 Tcl_MutexLock(&threadMutex); 1942 1943 /* 1944 * First walk; find out how many threads are registered. 1945 * We may avoid this and gain some speed by maintaining 1946 * the counter of allocated structs in the threadList. 1947 */ 1948 1949 for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) { 1950 count++; 1951 } 1952 1953 if (count == 0) { 1954 return 0; 1955 } 1956 1957 /* 1958 * Allocate storage for passing thread id's to caller 1959 */ 1960 1961 *thrIdArray = (Tcl_ThreadId*)Tcl_Alloc(count * sizeof(Tcl_ThreadId)); 1962 1963 /* 1964 * Second walk; fill-in the array with thread ID's 1965 */ 1966 1967 for (tsdPtr = threadList, ii = 0; tsdPtr; tsdPtr = tsdPtr->nextPtr, ii++) { 1968 (*thrIdArray)[ii] = tsdPtr->threadId; 1969 } 1970 1971 Tcl_MutexUnlock(&threadMutex); 1972 1973 return count; 1974} 1975 1976/* 1977 *---------------------------------------------------------------------- 1978 * 1979 * ThreadExists -- 1980 * 1981 * Test wether a thread given by it's id is known to us. 1982 * 1983 * Results: 1984 * Pointer to thread specific data structure or 1985 * NULL if no thread with given ID found 1986 * 1987 * Side effects: 1988 * None. 1989 * 1990 *---------------------------------------------------------------------- 1991 */ 1992 1993static int 1994ThreadExists(thrId) 1995 Tcl_ThreadId thrId; 1996{ 1997 ThreadSpecificData *tsdPtr; 1998 1999 Tcl_MutexLock(&threadMutex); 2000 tsdPtr = ThreadExistsInner(thrId); 2001 Tcl_MutexUnlock(&threadMutex); 2002 2003 return tsdPtr != NULL; 2004} 2005 2006/* 2007 *---------------------------------------------------------------------- 2008 * 2009 * ThreadExistsInner -- 2010 * 2011 * Test wether a thread given by it's id is known to us. Assumes 2012 * caller holds the thread mutex. 2013 * 2014 * Results: 2015 * Pointer to thread specific data structure or 2016 * NULL if no thread with given ID found 2017 * 2018 * Side effects: 2019 * None. 2020 * 2021 *---------------------------------------------------------------------- 2022 */ 2023 2024static ThreadSpecificData * 2025ThreadExistsInner(thrId) 2026 Tcl_ThreadId thrId; /* Thread id to look for. */ 2027{ 2028 ThreadSpecificData *tsdPtr; 2029 2030 for (tsdPtr = threadList; tsdPtr; tsdPtr = tsdPtr->nextPtr) { 2031 if (tsdPtr->threadId == thrId) { 2032 return tsdPtr; 2033 } 2034 } 2035 2036 return NULL; 2037} 2038 2039/* 2040 *---------------------------------------------------------------------- 2041 * 2042 * ThreadJoin -- 2043 * 2044 * Wait for the exit of a different thread. 2045 * 2046 * Results: 2047 * A standard Tcl result. 2048 * 2049 * Side effects: 2050 * The status of the exiting thread is left in the interp result 2051 * area, but only in the case of success. 2052 * 2053 *---------------------------------------------------------------------- 2054 */ 2055 2056static int 2057ThreadJoin(interp, thrId) 2058 Tcl_Interp *interp; /* The current interpreter. */ 2059 Tcl_ThreadId thrId; /* Thread ID of other interpreter. */ 2060{ 2061 int ret, state; 2062 2063 ret = Tcl_JoinThread(thrId, &state); 2064 2065 if (ret == TCL_OK) { 2066 Tcl_SetIntObj(Tcl_GetObjResult (interp), state); 2067 } else { 2068 char thrHandle[THREAD_HNDLMAXLEN]; 2069 ThreadGetHandle(thrId, thrHandle); 2070 Tcl_AppendResult(interp, "cannot join thread ", thrHandle, NULL); 2071 } 2072 2073 return ret; 2074} 2075 2076/* 2077 *---------------------------------------------------------------------- 2078 * 2079 * ThreadTransfer -- 2080 * 2081 * Transfers the specified channel which must not be shared and has 2082 * to be registered in the given interp from that location to the 2083 * main interp of the specified thread. 2084 * 2085 * Thanks to Anreas Kupries for the initial implementation. 2086 * 2087 * Results: 2088 * A standard Tcl result. 2089 * 2090 * Side effects: 2091 * The thread-global lists of all known channels of both threads 2092 * involved (specified and current) are modified. The channel is 2093 * moved, all event handling for the channel is killed. 2094 * 2095 *---------------------------------------------------------------------- 2096 */ 2097 2098static int 2099ThreadTransfer(interp, thrId, chan) 2100 Tcl_Interp *interp; /* The current interpreter. */ 2101 Tcl_ThreadId thrId; /* Thread Id of other interpreter. */ 2102 Tcl_Channel chan; /* The channel to transfer */ 2103{ 2104 /* Steps to perform for the transfer: 2105 * 2106 * i. Sanity checks: chan has to registered in interp, must not be 2107 * shared. This automatically excludes the special channels for 2108 * stdin, stdout and stderr! 2109 * ii. Clear event handling. 2110 * iii. Bump reference counter up to prevent destruction during the 2111 * following unregister, then unregister the channel from the 2112 * interp. Remove it from the thread-global list of all channels 2113 * too. 2114 * iv. Wrap the channel into an event and send that to the other 2115 * thread, then wait for the other thread to process our message. 2116 * v. The event procedure called by the other thread is 2117 * 'TransferEventProc'. It links the channel into the 2118 * thread-global list of channels for that thread, registers it 2119 * in the main interp of the other thread, removes the artificial 2120 * reference, at last notifies this thread of the sucessful 2121 * transfer. This allows this thread then to proceed. 2122 */ 2123 2124 TransferEvent *evPtr; 2125 TransferResult *resultPtr; 2126 2127 if (!Tcl_IsChannelRegistered(interp, chan)) { 2128 Tcl_SetResult(interp, "channel is not registered here", TCL_STATIC); 2129 } 2130 if (Tcl_IsChannelShared(chan)) { 2131 Tcl_SetResult(interp, "channel is shared", TCL_STATIC); 2132 return TCL_ERROR; 2133 } 2134 2135 /* 2136 * Short circut transfers to ourself. Nothing to do. 2137 */ 2138 2139 if (thrId == Tcl_GetCurrentThread()) { 2140 return TCL_OK; 2141 } 2142 2143 Tcl_MutexLock(&threadMutex); 2144 2145 /* 2146 * Verify the thread exists. 2147 */ 2148 2149 if (ThreadExistsInner(thrId) == NULL) { 2150 Tcl_MutexUnlock(&threadMutex); 2151 ErrorNoSuchThread(interp, thrId); 2152 return TCL_ERROR; 2153 } 2154 2155 /* 2156 * Cut the channel out of the interp/thread 2157 */ 2158 2159 ThreadCutChannel(interp, chan); 2160 2161 /* 2162 * Wrap it into an event. 2163 */ 2164 2165 resultPtr = (TransferResult*)Tcl_Alloc(sizeof(TransferResult)); 2166 evPtr = (TransferEvent *)Tcl_Alloc(sizeof(TransferEvent)); 2167 2168 evPtr->chan = chan; 2169 evPtr->event.proc = TransferEventProc; 2170 evPtr->resultPtr = resultPtr; 2171 2172 /* 2173 * Initialize the result fields. 2174 */ 2175 2176 resultPtr->done = (Tcl_Condition) NULL; 2177 resultPtr->resultCode = -1; 2178 resultPtr->resultMsg = (char *) NULL; 2179 2180 /* 2181 * Maintain the cleanup list. 2182 */ 2183 2184 resultPtr->srcThreadId = Tcl_GetCurrentThread(); 2185 resultPtr->dstThreadId = thrId; 2186 resultPtr->eventPtr = evPtr; 2187 2188 SpliceIn(resultPtr, transferList); 2189 2190 /* 2191 * Queue the event and poke the other thread's notifier. 2192 */ 2193 2194 Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); 2195 Tcl_ThreadAlert(thrId); 2196 2197 /* 2198 * (*) Block until the other thread has either processed the transfer 2199 * or rejected it. 2200 */ 2201 2202 while (resultPtr->resultCode < 0) { 2203 Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); 2204 } 2205 2206 /* 2207 * Unlink result from the result list. 2208 */ 2209 2210 SpliceOut(resultPtr, transferList); 2211 2212 resultPtr->eventPtr = NULL; 2213 resultPtr->nextPtr = NULL; 2214 resultPtr->prevPtr = NULL; 2215 2216 Tcl_MutexUnlock(&threadMutex); 2217 2218 Tcl_ConditionFinalize(&resultPtr->done); 2219 2220 /* 2221 * Process the result now. 2222 */ 2223 2224 if (resultPtr->resultCode != TCL_OK) { 2225 2226 /* 2227 * Transfer failed, restore old state of channel with respect 2228 * to current thread and specified interp. 2229 */ 2230 2231 Tcl_SpliceChannel(chan); 2232 Tcl_RegisterChannel(interp, chan); 2233 Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); 2234 Tcl_AppendResult(interp, "transfer failed: ", NULL); 2235 2236 if (resultPtr->resultMsg) { 2237 Tcl_AppendResult(interp, resultPtr->resultMsg, NULL); 2238 Tcl_Free(resultPtr->resultMsg); 2239 } else { 2240 Tcl_AppendResult(interp, "for reasons unknown", NULL); 2241 } 2242 2243 return TCL_ERROR; 2244 } 2245 2246 if (resultPtr->resultMsg) { 2247 Tcl_Free(resultPtr->resultMsg); 2248 } 2249 2250 return TCL_OK; 2251} 2252 2253/* 2254 *---------------------------------------------------------------------- 2255 * 2256 * ThreadDetach -- 2257 * 2258 * Detaches the specified channel which must not be shared and has 2259 * to be registered in the given interp. The detached channel is 2260 * left in the transfer list until some other thread attaches it 2261 + by calling the "thread::attach" command. 2262 * 2263 * Results: 2264 * A standard Tcl result. 2265 * 2266 * Side effects: 2267 * The thread-global lists of all known channels (transferList) 2268 * is modified. All event handling for the channel is killed. 2269 * 2270 *---------------------------------------------------------------------- 2271 */ 2272 2273static int 2274ThreadDetach(interp, chan) 2275 Tcl_Interp *interp; /* The current interpreter. */ 2276 Tcl_Channel chan; /* The channel to detach */ 2277{ 2278 TransferEvent *evPtr; 2279 TransferResult *resultPtr; 2280 2281 if (!Tcl_IsChannelRegistered(interp, chan)) { 2282 Tcl_SetResult(interp, "channel is not registered here", TCL_STATIC); 2283 } 2284 if (Tcl_IsChannelShared(chan)) { 2285 Tcl_SetResult(interp, "channel is shared", TCL_STATIC); 2286 return TCL_ERROR; 2287 } 2288 2289 /* 2290 * Cut the channel out of the interp/thread 2291 */ 2292 2293 ThreadCutChannel(interp, chan); 2294 2295 /* 2296 * Wrap it into the list of transfered channels. We generate no 2297 * events associated with the detached channel, thus really not 2298 * needing the transfer event structure allocated here. This 2299 * is done purely to avoid having yet another wrapper. 2300 */ 2301 2302 resultPtr = (TransferResult*)Tcl_Alloc(sizeof(TransferResult)); 2303 evPtr = (TransferEvent*)Tcl_Alloc(sizeof(TransferEvent)); 2304 2305 evPtr->chan = chan; 2306 evPtr->event.proc = NULL; 2307 evPtr->resultPtr = resultPtr; 2308 2309 /* 2310 * Initialize the result fields. This is not used. 2311 */ 2312 2313 resultPtr->done = (Tcl_Condition)NULL; 2314 resultPtr->resultCode = -1; 2315 resultPtr->resultMsg = (char*)NULL; 2316 2317 /* 2318 * Maintain the cleanup list. By setting the dst/srcThreadId 2319 * to zero we signal the code in ThreadAttach that this is the 2320 * detached channel. Therefore it should not be mistaken for 2321 * some regular TransferChannel operation underway. Also, this 2322 * will prevent the code in ThreadExitProc to splice out this 2323 * record from the list when the threads are exiting. 2324 * A side effect of this is that we may have entries in this 2325 * list which may never be removed (i.e. nobody attaches the 2326 * channel later on). This will result in both Tcl channel and 2327 * memory leak. 2328 */ 2329 2330 resultPtr->srcThreadId = (Tcl_ThreadId)0; 2331 resultPtr->dstThreadId = (Tcl_ThreadId)0; 2332 resultPtr->eventPtr = evPtr; 2333 2334 Tcl_MutexLock(&threadMutex); 2335 SpliceIn(resultPtr, transferList); 2336 Tcl_MutexUnlock(&threadMutex); 2337 2338 return TCL_OK; 2339} 2340 2341/* 2342 *---------------------------------------------------------------------- 2343 * 2344 * ThreadAttach -- 2345 * 2346 * Attaches the previously detached channel into the current 2347 * interpreter. 2348 * 2349 * Results: 2350 * A standard Tcl result. 2351 * 2352 * Side effects: 2353 * The thread-global lists of all known channels (transferList) 2354 * is modified. 2355 * 2356 *---------------------------------------------------------------------- 2357 */ 2358 2359static int 2360ThreadAttach(interp, chanName) 2361 Tcl_Interp *interp; /* The current interpreter. */ 2362 char *chanName; /* The name of the channel to detach */ 2363{ 2364 int found = 0; 2365 Tcl_Channel chan = NULL; 2366 TransferResult *resPtr; 2367 2368 /* 2369 * Locate the channel to attach by looking up its name in 2370 * the list of transfered channels. Watch that we don't 2371 * hit the regular channel transfer event. 2372 */ 2373 2374 Tcl_MutexLock(&threadMutex); 2375 for (resPtr = transferList; resPtr; resPtr = resPtr->nextPtr) { 2376 chan = resPtr->eventPtr->chan; 2377 if (!strcmp(Tcl_GetChannelName(chan),chanName) 2378 && !resPtr->dstThreadId) { 2379 if (Tcl_IsChannelExisting(chanName)) { 2380 Tcl_MutexUnlock(&threadMutex); 2381 Tcl_AppendResult(interp, "channel already exists", NULL); 2382 return TCL_ERROR; 2383 } 2384 SpliceOut(resPtr, transferList); 2385 Tcl_Free((char*)resPtr->eventPtr); 2386 Tcl_Free((char*)resPtr); 2387 found = 1; 2388 break; 2389 } 2390 } 2391 Tcl_MutexUnlock(&threadMutex); 2392 2393 if (found == 0) { 2394 Tcl_AppendResult(interp, "channel not detached", NULL); 2395 return TCL_ERROR; 2396 } 2397 2398 /* 2399 * Splice channel into the current interpreter 2400 */ 2401 2402 Tcl_SpliceChannel(chan); 2403 Tcl_RegisterChannel(interp, chan); 2404 Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan); 2405 2406 return TCL_OK; 2407} 2408 2409/* 2410 *---------------------------------------------------------------------- 2411 * 2412 * ThreadSend -- 2413 * 2414 * Run the procedure in other thread. 2415 * 2416 * Results: 2417 * A standard Tcl result. 2418 * 2419 * Side effects: 2420 * None. 2421 * 2422 *---------------------------------------------------------------------- 2423 */ 2424 2425static int 2426ThreadSend(interp, thrId, send, clbk, flags) 2427 Tcl_Interp *interp; /* The current interpreter. */ 2428 Tcl_ThreadId thrId; /* Thread Id of other thread. */ 2429 ThreadSendData *send; /* Pointer to structure with work to do */ 2430 ThreadClbkData *clbk; /* Opt. callback structure (may be NULL) */ 2431 int flags; /* Wait or queue to tail */ 2432{ 2433 ThreadSpecificData *tsdPtr = NULL; /* ... of the target thread */ 2434 2435 int code; 2436 ThreadEvent *eventPtr; 2437 ThreadEventResult *resultPtr; 2438 2439 /* 2440 * Verify the thread exists and is not in the error state. 2441 * The thread is in the error state only if we've configured 2442 * it to unwind on script evaluation error and last script 2443 * evaluation resulted in error actually. 2444 */ 2445 2446 Tcl_MutexLock(&threadMutex); 2447 2448 tsdPtr = ThreadExistsInner(thrId); 2449 2450 if (tsdPtr == (ThreadSpecificData*)NULL 2451 || (tsdPtr->flags & THREAD_FLAGS_INERROR)) { 2452 int inerror = tsdPtr && (tsdPtr->flags & THREAD_FLAGS_INERROR); 2453 Tcl_MutexUnlock(&threadMutex); 2454 ThreadFreeProc((ClientData)send); 2455 if (clbk) { 2456 ThreadFreeProc((ClientData)clbk); 2457 } 2458 if (inerror) { 2459 Tcl_SetResult(interp, "thread is in error", TCL_STATIC); 2460 } else { 2461 ErrorNoSuchThread(interp, thrId); 2462 } 2463 return TCL_ERROR; 2464 } 2465 2466 /* 2467 * Short circut sends to ourself. 2468 */ 2469 2470 if (thrId == Tcl_GetCurrentThread()) { 2471 Tcl_MutexUnlock(&threadMutex); 2472 if ((flags & THREAD_SEND_WAIT)) { 2473 return (*send->execProc)(interp, (ClientData)send); 2474 } else { 2475 send->interp = interp; 2476 Tcl_Preserve((ClientData)send->interp); 2477 Tcl_DoWhenIdle((Tcl_IdleProc*)ThreadIdleProc, (ClientData)send); 2478 return TCL_OK; 2479 } 2480 } 2481 2482 /* 2483 * Create the event for target thread event queue. 2484 */ 2485 2486 eventPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent)); 2487 eventPtr->sendData = send; 2488 eventPtr->clbkData = clbk; 2489 2490 /* 2491 * Target thread about to service 2492 * another event 2493 */ 2494 2495 if (tsdPtr->maxEventsCount) { 2496 tsdPtr->eventsPending++; 2497 } 2498 2499 /* 2500 * Caller wants to be notified, so we must take care 2501 * it's interpreter stays alive until we've finished. 2502 */ 2503 2504 if (eventPtr->clbkData) { 2505 Tcl_Preserve((ClientData)eventPtr->clbkData->interp); 2506 } 2507 if ((flags & THREAD_SEND_WAIT) == 0) { 2508 resultPtr = NULL; 2509 eventPtr->resultPtr = NULL; 2510 } else { 2511 resultPtr = (ThreadEventResult*)Tcl_Alloc(sizeof(ThreadEventResult)); 2512 resultPtr->done = (Tcl_Condition)NULL; 2513 resultPtr->result = NULL; 2514 resultPtr->errorCode = NULL; 2515 resultPtr->errorInfo = NULL; 2516 resultPtr->dstThreadId = thrId; 2517 resultPtr->srcThreadId = Tcl_GetCurrentThread(); 2518 resultPtr->eventPtr = eventPtr; 2519 2520 eventPtr->resultPtr = resultPtr; 2521 2522 SpliceIn(resultPtr, resultList); 2523 } 2524 2525 /* 2526 * Queue the event and poke the other thread's notifier. 2527 */ 2528 2529 eventPtr->event.proc = ThreadEventProc; 2530 if ((flags & THREAD_SEND_HEAD)) { 2531 Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_HEAD); 2532 } else { 2533 Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)eventPtr, TCL_QUEUE_TAIL); 2534 } 2535 Tcl_ThreadAlert(thrId); 2536 2537 if ((flags & THREAD_SEND_WAIT) == 0) { 2538 /* 2539 * Might potentially spend some time here, until the 2540 * worker thread clean's up it's queue a little bit. 2541 */ 2542 while (tsdPtr->maxEventsCount && 2543 tsdPtr->eventsPending > tsdPtr->maxEventsCount) { 2544 Tcl_ConditionWait(&tsdPtr->doOneEvent, &threadMutex, NULL); 2545 } 2546 Tcl_MutexUnlock(&threadMutex); 2547 return TCL_OK; 2548 } 2549 2550 /* 2551 * Block on the result indefinitely. 2552 */ 2553 2554 Tcl_ResetResult(interp); 2555 2556 while (resultPtr->result == NULL) { 2557 Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); 2558 } 2559 2560 SpliceOut(resultPtr, resultList); 2561 2562 Tcl_MutexUnlock(&threadMutex); 2563 2564 /* 2565 * Return result to caller 2566 */ 2567 2568 if (resultPtr->code == TCL_ERROR) { 2569 if (resultPtr->errorCode) { 2570 Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL); 2571 Tcl_Free(resultPtr->errorCode); 2572 } 2573 if (resultPtr->errorInfo) { 2574 Tcl_AddErrorInfo(interp, resultPtr->errorInfo); 2575 Tcl_Free(resultPtr->errorInfo); 2576 } 2577 } 2578 2579 code = resultPtr->code; 2580 Tcl_SetObjResult(interp, Tcl_NewStringObj(resultPtr->result, -1)); 2581 2582 /* 2583 * Cleanup 2584 */ 2585 2586 Tcl_ConditionFinalize(&resultPtr->done); 2587 if (resultPtr->result != threadEmptyResult) { 2588 Tcl_Free(resultPtr->result); 2589 } 2590 Tcl_Free((char*)resultPtr); 2591 2592 return code; 2593} 2594 2595/* 2596 *---------------------------------------------------------------------- 2597 * 2598 * ThreadWait -- 2599 * 2600 * Waits for events and process them as they come, until signaled 2601 * to stop. 2602 * 2603 * Results: 2604 * TCL_OK always 2605 * 2606 * Side effects: 2607 * Deletes any thread::send or thread::transfer events that are 2608 * pending. 2609 * 2610 *---------------------------------------------------------------------- 2611 */ 2612static int 2613ThreadWait() 2614{ 2615 int canrun = 1; 2616 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 2617 2618 /* 2619 * Process events until signaled to stop. 2620 */ 2621 2622 while (canrun) { 2623 2624 /* 2625 * About to service another event. 2626 * Wake-up eventual sleepers. 2627 */ 2628 2629 if (tsdPtr->maxEventsCount) { 2630 Tcl_MutexLock(&threadMutex); 2631 tsdPtr->eventsPending--; 2632 Tcl_ConditionNotify(&tsdPtr->doOneEvent); 2633 Tcl_MutexUnlock(&threadMutex); 2634 } 2635 Tcl_DoOneEvent(TCL_ALL_EVENTS); 2636 2637 /* 2638 * Test stop condition under mutex since 2639 * some other thread may flip our flags. 2640 */ 2641 2642 Tcl_MutexLock(&threadMutex); 2643 canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0; 2644 Tcl_MutexUnlock(&threadMutex); 2645 } 2646 2647 /* 2648 * Remove from the list of active threads, so nobody can post 2649 * work to this thread, since it is just about to terminate. 2650 */ 2651 2652 ListRemove(tsdPtr); 2653 2654 /* 2655 * Now that the event processor for this thread is closing, 2656 * delete all pending thread::send and thread::transfer events. 2657 * These events are owned by us. We don't delete anyone else's 2658 * events, but ours. 2659 */ 2660 2661 Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL); 2662 2663 return TCL_OK; 2664} 2665 2666/* 2667 *---------------------------------------------------------------------- 2668 * 2669 * ThreadReserve -- 2670 * 2671 * Results: 2672 * 2673 * Side effects: 2674 * 2675 *---------------------------------------------------------------------- 2676 */ 2677 2678static int 2679ThreadReserve(interp, thrId, operation, wait) 2680 Tcl_Interp *interp; /* Current interpreter */ 2681 Tcl_ThreadId thrId; /* Target thread ID */ 2682 int operation; /* THREAD_RESERVE | THREAD_RELEASE */ 2683 int wait; /* Wait for thread to exit */ 2684{ 2685 int users, dowait = 0; 2686 ThreadEvent *evPtr; 2687 ThreadSpecificData *tsdPtr; 2688 2689 Tcl_MutexLock(&threadMutex); 2690 2691 /* 2692 * Check the given thread 2693 */ 2694 2695 if (thrId == (Tcl_ThreadId)0) { 2696 tsdPtr = TCL_TSD_INIT(&dataKey); 2697 } else { 2698 tsdPtr = ThreadExistsInner(thrId); 2699 if (tsdPtr == (ThreadSpecificData*)NULL) { 2700 Tcl_MutexUnlock(&threadMutex); 2701 ErrorNoSuchThread(interp, thrId); 2702 return TCL_ERROR; 2703 } 2704 } 2705 2706 switch (operation) { 2707 case THREAD_RESERVE: ++tsdPtr->refCount; break; 2708 case THREAD_RELEASE: --tsdPtr->refCount; dowait = wait; break; 2709 } 2710 2711 users = tsdPtr->refCount; 2712 2713 if (users <= 0) { 2714 2715 /* 2716 * We're last attached user, so tear down the *target* thread 2717 */ 2718 2719 tsdPtr->flags |= THREAD_FLAGS_STOPPED; 2720 2721 if (thrId /* Not current! */) { 2722 ThreadEventResult *resultPtr = NULL; 2723 2724 /* 2725 * Remove from the list of active threads, so nobody can post 2726 * work to this thread, since it is just about to terminate. 2727 */ 2728 2729 ListRemoveInner(tsdPtr); 2730 2731 /* 2732 * Send an dummy event, just to wake-up target thread. 2733 * It should immediately exit thereafter. We might get 2734 * stuck here for long time if user really wants to 2735 * be absolutely sure that the thread has exited. 2736 */ 2737 2738 if (dowait) { 2739 resultPtr = (ThreadEventResult*) 2740 Tcl_Alloc(sizeof(ThreadEventResult)); 2741 resultPtr->done = (Tcl_Condition)NULL; 2742 resultPtr->result = NULL; 2743 resultPtr->code = TCL_OK; 2744 resultPtr->errorCode = NULL; 2745 resultPtr->errorInfo = NULL; 2746 resultPtr->dstThreadId = thrId; 2747 resultPtr->srcThreadId = Tcl_GetCurrentThread(); 2748 SpliceIn(resultPtr, resultList); 2749 } 2750 2751 evPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent)); 2752 evPtr->event.proc = ThreadEventProc; 2753 evPtr->sendData = NULL; 2754 evPtr->clbkData = NULL; 2755 evPtr->resultPtr = resultPtr; 2756 2757 Tcl_ThreadQueueEvent(thrId, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); 2758 Tcl_ThreadAlert(thrId); 2759 2760 if (dowait) { 2761 while (resultPtr->result == NULL) { 2762 Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL); 2763 } 2764 SpliceOut(resultPtr, resultList); 2765 Tcl_ConditionFinalize(&resultPtr->done); 2766 if (resultPtr->result != threadEmptyResult) { 2767 Tcl_Free(resultPtr->result); /* Will be ignored anyway */ 2768 } 2769 Tcl_Free((char*)resultPtr); 2770 } 2771 } 2772 } 2773 2774 Tcl_MutexUnlock(&threadMutex); 2775 Tcl_SetIntObj(Tcl_GetObjResult(interp), (users > 0) ? users : 0); 2776 2777 return TCL_OK; 2778} 2779 2780/* 2781 *---------------------------------------------------------------------- 2782 * 2783 * ThreadEventProc -- 2784 * 2785 * Handle the event in the target thread. 2786 * 2787 * Results: 2788 * Returns 1 to indicate that the event was processed. 2789 * 2790 * Side effects: 2791 * Fills out the ThreadEventResult struct. 2792 * 2793 *---------------------------------------------------------------------- 2794 */ 2795static int 2796ThreadEventProc(evPtr, mask) 2797 Tcl_Event *evPtr; /* Really ThreadEvent */ 2798 int mask; 2799{ 2800 ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey); 2801 2802 Tcl_Interp *interp = NULL; 2803 Tcl_ThreadId thrId = Tcl_GetCurrentThread(); 2804 ThreadEvent *eventPtr = (ThreadEvent*)evPtr; 2805 ThreadSendData *sendPtr = eventPtr->sendData; 2806 ThreadClbkData *clbkPtr = eventPtr->clbkData; 2807 ThreadEventResult* resultPtr = eventPtr->resultPtr; 2808 2809 int code = TCL_ERROR; /* Pessimistic assumption */ 2810 2811 /* 2812 * See wether user has any preferences about which interpreter 2813 * to use for running this job. The job structure might indentify 2814 * one. If not, just use the thread's main interpreter which is 2815 * stored in the thread specific data structure. 2816 * Note that later on we might discover that we're running the 2817 * aync callback script. In this case, interpreter will be 2818 * changed to one given in the callback. 2819 */ 2820 2821 interp = (sendPtr && sendPtr->interp) ? sendPtr->interp : tsdPtr->interp; 2822 2823 if (interp != NULL) { 2824 if (clbkPtr && clbkPtr->threadId == thrId) { 2825 /* Watch: this thread evaluates it's own callback. */ 2826 interp = clbkPtr->interp; 2827 } else { 2828 Tcl_Preserve((ClientData)interp); 2829 } 2830 2831 Tcl_ResetResult(interp); 2832 2833 if (sendPtr) { 2834 Tcl_CreateThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr); 2835 if (clbkPtr) { 2836 Tcl_CreateThreadExitHandler(ThreadFreeProc, 2837 (ClientData)clbkPtr); 2838 } 2839 code = (*sendPtr->execProc)(interp, (ClientData)sendPtr); 2840 Tcl_DeleteThreadExitHandler(ThreadFreeProc, (ClientData)sendPtr); 2841 if (clbkPtr) { 2842 Tcl_DeleteThreadExitHandler(ThreadFreeProc, 2843 (ClientData)clbkPtr); 2844 } 2845 } else { 2846 code = TCL_OK; 2847 } 2848 } 2849 2850 ThreadFreeProc((ClientData)sendPtr); 2851 2852 if (resultPtr) { 2853 2854 /* 2855 * Report job result synchronously to waiting caller 2856 */ 2857 2858 Tcl_MutexLock(&threadMutex); 2859 ThreadSetResult(interp, code, resultPtr); 2860 Tcl_ConditionNotify(&resultPtr->done); 2861 Tcl_MutexUnlock(&threadMutex); 2862 2863 } else if (clbkPtr && clbkPtr->threadId != thrId) { 2864 2865 ThreadSendData *tmpPtr = (ThreadSendData*)clbkPtr; 2866 2867 /* 2868 * Route the callback back to it's originator. 2869 * Do not wait for the result. 2870 */ 2871 2872 if (code == TCL_ERROR) { 2873 ThreadErrorProc(interp); 2874 } 2875 2876 ThreadSetResult(interp, code, &clbkPtr->result); 2877 ThreadSend(interp, clbkPtr->threadId, tmpPtr, NULL, 0); 2878 2879 } else if (code == TCL_ERROR) { 2880 /* 2881 * Only pass errors onto the registered error handler 2882 * when we don't have a result target for this event. 2883 */ 2884 ThreadErrorProc(interp); 2885 } 2886 2887 if (interp != NULL) { 2888 Tcl_Release((ClientData)interp); 2889 } 2890 2891 /* 2892 * Mark unwind scenario for this thread if the script resulted 2893 * in error condition and thread has been marked to unwind. 2894 * This will cause thread to disappear from the list of active 2895 * threads, clean-up its event queue and exit. 2896 */ 2897 2898 if (code != TCL_OK) { 2899 Tcl_MutexLock(&threadMutex); 2900 if (tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR) { 2901 tsdPtr->flags |= THREAD_FLAGS_INERROR; 2902 if (tsdPtr->refCount == 0) { 2903 tsdPtr->flags |= THREAD_FLAGS_STOPPED; 2904 } 2905 } 2906 Tcl_MutexUnlock(&threadMutex); 2907 } 2908 2909 return 1; 2910} 2911 2912/* 2913 *---------------------------------------------------------------------- 2914 * 2915 * ThreadSetResult -- 2916 * 2917 * Results: 2918 * 2919 * Side effects: 2920 * 2921 *---------------------------------------------------------------------- 2922 */ 2923 2924static void 2925ThreadSetResult(interp, code, resultPtr) 2926 Tcl_Interp *interp; 2927 int code; 2928 ThreadEventResult *resultPtr; 2929{ 2930 int reslen; 2931 const char *errorCode, *errorInfo, *result; 2932 2933 if (interp == NULL) { 2934 code = TCL_ERROR; 2935 errorInfo = ""; 2936 errorCode = "THREAD"; 2937 result = "no target interp!"; 2938 reslen = strlen(result); 2939 resultPtr->result = (reslen) ? 2940 strcpy(Tcl_Alloc(1+reslen), result) : threadEmptyResult; 2941 } else { 2942 result = Tcl_GetStringResult(interp); 2943 reslen = strlen(result); 2944 resultPtr->result = (reslen) ? 2945 strcpy(Tcl_Alloc(1+reslen), result) : threadEmptyResult; 2946 if (code == TCL_ERROR) { 2947 errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); 2948 errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); 2949 } else { 2950 errorCode = NULL; 2951 errorInfo = NULL; 2952 } 2953 } 2954 2955 resultPtr->code = code; 2956 2957 if (errorCode != NULL) { 2958 resultPtr->errorCode = Tcl_Alloc(1+strlen(errorCode)); 2959 strcpy(resultPtr->errorCode, errorCode); 2960 } else { 2961 resultPtr->errorCode = NULL; 2962 } 2963 if (errorInfo != NULL) { 2964 resultPtr->errorInfo = Tcl_Alloc(1+strlen(errorInfo)); 2965 strcpy(resultPtr->errorInfo, errorInfo); 2966 } else { 2967 resultPtr->errorInfo = NULL; 2968 } 2969} 2970 2971/* 2972 *---------------------------------------------------------------------- 2973 * 2974 * ThreadGetOption -- 2975 * 2976 * Results: 2977 * 2978 * Side effects: 2979 * 2980 *---------------------------------------------------------------------- 2981 */ 2982 2983static int 2984ThreadGetOption(interp, thrId, option, dsPtr) 2985 Tcl_Interp *interp; 2986 Tcl_ThreadId thrId; 2987 char *option; 2988 Tcl_DString *dsPtr; 2989{ 2990 int len; 2991 ThreadSpecificData *tsdPtr = NULL; 2992 2993 /* 2994 * If the optionName is NULL it means that we want 2995 * a list of all options and values. 2996 */ 2997 2998 len = (option == NULL) ? 0 : strlen(option); 2999 3000 Tcl_MutexLock(&threadMutex); 3001 3002 tsdPtr = ThreadExistsInner(thrId); 3003 3004 if (tsdPtr == (ThreadSpecificData*)NULL) { 3005 Tcl_MutexUnlock(&threadMutex); 3006 ErrorNoSuchThread(interp, thrId); 3007 return TCL_ERROR; 3008 } 3009 3010 if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'v' 3011 && !strncmp(option,"-eventmark", len))) { 3012 char buf[16]; 3013 if (len == 0) { 3014 Tcl_DStringAppendElement(dsPtr, "-eventmark"); 3015 } 3016 sprintf(buf, "%d", tsdPtr->maxEventsCount); 3017 Tcl_DStringAppendElement(dsPtr, buf); 3018 if (len != 0) { 3019 Tcl_MutexUnlock(&threadMutex); 3020 return TCL_OK; 3021 } 3022 } 3023 3024 if (len == 0 || (len > 2 && option[1] == 'u' 3025 && !strncmp(option,"-unwindonerror", len))) { 3026 int flag = tsdPtr->flags & THREAD_FLAGS_UNWINDONERROR; 3027 if (len == 0) { 3028 Tcl_DStringAppendElement(dsPtr, "-unwindonerror"); 3029 } 3030 Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0"); 3031 if (len != 0) { 3032 Tcl_MutexUnlock(&threadMutex); 3033 return TCL_OK; 3034 } 3035 } 3036 3037 if (len == 0 || (len > 3 && option[1] == 'e' && option[2] == 'r' 3038 && !strncmp(option,"-errorstate", len))) { 3039 int flag = tsdPtr->flags & THREAD_FLAGS_INERROR; 3040 if (len == 0) { 3041 Tcl_DStringAppendElement(dsPtr, "-errorstate"); 3042 } 3043 Tcl_DStringAppendElement(dsPtr, flag ? "1" : "0"); 3044 if (len != 0) { 3045 Tcl_MutexUnlock(&threadMutex); 3046 return TCL_OK; 3047 } 3048 } 3049 3050 if (len != 0) { 3051 Tcl_AppendResult(interp, "bad option \"", option, 3052 "\", should be one of -eventmark, " 3053 "-unwindonerror or -errorstate", NULL); 3054 Tcl_MutexUnlock(&threadMutex); 3055 return TCL_ERROR; 3056 } 3057 3058 Tcl_MutexUnlock(&threadMutex); 3059 3060 return TCL_OK; 3061} 3062 3063/* 3064 *---------------------------------------------------------------------- 3065 * 3066 * ThreadSetOption -- 3067 * 3068 * Results: 3069 * 3070 * Side effects: 3071 * 3072 *---------------------------------------------------------------------- 3073 */ 3074 3075static int 3076ThreadSetOption(interp, thrId, option, value) 3077 Tcl_Interp *interp; 3078 Tcl_ThreadId thrId; 3079 char *option; 3080 char *value; 3081{ 3082 int len = strlen(option); 3083 ThreadSpecificData *tsdPtr = NULL; 3084 3085 Tcl_MutexLock(&threadMutex); 3086 3087 tsdPtr = ThreadExistsInner(thrId); 3088 3089 if (tsdPtr == (ThreadSpecificData*)NULL) { 3090 Tcl_MutexUnlock(&threadMutex); 3091 ErrorNoSuchThread(interp, thrId); 3092 return TCL_ERROR; 3093 } 3094 if (len > 3 && option[1] == 'e' && option[2] == 'v' 3095 && !strncmp(option,"-eventmark", len)) { 3096 if (sscanf(value, "%d", &tsdPtr->maxEventsCount) != 1) { 3097 Tcl_AppendResult(interp, "expected integer but got \"", 3098 value, "\"", NULL); 3099 Tcl_MutexUnlock(&threadMutex); 3100 return TCL_ERROR; 3101 } 3102 } else if (len > 2 && option[1] == 'u' 3103 && !strncmp(option,"-unwindonerror", len)) { 3104 int flag = 0; 3105 if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) { 3106 Tcl_MutexUnlock(&threadMutex); 3107 return TCL_ERROR; 3108 } 3109 if (flag) { 3110 tsdPtr->flags |= THREAD_FLAGS_UNWINDONERROR; 3111 } else { 3112 tsdPtr->flags &= ~THREAD_FLAGS_UNWINDONERROR; 3113 } 3114 } else if (len > 3 && option[1] == 'e' && option[2] == 'r' 3115 && !strncmp(option,"-errorstate", len)) { 3116 int flag = 0; 3117 if (Tcl_GetBoolean(interp, value, &flag) != TCL_OK) { 3118 Tcl_MutexUnlock(&threadMutex); 3119 return TCL_ERROR; 3120 } 3121 if (flag) { 3122 tsdPtr->flags |= THREAD_FLAGS_INERROR; 3123 } else { 3124 tsdPtr->flags &= ~THREAD_FLAGS_INERROR; 3125 } 3126 } 3127 3128 Tcl_MutexUnlock(&threadMutex); 3129 3130 return TCL_OK; 3131} 3132 3133/* 3134 *---------------------------------------------------------------------- 3135 * 3136 * ThreadIdleProc -- 3137 * 3138 * Results: 3139 * 3140 * Side effects. 3141 * 3142 *---------------------------------------------------------------------- 3143 */ 3144 3145static void 3146ThreadIdleProc(clientData) 3147 ClientData clientData; 3148{ 3149 int ret; 3150 ThreadSendData *sendPtr = (ThreadSendData*)clientData; 3151 3152 ret = (*sendPtr->execProc)(sendPtr->interp, (ClientData)sendPtr); 3153 if (ret != TCL_OK) { 3154 ThreadErrorProc(sendPtr->interp); 3155 } 3156 3157 Tcl_Release((ClientData)sendPtr->interp); 3158} 3159 3160/* 3161 *---------------------------------------------------------------------- 3162 * 3163 * TransferEventProc -- 3164 * 3165 * Handle a transfer event in the target thread. 3166 * 3167 * Results: 3168 * Returns 1 to indicate that the event was processed. 3169 * 3170 * Side effects: 3171 * Fills out the TransferResult struct. 3172 * 3173 *---------------------------------------------------------------------- 3174 */ 3175 3176static int 3177TransferEventProc(evPtr, mask) 3178 Tcl_Event *evPtr; /* Really ThreadEvent */ 3179 int mask; 3180{ 3181 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 3182 TransferEvent *eventPtr = (TransferEvent *)evPtr; 3183 TransferResult *resultPtr = eventPtr->resultPtr; 3184 Tcl_Interp *interp = tsdPtr->interp; 3185 int code; 3186 const char* msg = NULL; 3187 3188 if (interp == NULL) { 3189 /* 3190 * Reject transfer in case of a missing target. 3191 */ 3192 code = TCL_ERROR; 3193 msg = "target interp missing"; 3194 } else { 3195 /* 3196 * Add channel to current thread and interp. 3197 * See ThreadTransfer for more explanations. 3198 */ 3199 if (Tcl_IsChannelExisting(Tcl_GetChannelName(eventPtr->chan))) { 3200 /* 3201 * Reject transfer. Channel of same name already exists in target. 3202 */ 3203 code = TCL_ERROR; 3204 msg = "channel already exists in target"; 3205 } else { 3206 Tcl_SpliceChannel(eventPtr->chan); 3207 Tcl_RegisterChannel(interp, eventPtr->chan); 3208 Tcl_UnregisterChannel((Tcl_Interp *) NULL, eventPtr->chan); 3209 code = TCL_OK; /* Return success. */ 3210 } 3211 } 3212 if (resultPtr) { 3213 Tcl_MutexLock(&threadMutex); 3214 resultPtr->resultCode = code; 3215 if (msg != NULL) { 3216 resultPtr->resultMsg = (char*)Tcl_Alloc(1+strlen (msg)); 3217 strcpy (resultPtr->resultMsg, msg); 3218 } 3219 Tcl_ConditionNotify(&resultPtr->done); 3220 Tcl_MutexUnlock(&threadMutex); 3221 } 3222 3223 return 1; 3224} 3225 3226/* 3227 *---------------------------------------------------------------------- 3228 * 3229 * ThreadFreeProc -- 3230 * 3231 * Called when we are exiting and memory needs to be freed. 3232 * 3233 * Results: 3234 * None. 3235 * 3236 * Side effects: 3237 * Clears up mem specified in ClientData 3238 * 3239 *---------------------------------------------------------------------- 3240 */ 3241static void 3242ThreadFreeProc(clientData) 3243 ClientData clientData; 3244{ 3245 /* 3246 * This will free send and/or callback structures 3247 * since both are the same in the beginning. 3248 */ 3249 3250 ThreadSendData *anyPtr = (ThreadSendData*)clientData; 3251 3252 if (anyPtr) { 3253 if (anyPtr->clientData) { 3254 (*anyPtr->freeProc)(anyPtr->clientData); 3255 } 3256 Tcl_Free((char*)anyPtr); 3257 } 3258} 3259 3260/* 3261 *---------------------------------------------------------------------- 3262 * 3263 * ThreadDeleteEvent -- 3264 * 3265 * This is called from the ThreadExitProc to delete memory related 3266 * to events that we put on the queue. 3267 * 3268 * Results: 3269 * 1 it was our event and we want it removed, 0 otherwise. 3270 * 3271 * Side effects: 3272 * It cleans up our events in the event queue for this thread. 3273 * 3274 *---------------------------------------------------------------------- 3275 */ 3276static int 3277ThreadDeleteEvent(eventPtr, clientData) 3278 Tcl_Event *eventPtr; /* Really ThreadEvent */ 3279 ClientData clientData; /* dummy */ 3280{ 3281 if (eventPtr->proc == ThreadEventProc) { 3282 /* 3283 * Regular script event. Just dispose memory 3284 */ 3285 ThreadEvent *evPtr = (ThreadEvent*)eventPtr; 3286 if (evPtr->sendData) { 3287 ThreadFreeProc((ClientData)evPtr->sendData); 3288 } 3289 if (evPtr->clbkData) { 3290 ThreadFreeProc((ClientData)evPtr->clbkData); 3291 } 3292 return 1; 3293 } 3294 if ((eventPtr->proc == TransferEventProc)) { 3295 /* 3296 * A channel is in flight toward the thread just exiting. 3297 * Pass it back to the originator, if possible. 3298 * Else kill it. 3299 */ 3300 TransferEvent* evPtr = (TransferEvent *) eventPtr; 3301 3302 if (evPtr->resultPtr == (TransferResult *) NULL) { 3303 /* No thread to pass the channel back to. Kill it. 3304 * This requires to splice it temporarily into our channel 3305 * list and then forcing the ref.counter down to the real 3306 * value of zero. This destroys the channel. 3307 */ 3308 3309 Tcl_SpliceChannel(evPtr->chan); 3310 Tcl_UnregisterChannel((Tcl_Interp *) NULL, evPtr->chan); 3311 return 1; 3312 } 3313 3314 /* Our caller (ThreadExitProc) will pass the channel back. 3315 */ 3316 3317 return 1; 3318 } 3319 3320 /* 3321 * If it was NULL, we were in the middle of servicing the event 3322 * and it should be removed 3323 */ 3324 3325 return (eventPtr->proc == NULL); 3326} 3327 3328/* 3329 *---------------------------------------------------------------------- 3330 * 3331 * ThreadExitProc -- 3332 * 3333 * This is called when the thread exits. 3334 * 3335 * Results: 3336 * None. 3337 * 3338 * Side effects: 3339 * It unblocks anyone that is waiting on a send to this thread. 3340 * It cleans up any events in the event queue for this thread. 3341 * 3342 *---------------------------------------------------------------------- 3343 */ 3344static void 3345ThreadExitProc(clientData) 3346 ClientData clientData; 3347{ 3348 char *threadEvalScript = (char*)clientData; 3349 const char *diemsg = "target thread died"; 3350 ThreadEventResult *resultPtr, *nextPtr; 3351 Tcl_ThreadId self = Tcl_GetCurrentThread(); 3352 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 3353 3354 TransferResult *tResultPtr, *tNextPtr; 3355 3356 if (threadEvalScript && threadEvalScript != threadEmptyResult) { 3357 Tcl_Free((char*)threadEvalScript); 3358 } 3359 3360 Tcl_MutexLock(&threadMutex); 3361 3362 /* 3363 * AOLserver and threadpool threads get started/stopped 3364 * out of the control of this interface so this is 3365 * the first chance to split them out of the thread list. 3366 */ 3367 3368 ListRemoveInner(tsdPtr); 3369 3370 /* 3371 * Delete events posted to our queue while we were running. 3372 * For threads exiting from the thread::wait command, this 3373 * has already been done in ThreadWait() function. 3374 * For one-shot threads, having something here is a very 3375 * strange condition. It *may* happen if somebody posts us 3376 * an event while we were in the middle of processing some 3377 * lengthly user script. It is unlikely to happen, though. 3378 */ 3379 3380 Tcl_DeleteEvents((Tcl_EventDeleteProc*)ThreadDeleteEvent, NULL); 3381 3382 /* 3383 * Walk the list of threads waiting for result from us 3384 * and inform them that we're about to exit. 3385 */ 3386 3387 for (resultPtr = resultList; resultPtr; resultPtr = nextPtr) { 3388 nextPtr = resultPtr->nextPtr; 3389 if (resultPtr->srcThreadId == self) { 3390 3391 /* 3392 * We are going away. By freeing up the result we signal 3393 * to the other thread we don't care about the result. 3394 */ 3395 3396 SpliceOut(resultPtr, resultList); 3397 Tcl_Free((char*)resultPtr); 3398 3399 } else if (resultPtr->dstThreadId == self) { 3400 3401 /* 3402 * Dang. The target is going away. Unblock the caller. 3403 * The result string must be dynamically allocated 3404 * because the main thread is going to call free on it. 3405 */ 3406 3407 resultPtr->result = strcpy(Tcl_Alloc(1+strlen(diemsg)), diemsg); 3408 resultPtr->code = TCL_ERROR; 3409 resultPtr->errorCode = resultPtr->errorInfo = NULL; 3410 Tcl_ConditionNotify(&resultPtr->done); 3411 } 3412 } 3413 for (tResultPtr = transferList; tResultPtr; tResultPtr = tNextPtr) { 3414 tNextPtr = tResultPtr->nextPtr; 3415 if (tResultPtr->srcThreadId == self) { 3416 /* 3417 * We are going away. By freeing up the result we signal 3418 * to the other thread we don't care about the result. 3419 * 3420 * This should not happen, as this thread should be in 3421 * ThreadTransfer at location (*). 3422 */ 3423 3424 SpliceOut(tResultPtr, transferList); 3425 Tcl_Free((char*)tResultPtr); 3426 3427 } else if (tResultPtr->dstThreadId == self) { 3428 /* 3429 * Dang. The target is going away. Unblock the caller. 3430 * The result string must be dynamically allocated 3431 * because the main thread is going to call free on it. 3432 */ 3433 3434 tResultPtr->resultMsg = strcpy(Tcl_Alloc(1+strlen(diemsg)), 3435 diemsg); 3436 tResultPtr->resultCode = TCL_ERROR; 3437 Tcl_ConditionNotify(&tResultPtr->done); 3438 } 3439 } 3440 Tcl_MutexUnlock(&threadMutex); 3441} 3442 3443/* 3444 *---------------------------------------------------------------------- 3445 * 3446 * ThreadGetHandle -- 3447 * 3448 * Construct the handle of the thread which is suitable 3449 * to pass to Tcl. 3450 * 3451 * Results: 3452 * None. 3453 * 3454 * Side effects: 3455 * None. 3456 * 3457 *---------------------------------------------------------------------- 3458 */ 3459 3460static void 3461ThreadGetHandle(thrId, handlePtr) 3462 Tcl_ThreadId thrId; 3463 char *handlePtr; 3464{ 3465 sprintf(handlePtr, THREAD_HNDLPREFIX"%p", thrId); 3466} 3467 3468/* 3469 *---------------------------------------------------------------------- 3470 * 3471 * ThreadGetId -- 3472 * 3473 * Returns the ID of thread given it's Tcl handle. 3474 * 3475 * Results: 3476 * Thread ID. 3477 * 3478 * Side effects: 3479 * None. 3480 * 3481 *---------------------------------------------------------------------- 3482 */ 3483 3484static int 3485ThreadGetId(interp, handleObj, thrIdPtr) 3486 Tcl_Interp *interp; 3487 Tcl_Obj *handleObj; 3488 Tcl_ThreadId *thrIdPtr; 3489{ 3490 const char *thrHandle = Tcl_GetStringFromObj(handleObj, NULL); 3491 3492 if (sscanf(thrHandle, THREAD_HNDLPREFIX"%p", thrIdPtr) == 1) { 3493 return TCL_OK; 3494 } 3495 3496 Tcl_AppendResult(interp, "invalid thread handle \"", 3497 thrHandle, "\"", NULL); 3498 return TCL_ERROR; 3499} 3500 3501/* 3502 *---------------------------------------------------------------------- 3503 * 3504 * ErrorNoSuchThread -- 3505 * 3506 * Convenience function to set interpreter result when the thread 3507 * given by it's ID cannot be found. 3508 * 3509 * Results: 3510 * None. 3511 * 3512 * Side effects: 3513 * None. 3514 * 3515 *---------------------------------------------------------------------- 3516 */ 3517 3518static void 3519ErrorNoSuchThread(interp, thrId) 3520 Tcl_Interp *interp; 3521 Tcl_ThreadId thrId; 3522{ 3523 char thrHandle[THREAD_HNDLMAXLEN]; 3524 3525 ThreadGetHandle(thrId, thrHandle); 3526 Tcl_AppendResult(interp, "thread \"", thrHandle, 3527 "\" does not exist", NULL); 3528} 3529 3530/* 3531 *---------------------------------------------------------------------- 3532 * 3533 * ThreadCutChannel -- 3534 * 3535 * Dissociate a Tcl channel from the current thread/interp. 3536 * 3537 * Results: 3538 * None. 3539 * 3540 * Side effects: 3541 * Events still pending in the thread event queue and ready to fire 3542 * are not processed. 3543 * 3544 *---------------------------------------------------------------------- 3545 */ 3546 3547static void 3548ThreadCutChannel(interp, chan) 3549 Tcl_Interp *interp; 3550 Tcl_Channel chan; 3551{ 3552 const Tcl_ChannelType *chanTypePtr; 3553 Tcl_DriverWatchProc *watchProc; 3554 3555 Tcl_ClearChannelHandlers(chan); 3556 3557 chanTypePtr = Tcl_GetChannelType(chan); 3558 watchProc = Tcl_ChannelWatchProc(chanTypePtr); 3559 3560 /* 3561 * This effectively disables processing of pending 3562 * events which are ready to fire for the given 3563 * channel. If we do not do this, events will hit 3564 * the detached channel which is potentially being 3565 * owned by some other thread. This will wreck havoc 3566 * on our memory and eventually badly hurt us... 3567 */ 3568 3569 if (watchProc) { 3570 (*watchProc)(Tcl_GetChannelInstanceData(chan), 0); 3571 } 3572 3573 /* 3574 * Artificially bump the channel reference count 3575 * which protects us from channel being closed 3576 * during the Tcl_UnregisterChannel(). 3577 */ 3578 3579 Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); 3580 Tcl_UnregisterChannel(interp, chan); 3581 3582 Tcl_CutChannel(chan); 3583} 3584 3585/* EOF $RCSfile: threadCmd.c,v $ */ 3586 3587/* Emacs Setup Variables */ 3588/* Local Variables: */ 3589/* mode: C */ 3590/* indent-tabs-mode: nil */ 3591/* c-basic-offset: 4 */ 3592/* End: */ 3593