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