os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclThreadTest.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclThreadTest.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1029 @@
1.4 +/*
1.5 + * tclThreadTest.c --
1.6 + *
1.7 + * This file implements the testthread command. Eventually this
1.8 + * should be tclThreadCmd.c
1.9 + * Some of this code is based on work done by Richard Hipp on behalf of
1.10 + * Conservation Through Innovation, Limited, with their permission.
1.11 + *
1.12 + * Copyright (c) 1998 by Sun Microsystems, Inc.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclThreadTest.c,v 1.16.2.2 2006/09/22 14:48:52 dkf Exp $
1.18 + */
1.19 +
1.20 +#include "tclInt.h"
1.21 +
1.22 +#ifdef TCL_THREADS
1.23 +/*
1.24 + * Each thread has an single instance of the following structure. There
1.25 + * is one instance of this structure per thread even if that thread contains
1.26 + * multiple interpreters. The interpreter identified by this structure is
1.27 + * the main interpreter for the thread.
1.28 + *
1.29 + * The main interpreter is the one that will process any messages
1.30 + * received by a thread. Any thread can send messages but only the
1.31 + * main interpreter can receive them.
1.32 + */
1.33 +
1.34 +typedef struct ThreadSpecificData {
1.35 + Tcl_ThreadId threadId; /* Tcl ID for this thread */
1.36 + Tcl_Interp *interp; /* Main interpreter for this thread */
1.37 + int flags; /* See the TP_ defines below... */
1.38 + struct ThreadSpecificData *nextPtr; /* List for "thread names" */
1.39 + struct ThreadSpecificData *prevPtr; /* List for "thread names" */
1.40 +} ThreadSpecificData;
1.41 +static Tcl_ThreadDataKey dataKey;
1.42 +
1.43 +/*
1.44 + * This list is used to list all threads that have interpreters.
1.45 + * This is protected by threadMutex.
1.46 + */
1.47 +
1.48 +static struct ThreadSpecificData *threadList;
1.49 +
1.50 +/*
1.51 + * The following bit-values are legal for the "flags" field of the
1.52 + * ThreadSpecificData structure.
1.53 + */
1.54 +#define TP_Dying 0x001 /* This thread is being cancelled */
1.55 +
1.56 +/*
1.57 + * An instance of the following structure contains all information that is
1.58 + * passed into a new thread when the thread is created using either the
1.59 + * "thread create" Tcl command or the TclCreateThread() C function.
1.60 + */
1.61 +
1.62 +typedef struct ThreadCtrl {
1.63 + char *script; /* The TCL command this thread should execute */
1.64 + int flags; /* Initial value of the "flags" field in the
1.65 + * ThreadSpecificData structure for the new thread.
1.66 + * Might contain TP_Detached or TP_TclThread. */
1.67 + Tcl_Condition condWait;
1.68 + /* This condition variable is used to synchronize
1.69 + * the parent and child threads. The child won't run
1.70 + * until it acquires threadMutex, and the parent function
1.71 + * won't complete until signaled on this condition
1.72 + * variable. */
1.73 +} ThreadCtrl;
1.74 +
1.75 +/*
1.76 + * This is the event used to send scripts to other threads.
1.77 + */
1.78 +
1.79 +typedef struct ThreadEvent {
1.80 + Tcl_Event event; /* Must be first */
1.81 + char *script; /* The script to execute. */
1.82 + struct ThreadEventResult *resultPtr;
1.83 + /* To communicate the result. This is
1.84 + * NULL if we don't care about it. */
1.85 +} ThreadEvent;
1.86 +
1.87 +typedef struct ThreadEventResult {
1.88 + Tcl_Condition done; /* Signaled when the script completes */
1.89 + int code; /* Return value of Tcl_Eval */
1.90 + char *result; /* Result from the script */
1.91 + char *errorInfo; /* Copy of errorInfo variable */
1.92 + char *errorCode; /* Copy of errorCode variable */
1.93 + Tcl_ThreadId srcThreadId; /* Id of sending thread, in case it dies */
1.94 + Tcl_ThreadId dstThreadId; /* Id of target thread, in case it dies */
1.95 + struct ThreadEvent *eventPtr; /* Back pointer */
1.96 + struct ThreadEventResult *nextPtr; /* List for cleanup */
1.97 + struct ThreadEventResult *prevPtr;
1.98 +
1.99 +} ThreadEventResult;
1.100 +
1.101 +static ThreadEventResult *resultList;
1.102 +
1.103 +/*
1.104 + * This is for simple error handling when a thread script exits badly.
1.105 + */
1.106 +
1.107 +static Tcl_ThreadId errorThreadId;
1.108 +static char *errorProcString;
1.109 +
1.110 +/*
1.111 + * Access to the list of threads and to the thread send results is
1.112 + * guarded by this mutex.
1.113 + */
1.114 +
1.115 +TCL_DECLARE_MUTEX(threadMutex)
1.116 +
1.117 +#undef TCL_STORAGE_CLASS
1.118 +#define TCL_STORAGE_CLASS DLLEXPORT
1.119 +
1.120 +EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
1.121 +EXTERN int Tcl_ThreadObjCmd _ANSI_ARGS_((ClientData clientData,
1.122 + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
1.123 +EXTERN int TclCreateThread _ANSI_ARGS_((Tcl_Interp *interp,
1.124 + char *script, int joinable));
1.125 +EXTERN int TclThreadList _ANSI_ARGS_((Tcl_Interp *interp));
1.126 +EXTERN int TclThreadSend _ANSI_ARGS_((Tcl_Interp *interp, Tcl_ThreadId id,
1.127 + char *script, int wait));
1.128 +
1.129 +#undef TCL_STORAGE_CLASS
1.130 +#define TCL_STORAGE_CLASS DLLIMPORT
1.131 +
1.132 +Tcl_ThreadCreateType NewTestThread _ANSI_ARGS_((ClientData clientData));
1.133 +static void ListRemove _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
1.134 +static void ListUpdateInner _ANSI_ARGS_((ThreadSpecificData *tsdPtr));
1.135 +static int ThreadEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int mask));
1.136 +static void ThreadErrorProc _ANSI_ARGS_((Tcl_Interp *interp));
1.137 +static void ThreadFreeProc _ANSI_ARGS_((ClientData clientData));
1.138 +static int ThreadDeleteEvent _ANSI_ARGS_((Tcl_Event *eventPtr,
1.139 + ClientData clientData));
1.140 +static void ThreadExitProc _ANSI_ARGS_((ClientData clientData));
1.141 +
1.142 +
1.143 +/*
1.144 + *----------------------------------------------------------------------
1.145 + *
1.146 + * TclThread_Init --
1.147 + *
1.148 + * Initialize the test thread command.
1.149 + *
1.150 + * Results:
1.151 + * TCL_OK if the package was properly initialized.
1.152 + *
1.153 + * Side effects:
1.154 + * Add the "testthread" command to the interp.
1.155 + *
1.156 + *----------------------------------------------------------------------
1.157 + */
1.158 +
1.159 +int
1.160 +TclThread_Init(interp)
1.161 + Tcl_Interp *interp; /* The current Tcl interpreter */
1.162 +{
1.163 +
1.164 + Tcl_CreateObjCommand(interp,"testthread", Tcl_ThreadObjCmd,
1.165 + (ClientData)NULL ,NULL);
1.166 + if (Tcl_PkgProvide(interp, "Thread", "1.0" ) != TCL_OK) {
1.167 + return TCL_ERROR;
1.168 + }
1.169 + return TCL_OK;
1.170 +}
1.171 +
1.172 +
1.173 +/*
1.174 + *----------------------------------------------------------------------
1.175 + *
1.176 + * Tcl_ThreadObjCmd --
1.177 + *
1.178 + * This procedure is invoked to process the "testthread" Tcl command.
1.179 + * See the user documentation for details on what it does.
1.180 + *
1.181 + * thread create ?-joinable? ?script?
1.182 + * thread send id ?-async? script
1.183 + * thread exit
1.184 + * thread info id
1.185 + * thread names
1.186 + * thread wait
1.187 + * thread errorproc proc
1.188 + * thread join id
1.189 + *
1.190 + * Results:
1.191 + * A standard Tcl result.
1.192 + *
1.193 + * Side effects:
1.194 + * See the user documentation.
1.195 + *
1.196 + *----------------------------------------------------------------------
1.197 + */
1.198 +
1.199 + /* ARGSUSED */
1.200 +int
1.201 +Tcl_ThreadObjCmd(dummy, interp, objc, objv)
1.202 + ClientData dummy; /* Not used. */
1.203 + Tcl_Interp *interp; /* Current interpreter. */
1.204 + int objc; /* Number of arguments. */
1.205 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.206 +{
1.207 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.208 + int option;
1.209 + static CONST char *threadOptions[] = {"create", "exit", "id", "join", "names",
1.210 + "send", "wait", "errorproc",
1.211 + (char *) NULL};
1.212 + enum options {THREAD_CREATE, THREAD_EXIT, THREAD_ID, THREAD_JOIN,
1.213 + THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC};
1.214 +
1.215 + if (objc < 2) {
1.216 + Tcl_WrongNumArgs(interp, 1, objv, "option ?args?");
1.217 + return TCL_ERROR;
1.218 + }
1.219 + if (Tcl_GetIndexFromObj(interp, objv[1], threadOptions,
1.220 + "option", 0, &option) != TCL_OK) {
1.221 + return TCL_ERROR;
1.222 + }
1.223 +
1.224 + /*
1.225 + * Make sure the initial thread is on the list before doing anything.
1.226 + */
1.227 +
1.228 + if (tsdPtr->interp == NULL) {
1.229 + Tcl_MutexLock(&threadMutex);
1.230 + tsdPtr->interp = interp;
1.231 + ListUpdateInner(tsdPtr);
1.232 + Tcl_CreateThreadExitHandler(ThreadExitProc, NULL);
1.233 + Tcl_MutexUnlock(&threadMutex);
1.234 + }
1.235 +
1.236 + switch ((enum options)option) {
1.237 + case THREAD_CREATE: {
1.238 + char *script;
1.239 + int joinable, len;
1.240 +
1.241 + if (objc == 2) {
1.242 + /* Neither joinable nor special script
1.243 + */
1.244 +
1.245 + joinable = 0;
1.246 + script = "testthread wait"; /* Just enter the event loop */
1.247 +
1.248 + } else if (objc == 3) {
1.249 + /* Possibly -joinable, then no special script,
1.250 + * no joinable, then its a script.
1.251 + */
1.252 +
1.253 + script = Tcl_GetString(objv[2]);
1.254 + len = strlen (script);
1.255 +
1.256 + if ((len > 1) &&
1.257 + (script [0] == '-') && (script [1] == 'j') &&
1.258 + (0 == strncmp (script, "-joinable", (size_t) len))) {
1.259 + joinable = 1;
1.260 + script = "testthread wait"; /* Just enter the event loop
1.261 + */
1.262 + } else {
1.263 + /* Remember the script */
1.264 + joinable = 0;
1.265 + }
1.266 + } else if (objc == 4) {
1.267 + /* Definitely a script available, but is the flag
1.268 + * -joinable ?
1.269 + */
1.270 +
1.271 + script = Tcl_GetString(objv[2]);
1.272 + len = strlen (script);
1.273 +
1.274 + joinable = ((len > 1) &&
1.275 + (script [0] == '-') && (script [1] == 'j') &&
1.276 + (0 == strncmp (script, "-joinable", (size_t) len)));
1.277 +
1.278 + script = Tcl_GetString(objv[3]);
1.279 + } else {
1.280 + Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
1.281 + return TCL_ERROR;
1.282 + }
1.283 + return TclCreateThread(interp, script, joinable);
1.284 + }
1.285 + case THREAD_EXIT: {
1.286 + if (objc > 2) {
1.287 + Tcl_WrongNumArgs(interp, 1, objv, NULL);
1.288 + return TCL_ERROR;
1.289 + }
1.290 + ListRemove(NULL);
1.291 + Tcl_ExitThread(0);
1.292 + return TCL_OK;
1.293 + }
1.294 + case THREAD_ID:
1.295 + if (objc == 2) {
1.296 + Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
1.297 + Tcl_SetObjResult(interp, idObj);
1.298 + return TCL_OK;
1.299 + } else {
1.300 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.301 + return TCL_ERROR;
1.302 + }
1.303 + case THREAD_JOIN: {
1.304 + long id;
1.305 + int result, status;
1.306 +
1.307 + if (objc != 3) {
1.308 + Tcl_WrongNumArgs(interp, 1, objv, "join id");
1.309 + return TCL_ERROR;
1.310 + }
1.311 + if (Tcl_GetLongFromObj(interp, objv[2], &id) != TCL_OK) {
1.312 + return TCL_ERROR;
1.313 + }
1.314 +
1.315 + result = Tcl_JoinThread ((Tcl_ThreadId) id, &status);
1.316 + if (result == TCL_OK) {
1.317 + Tcl_SetIntObj (Tcl_GetObjResult (interp), status);
1.318 + } else {
1.319 + char buf [20];
1.320 + sprintf (buf, "%ld", id);
1.321 + Tcl_AppendResult (interp, "cannot join thread ", buf, NULL);
1.322 + }
1.323 + return result;
1.324 + }
1.325 + case THREAD_NAMES: {
1.326 + if (objc > 2) {
1.327 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.328 + return TCL_ERROR;
1.329 + }
1.330 + return TclThreadList(interp);
1.331 + }
1.332 + case THREAD_SEND: {
1.333 + long id;
1.334 + char *script;
1.335 + int wait, arg;
1.336 +
1.337 + if ((objc != 4) && (objc != 5)) {
1.338 + Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
1.339 + return TCL_ERROR;
1.340 + }
1.341 + if (objc == 5) {
1.342 + if (strcmp("-async", Tcl_GetString(objv[2])) != 0) {
1.343 + Tcl_WrongNumArgs(interp, 1, objv, "send ?-async? id script");
1.344 + return TCL_ERROR;
1.345 + }
1.346 + wait = 0;
1.347 + arg = 3;
1.348 + } else {
1.349 + wait = 1;
1.350 + arg = 2;
1.351 + }
1.352 + if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
1.353 + return TCL_ERROR;
1.354 + }
1.355 + arg++;
1.356 + script = Tcl_GetString(objv[arg]);
1.357 + return TclThreadSend(interp, (Tcl_ThreadId) id, script, wait);
1.358 + }
1.359 + case THREAD_WAIT: {
1.360 + while (1) {
1.361 + (void) Tcl_DoOneEvent(TCL_ALL_EVENTS);
1.362 + }
1.363 + }
1.364 + case THREAD_ERRORPROC: {
1.365 + /*
1.366 + * Arrange for this proc to handle thread death errors.
1.367 + */
1.368 +
1.369 + char *proc;
1.370 + if (objc != 3) {
1.371 + Tcl_WrongNumArgs(interp, 1, objv, "errorproc proc");
1.372 + return TCL_ERROR;
1.373 + }
1.374 + Tcl_MutexLock(&threadMutex);
1.375 + errorThreadId = Tcl_GetCurrentThread();
1.376 + if (errorProcString) {
1.377 + ckfree(errorProcString);
1.378 + }
1.379 + proc = Tcl_GetString(objv[2]);
1.380 + errorProcString = ckalloc(strlen(proc)+1);
1.381 + strcpy(errorProcString, proc);
1.382 + Tcl_MutexUnlock(&threadMutex);
1.383 + return TCL_OK;
1.384 + }
1.385 + }
1.386 + return TCL_OK;
1.387 +}
1.388 +
1.389 +
1.390 +/*
1.391 + *----------------------------------------------------------------------
1.392 + *
1.393 + * TclCreateThread --
1.394 + *
1.395 + * This procedure is invoked to create a thread containing an interp to
1.396 + * run a script. This returns after the thread has started executing.
1.397 + *
1.398 + * Results:
1.399 + * A standard Tcl result, which is the thread ID.
1.400 + *
1.401 + * Side effects:
1.402 + * Create a thread.
1.403 + *
1.404 + *----------------------------------------------------------------------
1.405 + */
1.406 +
1.407 + /* ARGSUSED */
1.408 +int
1.409 +TclCreateThread(interp, script, joinable)
1.410 + Tcl_Interp *interp; /* Current interpreter. */
1.411 + char *script; /* Script to execute */
1.412 + int joinable; /* Flag, joinable thread or not */
1.413 +{
1.414 + ThreadCtrl ctrl;
1.415 + Tcl_ThreadId id;
1.416 +
1.417 + ctrl.script = script;
1.418 + ctrl.condWait = NULL;
1.419 + ctrl.flags = 0;
1.420 +
1.421 + joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
1.422 +
1.423 + Tcl_MutexLock(&threadMutex);
1.424 + if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
1.425 + TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
1.426 + Tcl_MutexUnlock(&threadMutex);
1.427 + Tcl_AppendResult(interp,"can't create a new thread",NULL);
1.428 + ckfree((void*)ctrl.script);
1.429 + return TCL_ERROR;
1.430 + }
1.431 +
1.432 + /*
1.433 + * Wait for the thread to start because it is using something on our stack!
1.434 + */
1.435 +
1.436 + Tcl_ConditionWait(&ctrl.condWait, &threadMutex, NULL);
1.437 + Tcl_MutexUnlock(&threadMutex);
1.438 + Tcl_ConditionFinalize(&ctrl.condWait);
1.439 + Tcl_SetObjResult(interp, Tcl_NewLongObj((long)id));
1.440 + return TCL_OK;
1.441 +}
1.442 +
1.443 +/*
1.444 + *------------------------------------------------------------------------
1.445 + *
1.446 + * NewTestThread --
1.447 + *
1.448 + * This routine is the "main()" for a new thread whose task is to
1.449 + * execute a single TCL script. The argument to this function is
1.450 + * a pointer to a structure that contains the text of the TCL script
1.451 + * to be executed.
1.452 + *
1.453 + * Space to hold the script field of the ThreadControl structure passed
1.454 + * in as the only argument was obtained from malloc() and must be freed
1.455 + * by this function before it exits. Space to hold the ThreadControl
1.456 + * structure itself is released by the calling function, and the
1.457 + * two condition variables in the ThreadControl structure are destroyed
1.458 + * by the calling function. The calling function will destroy the
1.459 + * ThreadControl structure and the condition variable as soon as
1.460 + * ctrlPtr->condWait is signaled, so this routine must make copies of
1.461 + * any data it might need after that point.
1.462 + *
1.463 + * Results:
1.464 + * none
1.465 + *
1.466 + * Side effects:
1.467 + * A TCL script is executed in a new thread.
1.468 + *
1.469 + *------------------------------------------------------------------------
1.470 + */
1.471 +Tcl_ThreadCreateType
1.472 +NewTestThread(clientData)
1.473 + ClientData clientData;
1.474 +{
1.475 + ThreadCtrl *ctrlPtr = (ThreadCtrl*)clientData;
1.476 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.477 + int result;
1.478 + char *threadEvalScript;
1.479 +
1.480 + /*
1.481 + * Initialize the interpreter. This should be more general.
1.482 + */
1.483 +
1.484 + tsdPtr->interp = Tcl_CreateInterp();
1.485 + result = Tcl_Init(tsdPtr->interp);
1.486 + result = TclThread_Init(tsdPtr->interp);
1.487 +
1.488 + /*
1.489 + * Update the list of threads.
1.490 + */
1.491 +
1.492 + Tcl_MutexLock(&threadMutex);
1.493 + ListUpdateInner(tsdPtr);
1.494 + /*
1.495 + * We need to keep a pointer to the alloc'ed mem of the script
1.496 + * we are eval'ing, for the case that we exit during evaluation
1.497 + */
1.498 + threadEvalScript = (char *) ckalloc(strlen(ctrlPtr->script)+1);
1.499 + strcpy(threadEvalScript, ctrlPtr->script);
1.500 +
1.501 + Tcl_CreateThreadExitHandler(ThreadExitProc, (ClientData) threadEvalScript);
1.502 +
1.503 + /*
1.504 + * Notify the parent we are alive.
1.505 + */
1.506 +
1.507 + Tcl_ConditionNotify(&ctrlPtr->condWait);
1.508 + Tcl_MutexUnlock(&threadMutex);
1.509 +
1.510 + /*
1.511 + * Run the script.
1.512 + */
1.513 +
1.514 + Tcl_Preserve((ClientData) tsdPtr->interp);
1.515 + result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
1.516 + if (result != TCL_OK) {
1.517 + ThreadErrorProc(tsdPtr->interp);
1.518 + }
1.519 +
1.520 + /*
1.521 + * Clean up.
1.522 + */
1.523 +
1.524 + ListRemove(tsdPtr);
1.525 + Tcl_Release((ClientData) tsdPtr->interp);
1.526 + Tcl_DeleteInterp(tsdPtr->interp);
1.527 + Tcl_ExitThread(result);
1.528 +
1.529 + TCL_THREAD_CREATE_RETURN;
1.530 +}
1.531 +
1.532 +/*
1.533 + *------------------------------------------------------------------------
1.534 + *
1.535 + * ThreadErrorProc --
1.536 + *
1.537 + * Send a message to the thread willing to hear about errors.
1.538 + *
1.539 + * Results:
1.540 + * none
1.541 + *
1.542 + * Side effects:
1.543 + * Send an event.
1.544 + *
1.545 + *------------------------------------------------------------------------
1.546 + */
1.547 +static void
1.548 +ThreadErrorProc(interp)
1.549 + Tcl_Interp *interp; /* Interp that failed */
1.550 +{
1.551 + Tcl_Channel errChannel;
1.552 + CONST char *errorInfo, *argv[3];
1.553 + char *script;
1.554 + char buf[TCL_DOUBLE_SPACE+1];
1.555 + sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
1.556 +
1.557 + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
1.558 + if (errorProcString == NULL) {
1.559 + errChannel = Tcl_GetStdChannel(TCL_STDERR);
1.560 + Tcl_WriteChars(errChannel, "Error from thread ", -1);
1.561 + Tcl_WriteChars(errChannel, buf, -1);
1.562 + Tcl_WriteChars(errChannel, "\n", 1);
1.563 + Tcl_WriteChars(errChannel, errorInfo, -1);
1.564 + Tcl_WriteChars(errChannel, "\n", 1);
1.565 + } else {
1.566 + argv[0] = errorProcString;
1.567 + argv[1] = buf;
1.568 + argv[2] = errorInfo;
1.569 + script = Tcl_Merge(3, argv);
1.570 + TclThreadSend(interp, errorThreadId, script, 0);
1.571 + ckfree(script);
1.572 + }
1.573 +}
1.574 +
1.575 +
1.576 +/*
1.577 + *------------------------------------------------------------------------
1.578 + *
1.579 + * ListUpdateInner --
1.580 + *
1.581 + * Add the thread local storage to the list. This assumes
1.582 + * the caller has obtained the mutex.
1.583 + *
1.584 + * Results:
1.585 + * none
1.586 + *
1.587 + * Side effects:
1.588 + * Add the thread local storage to its list.
1.589 + *
1.590 + *------------------------------------------------------------------------
1.591 + */
1.592 +static void
1.593 +ListUpdateInner(tsdPtr)
1.594 + ThreadSpecificData *tsdPtr;
1.595 +{
1.596 + if (tsdPtr == NULL) {
1.597 + tsdPtr = TCL_TSD_INIT(&dataKey);
1.598 + }
1.599 + tsdPtr->threadId = Tcl_GetCurrentThread();
1.600 + tsdPtr->nextPtr = threadList;
1.601 + if (threadList) {
1.602 + threadList->prevPtr = tsdPtr;
1.603 + }
1.604 + tsdPtr->prevPtr = NULL;
1.605 + threadList = tsdPtr;
1.606 +}
1.607 +
1.608 +/*
1.609 + *------------------------------------------------------------------------
1.610 + *
1.611 + * ListRemove --
1.612 + *
1.613 + * Remove the thread local storage from its list. This grabs the
1.614 + * mutex to protect the list.
1.615 + *
1.616 + * Results:
1.617 + * none
1.618 + *
1.619 + * Side effects:
1.620 + * Remove the thread local storage from its list.
1.621 + *
1.622 + *------------------------------------------------------------------------
1.623 + */
1.624 +static void
1.625 +ListRemove(tsdPtr)
1.626 + ThreadSpecificData *tsdPtr;
1.627 +{
1.628 + if (tsdPtr == NULL) {
1.629 + tsdPtr = TCL_TSD_INIT(&dataKey);
1.630 + }
1.631 + Tcl_MutexLock(&threadMutex);
1.632 + if (tsdPtr->prevPtr) {
1.633 + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
1.634 + } else {
1.635 + threadList = tsdPtr->nextPtr;
1.636 + }
1.637 + if (tsdPtr->nextPtr) {
1.638 + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
1.639 + }
1.640 + tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
1.641 + Tcl_MutexUnlock(&threadMutex);
1.642 +}
1.643 +
1.644 +
1.645 +/*
1.646 + *------------------------------------------------------------------------
1.647 + *
1.648 + * TclThreadList --
1.649 + *
1.650 + * Return a list of threads running Tcl interpreters.
1.651 + *
1.652 + * Results:
1.653 + * A standard Tcl result.
1.654 + *
1.655 + * Side effects:
1.656 + * None.
1.657 + *
1.658 + *------------------------------------------------------------------------
1.659 + */
1.660 +int
1.661 +TclThreadList(interp)
1.662 + Tcl_Interp *interp;
1.663 +{
1.664 + ThreadSpecificData *tsdPtr;
1.665 + Tcl_Obj *listPtr;
1.666 +
1.667 + listPtr = Tcl_NewListObj(0, NULL);
1.668 + Tcl_MutexLock(&threadMutex);
1.669 + for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
1.670 + Tcl_ListObjAppendElement(interp, listPtr,
1.671 + Tcl_NewLongObj((long)tsdPtr->threadId));
1.672 + }
1.673 + Tcl_MutexUnlock(&threadMutex);
1.674 + Tcl_SetObjResult(interp, listPtr);
1.675 + return TCL_OK;
1.676 +}
1.677 +
1.678 +
1.679 +/*
1.680 + *------------------------------------------------------------------------
1.681 + *
1.682 + * TclThreadSend --
1.683 + *
1.684 + * Send a script to another thread.
1.685 + *
1.686 + * Results:
1.687 + * A standard Tcl result.
1.688 + *
1.689 + * Side effects:
1.690 + * None.
1.691 + *
1.692 + *------------------------------------------------------------------------
1.693 + */
1.694 +int
1.695 +TclThreadSend(interp, id, script, wait)
1.696 + Tcl_Interp *interp; /* The current interpreter. */
1.697 + Tcl_ThreadId id; /* Thread Id of other interpreter. */
1.698 + char *script; /* The script to evaluate. */
1.699 + int wait; /* If 1, we block for the result. */
1.700 +{
1.701 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.702 + ThreadEvent *threadEventPtr;
1.703 + ThreadEventResult *resultPtr;
1.704 + int found, code;
1.705 + Tcl_ThreadId threadId = (Tcl_ThreadId) id;
1.706 +
1.707 + /*
1.708 + * Verify the thread exists.
1.709 + */
1.710 +
1.711 + Tcl_MutexLock(&threadMutex);
1.712 + found = 0;
1.713 + for (tsdPtr = threadList ; tsdPtr ; tsdPtr = tsdPtr->nextPtr) {
1.714 + if (tsdPtr->threadId == threadId) {
1.715 + found = 1;
1.716 + break;
1.717 + }
1.718 + }
1.719 + if (!found) {
1.720 + Tcl_MutexUnlock(&threadMutex);
1.721 + Tcl_AppendResult(interp, "invalid thread id", NULL);
1.722 + return TCL_ERROR;
1.723 + }
1.724 +
1.725 + /*
1.726 + * Short circut sends to ourself. Ought to do something with -async,
1.727 + * like run in an idle handler.
1.728 + */
1.729 +
1.730 + if (threadId == Tcl_GetCurrentThread()) {
1.731 + Tcl_MutexUnlock(&threadMutex);
1.732 + return Tcl_GlobalEval(interp, script);
1.733 + }
1.734 +
1.735 + /*
1.736 + * Create the event for its event queue.
1.737 + */
1.738 +
1.739 + threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
1.740 + threadEventPtr->script = ckalloc(strlen(script) + 1);
1.741 + strcpy(threadEventPtr->script, script);
1.742 + if (!wait) {
1.743 + resultPtr = threadEventPtr->resultPtr = NULL;
1.744 + } else {
1.745 + resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
1.746 + threadEventPtr->resultPtr = resultPtr;
1.747 +
1.748 + /*
1.749 + * Initialize the result fields.
1.750 + */
1.751 +
1.752 + resultPtr->done = NULL;
1.753 + resultPtr->code = 0;
1.754 + resultPtr->result = NULL;
1.755 + resultPtr->errorInfo = NULL;
1.756 + resultPtr->errorCode = NULL;
1.757 +
1.758 + /*
1.759 + * Maintain the cleanup list.
1.760 + */
1.761 +
1.762 + resultPtr->srcThreadId = Tcl_GetCurrentThread();
1.763 + resultPtr->dstThreadId = threadId;
1.764 + resultPtr->eventPtr = threadEventPtr;
1.765 + resultPtr->nextPtr = resultList;
1.766 + if (resultList) {
1.767 + resultList->prevPtr = resultPtr;
1.768 + }
1.769 + resultPtr->prevPtr = NULL;
1.770 + resultList = resultPtr;
1.771 + }
1.772 +
1.773 + /*
1.774 + * Queue the event and poke the other thread's notifier.
1.775 + */
1.776 +
1.777 + threadEventPtr->event.proc = ThreadEventProc;
1.778 + Tcl_ThreadQueueEvent(threadId, (Tcl_Event *)threadEventPtr,
1.779 + TCL_QUEUE_TAIL);
1.780 + Tcl_ThreadAlert(threadId);
1.781 +
1.782 + if (!wait) {
1.783 + Tcl_MutexUnlock(&threadMutex);
1.784 + return TCL_OK;
1.785 + }
1.786 +
1.787 + /*
1.788 + * Block on the results and then get them.
1.789 + */
1.790 +
1.791 + Tcl_ResetResult(interp);
1.792 + while (resultPtr->result == NULL) {
1.793 + Tcl_ConditionWait(&resultPtr->done, &threadMutex, NULL);
1.794 + }
1.795 +
1.796 + /*
1.797 + * Unlink result from the result list.
1.798 + */
1.799 +
1.800 + if (resultPtr->prevPtr) {
1.801 + resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
1.802 + } else {
1.803 + resultList = resultPtr->nextPtr;
1.804 + }
1.805 + if (resultPtr->nextPtr) {
1.806 + resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
1.807 + }
1.808 + resultPtr->eventPtr = NULL;
1.809 + resultPtr->nextPtr = NULL;
1.810 + resultPtr->prevPtr = NULL;
1.811 +
1.812 + Tcl_MutexUnlock(&threadMutex);
1.813 +
1.814 + if (resultPtr->code != TCL_OK) {
1.815 + if (resultPtr->errorCode) {
1.816 + Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
1.817 + ckfree(resultPtr->errorCode);
1.818 + }
1.819 + if (resultPtr->errorInfo) {
1.820 + Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
1.821 + ckfree(resultPtr->errorInfo);
1.822 + }
1.823 + }
1.824 + Tcl_SetResult(interp, resultPtr->result, TCL_DYNAMIC);
1.825 + Tcl_ConditionFinalize(&resultPtr->done);
1.826 + code = resultPtr->code;
1.827 +
1.828 + ckfree((char *) resultPtr);
1.829 +
1.830 + return code;
1.831 +}
1.832 +
1.833 +
1.834 +/*
1.835 + *------------------------------------------------------------------------
1.836 + *
1.837 + * ThreadEventProc --
1.838 + *
1.839 + * Handle the event in the target thread.
1.840 + *
1.841 + * Results:
1.842 + * Returns 1 to indicate that the event was processed.
1.843 + *
1.844 + * Side effects:
1.845 + * Fills out the ThreadEventResult struct.
1.846 + *
1.847 + *------------------------------------------------------------------------
1.848 + */
1.849 +static int
1.850 +ThreadEventProc(evPtr, mask)
1.851 + Tcl_Event *evPtr; /* Really ThreadEvent */
1.852 + int mask;
1.853 +{
1.854 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.855 + ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
1.856 + ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
1.857 + Tcl_Interp *interp = tsdPtr->interp;
1.858 + int code;
1.859 + CONST char *result, *errorCode, *errorInfo;
1.860 +
1.861 + if (interp == NULL) {
1.862 + code = TCL_ERROR;
1.863 + result = "no target interp!";
1.864 + errorCode = "THREAD";
1.865 + errorInfo = "";
1.866 + } else {
1.867 + Tcl_Preserve((ClientData) interp);
1.868 + Tcl_ResetResult(interp);
1.869 + Tcl_CreateThreadExitHandler(ThreadFreeProc,
1.870 + (ClientData) threadEventPtr->script);
1.871 + code = Tcl_GlobalEval(interp, threadEventPtr->script);
1.872 + Tcl_DeleteThreadExitHandler(ThreadFreeProc,
1.873 + (ClientData) threadEventPtr->script);
1.874 + if (code != TCL_OK) {
1.875 + errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
1.876 + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
1.877 + } else {
1.878 + errorCode = errorInfo = NULL;
1.879 + }
1.880 + result = Tcl_GetStringResult(interp);
1.881 + }
1.882 + ckfree(threadEventPtr->script);
1.883 + if (resultPtr) {
1.884 + Tcl_MutexLock(&threadMutex);
1.885 + resultPtr->code = code;
1.886 + resultPtr->result = ckalloc(strlen(result) + 1);
1.887 + strcpy(resultPtr->result, result);
1.888 + if (errorCode != NULL) {
1.889 + resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
1.890 + strcpy(resultPtr->errorCode, errorCode);
1.891 + }
1.892 + if (errorInfo != NULL) {
1.893 + resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
1.894 + strcpy(resultPtr->errorInfo, errorInfo);
1.895 + }
1.896 + Tcl_ConditionNotify(&resultPtr->done);
1.897 + Tcl_MutexUnlock(&threadMutex);
1.898 + }
1.899 + if (interp != NULL) {
1.900 + Tcl_Release((ClientData) interp);
1.901 + }
1.902 + return 1;
1.903 +}
1.904 +
1.905 +/*
1.906 + *------------------------------------------------------------------------
1.907 + *
1.908 + * ThreadFreeProc --
1.909 + *
1.910 + * This is called from when we are exiting and memory needs
1.911 + * to be freed.
1.912 + *
1.913 + * Results:
1.914 + * None.
1.915 + *
1.916 + * Side effects:
1.917 + * Clears up mem specified in ClientData
1.918 + *
1.919 + *------------------------------------------------------------------------
1.920 + */
1.921 + /* ARGSUSED */
1.922 +static void
1.923 +ThreadFreeProc(clientData)
1.924 + ClientData clientData;
1.925 +{
1.926 + if (clientData) {
1.927 + ckfree((char *) clientData);
1.928 + }
1.929 +}
1.930 +
1.931 +/*
1.932 + *------------------------------------------------------------------------
1.933 + *
1.934 + * ThreadDeleteEvent --
1.935 + *
1.936 + * This is called from the ThreadExitProc to delete memory related
1.937 + * to events that we put on the queue.
1.938 + *
1.939 + * Results:
1.940 + * 1 it was our event and we want it removed, 0 otherwise.
1.941 + *
1.942 + * Side effects:
1.943 + * It cleans up our events in the event queue for this thread.
1.944 + *
1.945 + *------------------------------------------------------------------------
1.946 + */
1.947 + /* ARGSUSED */
1.948 +static int
1.949 +ThreadDeleteEvent(eventPtr, clientData)
1.950 + Tcl_Event *eventPtr; /* Really ThreadEvent */
1.951 + ClientData clientData; /* dummy */
1.952 +{
1.953 + if (eventPtr->proc == ThreadEventProc) {
1.954 + ckfree((char *) ((ThreadEvent *) eventPtr)->script);
1.955 + return 1;
1.956 + }
1.957 + /*
1.958 + * If it was NULL, we were in the middle of servicing the event
1.959 + * and it should be removed
1.960 + */
1.961 + return (eventPtr->proc == NULL);
1.962 +}
1.963 +
1.964 +/*
1.965 + *------------------------------------------------------------------------
1.966 + *
1.967 + * ThreadExitProc --
1.968 + *
1.969 + * This is called when the thread exits.
1.970 + *
1.971 + * Results:
1.972 + * None.
1.973 + *
1.974 + * Side effects:
1.975 + * It unblocks anyone that is waiting on a send to this thread.
1.976 + * It cleans up any events in the event queue for this thread.
1.977 + *
1.978 + *------------------------------------------------------------------------
1.979 + */
1.980 + /* ARGSUSED */
1.981 +static void
1.982 +ThreadExitProc(clientData)
1.983 + ClientData clientData;
1.984 +{
1.985 + char *threadEvalScript = (char *) clientData;
1.986 + ThreadEventResult *resultPtr, *nextPtr;
1.987 + Tcl_ThreadId self = Tcl_GetCurrentThread();
1.988 +
1.989 + Tcl_MutexLock(&threadMutex);
1.990 +
1.991 + if (threadEvalScript) {
1.992 + ckfree((char *) threadEvalScript);
1.993 + threadEvalScript = NULL;
1.994 + }
1.995 + Tcl_DeleteEvents((Tcl_EventDeleteProc *)ThreadDeleteEvent, NULL);
1.996 +
1.997 + for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
1.998 + nextPtr = resultPtr->nextPtr;
1.999 + if (resultPtr->srcThreadId == self) {
1.1000 + /*
1.1001 + * We are going away. By freeing up the result we signal
1.1002 + * to the other thread we don't care about the result.
1.1003 + */
1.1004 + if (resultPtr->prevPtr) {
1.1005 + resultPtr->prevPtr->nextPtr = resultPtr->nextPtr;
1.1006 + } else {
1.1007 + resultList = resultPtr->nextPtr;
1.1008 + }
1.1009 + if (resultPtr->nextPtr) {
1.1010 + resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
1.1011 + }
1.1012 + resultPtr->nextPtr = resultPtr->prevPtr = 0;
1.1013 + resultPtr->eventPtr->resultPtr = NULL;
1.1014 + ckfree((char *)resultPtr);
1.1015 + } else if (resultPtr->dstThreadId == self) {
1.1016 + /*
1.1017 + * Dang. The target is going away. Unblock the caller.
1.1018 + * The result string must be dynamically allocated because
1.1019 + * the main thread is going to call free on it.
1.1020 + */
1.1021 +
1.1022 + char *msg = "target thread died";
1.1023 + resultPtr->result = ckalloc(strlen(msg)+1);
1.1024 + strcpy(resultPtr->result, msg);
1.1025 + resultPtr->code = TCL_ERROR;
1.1026 + Tcl_ConditionNotify(&resultPtr->done);
1.1027 + }
1.1028 + }
1.1029 + Tcl_MutexUnlock(&threadMutex);
1.1030 +}
1.1031 +
1.1032 +#endif /* TCL_THREADS */