os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclEvent.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclEvent.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1281 @@
1.4 +/*
1.5 + * tclEvent.c --
1.6 + *
1.7 + * This file implements some general event related interfaces including
1.8 + * background errors, exit handlers, and the "vwait" and "update"
1.9 + * command procedures.
1.10 + *
1.11 + * Copyright (c) 1990-1994 The Regents of the University of California.
1.12 + * Copyright (c) 1994-1998 Sun Microsystems, Inc.
1.13 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclEvent.c,v 1.28.2.15 2007/03/19 17:06:25 dgp Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclPort.h"
1.23 +#if defined(__SYMBIAN32__) && defined(__WINSCW__)
1.24 +#include "tclSymbianGlobals.h"
1.25 +#define dataKey getdataKey(0)
1.26 +#endif
1.27 +
1.28 +/*
1.29 + * The data structure below is used to report background errors. One
1.30 + * such structure is allocated for each error; it holds information
1.31 + * about the interpreter and the error until bgerror can be invoked
1.32 + * later as an idle handler.
1.33 + */
1.34 +
1.35 +typedef struct BgError {
1.36 + Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
1.37 + * means this error report has been cancelled
1.38 + * (a previous report generated a break). */
1.39 + char *errorMsg; /* Copy of the error message (the interp's
1.40 + * result when the error occurred).
1.41 + * Malloc-ed. */
1.42 + char *errorInfo; /* Value of the errorInfo variable
1.43 + * (malloc-ed). */
1.44 + char *errorCode; /* Value of the errorCode variable
1.45 + * (malloc-ed). */
1.46 + struct BgError *nextPtr; /* Next in list of all pending error
1.47 + * reports for this interpreter, or NULL
1.48 + * for end of list. */
1.49 +} BgError;
1.50 +
1.51 +/*
1.52 + * One of the structures below is associated with the "tclBgError"
1.53 + * assoc data for each interpreter. It keeps track of the head and
1.54 + * tail of the list of pending background errors for the interpreter.
1.55 + */
1.56 +
1.57 +typedef struct ErrAssocData {
1.58 + BgError *firstBgPtr; /* First in list of all background errors
1.59 + * waiting to be processed for this
1.60 + * interpreter (NULL if none). */
1.61 + BgError *lastBgPtr; /* Last in list of all background errors
1.62 + * waiting to be processed for this
1.63 + * interpreter (NULL if none). */
1.64 +} ErrAssocData;
1.65 +
1.66 +/*
1.67 + * For each exit handler created with a call to Tcl_CreateExitHandler
1.68 + * there is a structure of the following type:
1.69 + */
1.70 +
1.71 +typedef struct ExitHandler {
1.72 + Tcl_ExitProc *proc; /* Procedure to call when process exits. */
1.73 + ClientData clientData; /* One word of information to pass to proc. */
1.74 + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
1.75 + * this application, or NULL for end of list. */
1.76 +} ExitHandler;
1.77 +
1.78 +/*
1.79 + * There is both per-process and per-thread exit handlers.
1.80 + * The first list is controlled by a mutex. The other is in
1.81 + * thread local storage.
1.82 + */
1.83 +
1.84 +static ExitHandler *firstExitPtr = NULL;
1.85 + /* First in list of all exit handlers for
1.86 + * application. */
1.87 +TCL_DECLARE_MUTEX(exitMutex)
1.88 +
1.89 +/*
1.90 + * This variable is set to 1 when Tcl_Finalize is called, and at the end of
1.91 + * its work, it is reset to 0. The variable is checked by TclInExit() to
1.92 + * allow different behavior for exit-time processing, e.g. in closing of
1.93 + * files and pipes.
1.94 + */
1.95 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.96 +static int inFinalize = 0;
1.97 +static int subsystemsInitialized = 0;
1.98 +#endif
1.99 +
1.100 +typedef struct ThreadSpecificData {
1.101 + ExitHandler *firstExitPtr; /* First in list of all exit handlers for
1.102 + * this thread. */
1.103 + int inExit; /* True when this thread is exiting. This
1.104 + * is used as a hack to decide to close
1.105 + * the standard channels. */
1.106 + Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */
1.107 +} ThreadSpecificData;
1.108 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.109 +static Tcl_ThreadDataKey dataKey;
1.110 +
1.111 +/*
1.112 + * Common string for the library path for sharing across threads.
1.113 + * This is ckalloc'd and cleared in Tcl_Finalize.
1.114 + */
1.115 +static char *tclLibraryPathStr = NULL;
1.116 +#endif
1.117 +
1.118 +#ifdef TCL_THREADS
1.119 +
1.120 +typedef struct {
1.121 + Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
1.122 + ClientData clientData; /* The one argument to Main() */
1.123 +} ThreadClientData;
1.124 +static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_((
1.125 + ClientData clientData));
1.126 +#endif
1.127 +
1.128 +/*
1.129 + * Prototypes for procedures referenced only in this file:
1.130 + */
1.131 +
1.132 +static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
1.133 + Tcl_Interp *interp));
1.134 +static void HandleBgErrors _ANSI_ARGS_((ClientData clientData));
1.135 +static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData,
1.136 + Tcl_Interp *interp, CONST char *name1,
1.137 + CONST char *name2, int flags));
1.138 +
1.139 +/*
1.140 + *----------------------------------------------------------------------
1.141 + *
1.142 + * Tcl_BackgroundError --
1.143 + *
1.144 + * This procedure is invoked to handle errors that occur in Tcl
1.145 + * commands that are invoked in "background" (e.g. from event or
1.146 + * timer bindings).
1.147 + *
1.148 + * Results:
1.149 + * None.
1.150 + *
1.151 + * Side effects:
1.152 + * The command "bgerror" is invoked later as an idle handler to
1.153 + * process the error, passing it the error message. If that fails,
1.154 + * then an error message is output on stderr.
1.155 + *
1.156 + *----------------------------------------------------------------------
1.157 + */
1.158 +
1.159 +EXPORT_C void
1.160 +Tcl_BackgroundError(interp)
1.161 + Tcl_Interp *interp; /* Interpreter in which an error has
1.162 + * occurred. */
1.163 +{
1.164 + BgError *errPtr;
1.165 + CONST char *errResult, *varValue;
1.166 + ErrAssocData *assocPtr;
1.167 + int length;
1.168 +
1.169 + /*
1.170 + * The Tcl_AddErrorInfo call below (with an empty string) ensures that
1.171 + * errorInfo gets properly set. It's needed in cases where the error
1.172 + * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
1.173 + * in these cases errorInfo still won't have been set when this
1.174 + * procedure is called.
1.175 + */
1.176 +
1.177 + Tcl_AddErrorInfo(interp, "");
1.178 +
1.179 + errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
1.180 +
1.181 + errPtr = (BgError *) ckalloc(sizeof(BgError));
1.182 + errPtr->interp = interp;
1.183 + errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
1.184 + memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
1.185 + varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
1.186 + if (varValue == NULL) {
1.187 + varValue = errPtr->errorMsg;
1.188 + }
1.189 + errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
1.190 + strcpy(errPtr->errorInfo, varValue);
1.191 + varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
1.192 + if (varValue == NULL) {
1.193 + varValue = "";
1.194 + }
1.195 + errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
1.196 + strcpy(errPtr->errorCode, varValue);
1.197 + errPtr->nextPtr = NULL;
1.198 +
1.199 + assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
1.200 + (Tcl_InterpDeleteProc **) NULL);
1.201 + if (assocPtr == NULL) {
1.202 +
1.203 + /*
1.204 + * This is the first time a background error has occurred in
1.205 + * this interpreter. Create associated data to keep track of
1.206 + * pending error reports.
1.207 + */
1.208 +
1.209 + assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
1.210 + assocPtr->firstBgPtr = NULL;
1.211 + assocPtr->lastBgPtr = NULL;
1.212 + Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
1.213 + (ClientData) assocPtr);
1.214 + }
1.215 + if (assocPtr->firstBgPtr == NULL) {
1.216 + assocPtr->firstBgPtr = errPtr;
1.217 + Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
1.218 + } else {
1.219 + assocPtr->lastBgPtr->nextPtr = errPtr;
1.220 + }
1.221 + assocPtr->lastBgPtr = errPtr;
1.222 + Tcl_ResetResult(interp);
1.223 +}
1.224 +
1.225 +/*
1.226 + *----------------------------------------------------------------------
1.227 + *
1.228 + * HandleBgErrors --
1.229 + *
1.230 + * This procedure is invoked as an idle handler to process all of
1.231 + * the accumulated background errors.
1.232 + *
1.233 + * Results:
1.234 + * None.
1.235 + *
1.236 + * Side effects:
1.237 + * Depends on what actions "bgerror" takes for the errors.
1.238 + *
1.239 + *----------------------------------------------------------------------
1.240 + */
1.241 +
1.242 +static void
1.243 +HandleBgErrors(clientData)
1.244 + ClientData clientData; /* Pointer to ErrAssocData structure. */
1.245 +{
1.246 + Tcl_Interp *interp;
1.247 + CONST char *argv[2];
1.248 + int code;
1.249 + BgError *errPtr;
1.250 + ErrAssocData *assocPtr = (ErrAssocData *) clientData;
1.251 + Tcl_Channel errChannel;
1.252 +
1.253 + Tcl_Preserve((ClientData) assocPtr);
1.254 +
1.255 + while (assocPtr->firstBgPtr != NULL) {
1.256 + interp = assocPtr->firstBgPtr->interp;
1.257 + if (interp == NULL) {
1.258 + goto doneWithInterp;
1.259 + }
1.260 +
1.261 + /*
1.262 + * Restore important state variables to what they were at
1.263 + * the time the error occurred.
1.264 + */
1.265 +
1.266 + Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
1.267 + TCL_GLOBAL_ONLY);
1.268 + Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
1.269 + TCL_GLOBAL_ONLY);
1.270 +
1.271 + /*
1.272 + * Create and invoke the bgerror command.
1.273 + */
1.274 +
1.275 + argv[0] = "bgerror";
1.276 + argv[1] = assocPtr->firstBgPtr->errorMsg;
1.277 +
1.278 + Tcl_AllowExceptions(interp);
1.279 + Tcl_Preserve((ClientData) interp);
1.280 + code = TclGlobalInvoke(interp, 2, argv, 0);
1.281 + if (code == TCL_ERROR) {
1.282 +
1.283 + /*
1.284 + * If the interpreter is safe, we look for a hidden command
1.285 + * named "bgerror" and call that with the error information.
1.286 + * Otherwise, simply ignore the error. The rationale is that
1.287 + * this could be an error caused by a malicious applet trying
1.288 + * to cause an infinite barrage of error messages. The hidden
1.289 + * "bgerror" command can be used by a security policy to
1.290 + * interpose on such attacks and e.g. kill the applet after a
1.291 + * few attempts.
1.292 + */
1.293 +
1.294 + if (Tcl_IsSafe(interp)) {
1.295 + Tcl_SavedResult save;
1.296 +
1.297 + Tcl_SaveResult(interp, &save);
1.298 + TclGlobalInvoke(interp, 2, argv, TCL_INVOKE_HIDDEN);
1.299 + Tcl_RestoreResult(interp, &save);
1.300 +
1.301 + goto doneWithInterp;
1.302 + }
1.303 +
1.304 + /*
1.305 + * We have to get the error output channel at the latest possible
1.306 + * time, because the eval (above) might have changed the channel.
1.307 + */
1.308 +
1.309 + errChannel = Tcl_GetStdChannel(TCL_STDERR);
1.310 + if (errChannel != (Tcl_Channel) NULL) {
1.311 + char *string;
1.312 + int len;
1.313 +
1.314 + string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
1.315 + if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) {
1.316 + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
1.317 + Tcl_WriteChars(errChannel, "\n", -1);
1.318 + } else {
1.319 + Tcl_WriteChars(errChannel,
1.320 + "bgerror failed to handle background error.\n",
1.321 + -1);
1.322 + Tcl_WriteChars(errChannel, " Original error: ", -1);
1.323 + Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
1.324 + -1);
1.325 + Tcl_WriteChars(errChannel, "\n", -1);
1.326 + Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
1.327 + Tcl_WriteChars(errChannel, string, len);
1.328 + Tcl_WriteChars(errChannel, "\n", -1);
1.329 + }
1.330 + Tcl_Flush(errChannel);
1.331 + }
1.332 + } else if (code == TCL_BREAK) {
1.333 +
1.334 + /*
1.335 + * Break means cancel any remaining error reports for this
1.336 + * interpreter.
1.337 + */
1.338 +
1.339 + for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
1.340 + errPtr = errPtr->nextPtr) {
1.341 + if (errPtr->interp == interp) {
1.342 + errPtr->interp = NULL;
1.343 + }
1.344 + }
1.345 + }
1.346 +
1.347 + /*
1.348 + * Discard the command and the information about the error report.
1.349 + */
1.350 +
1.351 +doneWithInterp:
1.352 +
1.353 + if (assocPtr->firstBgPtr) {
1.354 + ckfree(assocPtr->firstBgPtr->errorMsg);
1.355 + ckfree(assocPtr->firstBgPtr->errorInfo);
1.356 + ckfree(assocPtr->firstBgPtr->errorCode);
1.357 + errPtr = assocPtr->firstBgPtr->nextPtr;
1.358 + ckfree((char *) assocPtr->firstBgPtr);
1.359 + assocPtr->firstBgPtr = errPtr;
1.360 + }
1.361 +
1.362 + if (interp != NULL) {
1.363 + Tcl_Release((ClientData) interp);
1.364 + }
1.365 + }
1.366 + assocPtr->lastBgPtr = NULL;
1.367 +
1.368 + Tcl_Release((ClientData) assocPtr);
1.369 +}
1.370 +
1.371 +/*
1.372 + *----------------------------------------------------------------------
1.373 + *
1.374 + * BgErrorDeleteProc --
1.375 + *
1.376 + * This procedure is associated with the "tclBgError" assoc data
1.377 + * for an interpreter; it is invoked when the interpreter is
1.378 + * deleted in order to free the information assoicated with any
1.379 + * pending error reports.
1.380 + *
1.381 + * Results:
1.382 + * None.
1.383 + *
1.384 + * Side effects:
1.385 + * Background error information is freed: if there were any
1.386 + * pending error reports, they are cancelled.
1.387 + *
1.388 + *----------------------------------------------------------------------
1.389 + */
1.390 +
1.391 +static void
1.392 +BgErrorDeleteProc(clientData, interp)
1.393 + ClientData clientData; /* Pointer to ErrAssocData structure. */
1.394 + Tcl_Interp *interp; /* Interpreter being deleted. */
1.395 +{
1.396 + ErrAssocData *assocPtr = (ErrAssocData *) clientData;
1.397 + BgError *errPtr;
1.398 +
1.399 + while (assocPtr->firstBgPtr != NULL) {
1.400 + errPtr = assocPtr->firstBgPtr;
1.401 + assocPtr->firstBgPtr = errPtr->nextPtr;
1.402 + ckfree(errPtr->errorMsg);
1.403 + ckfree(errPtr->errorInfo);
1.404 + ckfree(errPtr->errorCode);
1.405 + ckfree((char *) errPtr);
1.406 + }
1.407 + Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
1.408 + Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
1.409 +}
1.410 +
1.411 +/*
1.412 + *----------------------------------------------------------------------
1.413 + *
1.414 + * Tcl_CreateExitHandler --
1.415 + *
1.416 + * Arrange for a given procedure to be invoked just before the
1.417 + * application exits.
1.418 + *
1.419 + * Results:
1.420 + * None.
1.421 + *
1.422 + * Side effects:
1.423 + * Proc will be invoked with clientData as argument when the
1.424 + * application exits.
1.425 + *
1.426 + *----------------------------------------------------------------------
1.427 + */
1.428 +
1.429 +EXPORT_C void
1.430 +Tcl_CreateExitHandler(proc, clientData)
1.431 + Tcl_ExitProc *proc; /* Procedure to invoke. */
1.432 + ClientData clientData; /* Arbitrary value to pass to proc. */
1.433 +{
1.434 + ExitHandler *exitPtr;
1.435 +
1.436 + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
1.437 + exitPtr->proc = proc;
1.438 + exitPtr->clientData = clientData;
1.439 + Tcl_MutexLock(&exitMutex);
1.440 + exitPtr->nextPtr = firstExitPtr;
1.441 + firstExitPtr = exitPtr;
1.442 + Tcl_MutexUnlock(&exitMutex);
1.443 +}
1.444 +
1.445 +/*
1.446 + *----------------------------------------------------------------------
1.447 + *
1.448 + * Tcl_DeleteExitHandler --
1.449 + *
1.450 + * This procedure cancels an existing exit handler matching proc
1.451 + * and clientData, if such a handler exits.
1.452 + *
1.453 + * Results:
1.454 + * None.
1.455 + *
1.456 + * Side effects:
1.457 + * If there is an exit handler corresponding to proc and clientData
1.458 + * then it is cancelled; if no such handler exists then nothing
1.459 + * happens.
1.460 + *
1.461 + *----------------------------------------------------------------------
1.462 + */
1.463 +
1.464 +EXPORT_C void
1.465 +Tcl_DeleteExitHandler(proc, clientData)
1.466 + Tcl_ExitProc *proc; /* Procedure that was previously registered. */
1.467 + ClientData clientData; /* Arbitrary value to pass to proc. */
1.468 +{
1.469 + ExitHandler *exitPtr, *prevPtr;
1.470 +
1.471 + Tcl_MutexLock(&exitMutex);
1.472 + for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
1.473 + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
1.474 + if ((exitPtr->proc == proc)
1.475 + && (exitPtr->clientData == clientData)) {
1.476 + if (prevPtr == NULL) {
1.477 + firstExitPtr = exitPtr->nextPtr;
1.478 + } else {
1.479 + prevPtr->nextPtr = exitPtr->nextPtr;
1.480 + }
1.481 + ckfree((char *) exitPtr);
1.482 + break;
1.483 + }
1.484 + }
1.485 + Tcl_MutexUnlock(&exitMutex);
1.486 + return;
1.487 +}
1.488 +
1.489 +/*
1.490 + *----------------------------------------------------------------------
1.491 + *
1.492 + * Tcl_CreateThreadExitHandler --
1.493 + *
1.494 + * Arrange for a given procedure to be invoked just before the
1.495 + * current thread exits.
1.496 + *
1.497 + * Results:
1.498 + * None.
1.499 + *
1.500 + * Side effects:
1.501 + * Proc will be invoked with clientData as argument when the
1.502 + * application exits.
1.503 + *
1.504 + *----------------------------------------------------------------------
1.505 + */
1.506 +
1.507 +EXPORT_C void
1.508 +Tcl_CreateThreadExitHandler(proc, clientData)
1.509 + Tcl_ExitProc *proc; /* Procedure to invoke. */
1.510 + ClientData clientData; /* Arbitrary value to pass to proc. */
1.511 +{
1.512 + ExitHandler *exitPtr;
1.513 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.514 +
1.515 + exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
1.516 + exitPtr->proc = proc;
1.517 + exitPtr->clientData = clientData;
1.518 + exitPtr->nextPtr = tsdPtr->firstExitPtr;
1.519 + tsdPtr->firstExitPtr = exitPtr;
1.520 +}
1.521 +
1.522 +/*
1.523 + *----------------------------------------------------------------------
1.524 + *
1.525 + * Tcl_DeleteThreadExitHandler --
1.526 + *
1.527 + * This procedure cancels an existing exit handler matching proc
1.528 + * and clientData, if such a handler exits.
1.529 + *
1.530 + * Results:
1.531 + * None.
1.532 + *
1.533 + * Side effects:
1.534 + * If there is an exit handler corresponding to proc and clientData
1.535 + * then it is cancelled; if no such handler exists then nothing
1.536 + * happens.
1.537 + *
1.538 + *----------------------------------------------------------------------
1.539 + */
1.540 +
1.541 +EXPORT_C void
1.542 +Tcl_DeleteThreadExitHandler(proc, clientData)
1.543 + Tcl_ExitProc *proc; /* Procedure that was previously registered. */
1.544 + ClientData clientData; /* Arbitrary value to pass to proc. */
1.545 +{
1.546 + ExitHandler *exitPtr, *prevPtr;
1.547 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.548 +
1.549 + for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
1.550 + prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
1.551 + if ((exitPtr->proc == proc)
1.552 + && (exitPtr->clientData == clientData)) {
1.553 + if (prevPtr == NULL) {
1.554 + tsdPtr->firstExitPtr = exitPtr->nextPtr;
1.555 + } else {
1.556 + prevPtr->nextPtr = exitPtr->nextPtr;
1.557 + }
1.558 + ckfree((char *) exitPtr);
1.559 + return;
1.560 + }
1.561 + }
1.562 +}
1.563 +
1.564 +/*
1.565 + *----------------------------------------------------------------------
1.566 + *
1.567 + * Tcl_Exit --
1.568 + *
1.569 + * This procedure is called to terminate the application.
1.570 + *
1.571 + * Results:
1.572 + * None.
1.573 + *
1.574 + * Side effects:
1.575 + * All existing exit handlers are invoked, then the application
1.576 + * ends.
1.577 + *
1.578 + *----------------------------------------------------------------------
1.579 + */
1.580 +
1.581 +EXPORT_C void
1.582 +Tcl_Exit(status)
1.583 + int status; /* Exit status for application; typically
1.584 + * 0 for normal return, 1 for error return. */
1.585 +{
1.586 + Tcl_Finalize();
1.587 + TclpExit(status);
1.588 +}
1.589 +
1.590 +/*
1.591 + *-------------------------------------------------------------------------
1.592 + *
1.593 + * TclSetLibraryPath --
1.594 + *
1.595 + * Set the path that will be used for searching for init.tcl and
1.596 + * encodings when an interp is being created.
1.597 + *
1.598 + * Results:
1.599 + * None.
1.600 + *
1.601 + * Side effects:
1.602 + * Changing the library path will affect what directories are
1.603 + * examined when looking for encodings for all interps from that
1.604 + * point forward.
1.605 + *
1.606 + * The refcount of the new library path is incremented and the
1.607 + * refcount of the old path is decremented.
1.608 + *
1.609 + *-------------------------------------------------------------------------
1.610 + */
1.611 +
1.612 +void
1.613 +TclSetLibraryPath(pathPtr)
1.614 + Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
1.615 + * the new library path. */
1.616 +{
1.617 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.618 + const char *toDupe;
1.619 + int size;
1.620 +
1.621 + if (pathPtr != NULL) {
1.622 + Tcl_IncrRefCount(pathPtr);
1.623 + }
1.624 + if (tsdPtr->tclLibraryPath != NULL) {
1.625 + Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
1.626 + }
1.627 + tsdPtr->tclLibraryPath = pathPtr;
1.628 +
1.629 + /*
1.630 + * No mutex locking is needed here as up the stack we're within
1.631 + * TclpInitLock().
1.632 + */
1.633 + if (tclLibraryPathStr != NULL) {
1.634 + ckfree(tclLibraryPathStr);
1.635 + }
1.636 + toDupe = Tcl_GetStringFromObj(pathPtr, &size);
1.637 + tclLibraryPathStr = ckalloc((unsigned)size+1);
1.638 + memcpy(tclLibraryPathStr, toDupe, (unsigned)size+1);
1.639 +}
1.640 +
1.641 +/*
1.642 + *-------------------------------------------------------------------------
1.643 + *
1.644 + * TclGetLibraryPath --
1.645 + *
1.646 + * Return a Tcl list object whose elements are the library path.
1.647 + * The caller should not modify the contents of the returned object.
1.648 + *
1.649 + * Results:
1.650 + * As above.
1.651 + *
1.652 + * Side effects:
1.653 + * None.
1.654 + *
1.655 + *-------------------------------------------------------------------------
1.656 + */
1.657 +
1.658 +Tcl_Obj *
1.659 +TclGetLibraryPath()
1.660 +{
1.661 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.662 +
1.663 + if (tsdPtr->tclLibraryPath == NULL) {
1.664 + /*
1.665 + * Grab the shared string and place it into a new thread specific
1.666 + * Tcl_Obj.
1.667 + */
1.668 + tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1);
1.669 +
1.670 + /* take ownership */
1.671 + Tcl_IncrRefCount(tsdPtr->tclLibraryPath);
1.672 + }
1.673 + return tsdPtr->tclLibraryPath;
1.674 +}
1.675 +
1.676 +/*
1.677 + *-------------------------------------------------------------------------
1.678 + *
1.679 + * TclInitSubsystems --
1.680 + *
1.681 + * Initialize various subsytems in Tcl. This should be called the
1.682 + * first time an interp is created, or before any of the subsystems
1.683 + * are used. This function ensures an order for the initialization
1.684 + * of subsystems:
1.685 + *
1.686 + * 1. that cannot be initialized in lazy order because they are
1.687 + * mutually dependent.
1.688 + *
1.689 + * 2. so that they can be finalized in a known order w/o causing
1.690 + * the subsequent re-initialization of a subsystem in the act of
1.691 + * shutting down another.
1.692 + *
1.693 + * Results:
1.694 + * None.
1.695 + *
1.696 + * Side effects:
1.697 + * Varied, see the respective initialization routines.
1.698 + *
1.699 + *-------------------------------------------------------------------------
1.700 + */
1.701 +
1.702 +void
1.703 +TclInitSubsystems(argv0)
1.704 + CONST char *argv0; /* Name of executable from argv[0] to main()
1.705 + * in native multi-byte encoding. */
1.706 +{
1.707 + ThreadSpecificData *tsdPtr;
1.708 +
1.709 + if (inFinalize != 0) {
1.710 + panic("TclInitSubsystems called while finalizing");
1.711 + }
1.712 +
1.713 + /*
1.714 + * Grab the thread local storage pointer before doing anything because
1.715 + * the initialization routines will be registering exit handlers.
1.716 + * We use this pointer to detect if this is the first time this
1.717 + * thread has created an interpreter.
1.718 + */
1.719 +
1.720 + tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
1.721 +
1.722 + if (subsystemsInitialized == 0) {
1.723 + /*
1.724 + * Double check inside the mutex. There are definitly calls
1.725 + * back into this routine from some of the procedures below.
1.726 + */
1.727 +
1.728 + TclpInitLock();
1.729 + if (subsystemsInitialized == 0) {
1.730 + /*
1.731 + * Have to set this bit here to avoid deadlock with the
1.732 + * routines below us that call into TclInitSubsystems.
1.733 + */
1.734 +
1.735 + subsystemsInitialized = 1;
1.736 +
1.737 + tclExecutableName = NULL;
1.738 +
1.739 + /*
1.740 + * Initialize locks used by the memory allocators before anything
1.741 + * interesting happens so we can use the allocators in the
1.742 + * implementation of self-initializing locks.
1.743 + */
1.744 +
1.745 +#if USE_TCLALLOC
1.746 + TclInitAlloc(); /* process wide mutex init */
1.747 +#endif
1.748 +#ifdef TCL_MEM_DEBUG
1.749 + TclInitDbCkalloc(); /* process wide mutex init */
1.750 +#endif
1.751 +
1.752 + TclpInitPlatform(); /* creates signal handler(s) */
1.753 + TclInitObjSubsystem(); /* register obj types, create mutexes */
1.754 + TclInitIOSubsystem(); /* inits a tsd key (noop) */
1.755 + TclInitEncodingSubsystem(); /* process wide encoding init */
1.756 + TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
1.757 + }
1.758 + TclpInitUnlock();
1.759 + }
1.760 +
1.761 + if (tsdPtr == NULL) {
1.762 + /*
1.763 + * First time this thread has created an interpreter.
1.764 + * We fetch the key again just in case no exit handlers were
1.765 + * registered by this point.
1.766 + */
1.767 +
1.768 + (void) TCL_TSD_INIT(&dataKey);
1.769 + TclInitNotifier();
1.770 + }
1.771 +}
1.772 +
1.773 +/*
1.774 + *----------------------------------------------------------------------
1.775 + *
1.776 + * Tcl_Finalize --
1.777 + *
1.778 + * Shut down Tcl. First calls registered exit handlers, then
1.779 + * carefully shuts down various subsystems.
1.780 + * Called by Tcl_Exit or when the Tcl shared library is being
1.781 + * unloaded.
1.782 + *
1.783 + * Results:
1.784 + * None.
1.785 + *
1.786 + * Side effects:
1.787 + * Varied, see the respective finalization routines.
1.788 + *
1.789 + *----------------------------------------------------------------------
1.790 + */
1.791 +
1.792 +EXPORT_C void
1.793 +Tcl_Finalize()
1.794 +{
1.795 + ExitHandler *exitPtr;
1.796 +
1.797 + /*
1.798 + * Invoke exit handlers first.
1.799 + */
1.800 +
1.801 + Tcl_MutexLock(&exitMutex);
1.802 + inFinalize = 1;
1.803 + for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
1.804 + /*
1.805 + * Be careful to remove the handler from the list before
1.806 + * invoking its callback. This protects us against
1.807 + * double-freeing if the callback should call
1.808 + * Tcl_DeleteExitHandler on itself.
1.809 + */
1.810 +
1.811 + firstExitPtr = exitPtr->nextPtr;
1.812 + Tcl_MutexUnlock(&exitMutex);
1.813 + (*exitPtr->proc)(exitPtr->clientData);
1.814 + ckfree((char *) exitPtr);
1.815 + Tcl_MutexLock(&exitMutex);
1.816 + }
1.817 + firstExitPtr = NULL;
1.818 + Tcl_MutexUnlock(&exitMutex);
1.819 +
1.820 + TclpInitLock();
1.821 + if (subsystemsInitialized != 0) {
1.822 + subsystemsInitialized = 0;
1.823 +
1.824 + /*
1.825 + * Ensure the thread-specific data is initialised as it is
1.826 + * used in Tcl_FinalizeThread()
1.827 + */
1.828 +
1.829 + (void) TCL_TSD_INIT(&dataKey);
1.830 +
1.831 + /*
1.832 + * Clean up after the current thread now, after exit handlers.
1.833 + * In particular, the testexithandler command sets up something
1.834 + * that writes to standard output, which gets closed.
1.835 + * Note that there is no thread-local storage after this call.
1.836 + */
1.837 +
1.838 + Tcl_FinalizeThread();
1.839 +
1.840 + /*
1.841 + * Now finalize the Tcl execution environment. Note that this
1.842 + * must be done after the exit handlers, because there are
1.843 + * order dependencies.
1.844 + */
1.845 +
1.846 + TclFinalizeCompilation();
1.847 + TclFinalizeExecution();
1.848 + TclFinalizeEnvironment();
1.849 +
1.850 + /*
1.851 + * Finalizing the filesystem must come after anything which
1.852 + * might conceivably interact with the 'Tcl_FS' API.
1.853 + */
1.854 +
1.855 + TclFinalizeFilesystem();
1.856 +
1.857 + /*
1.858 + * Undo all the Tcl_ObjType registrations, and reset the master list
1.859 + * of free Tcl_Obj's. After this returns, no more Tcl_Obj's should
1.860 + * be allocated or freed.
1.861 + *
1.862 + * Note in particular that TclFinalizeObjects() must follow
1.863 + * TclFinalizeFilesystem() because TclFinalizeFilesystem free's
1.864 + * the Tcl_Obj that holds the path of the current working directory.
1.865 + */
1.866 +
1.867 + TclFinalizeObjects();
1.868 +
1.869 + /*
1.870 + * We must be sure the encoding finalization doesn't need
1.871 + * to examine the filesystem in any way. Since it only
1.872 + * needs to clean up internal data structures, this is
1.873 + * fine.
1.874 + */
1.875 + TclFinalizeEncodingSubsystem();
1.876 +
1.877 + if (tclExecutableName != NULL) {
1.878 + ckfree(tclExecutableName);
1.879 + tclExecutableName = NULL;
1.880 + }
1.881 + if (tclNativeExecutableName != NULL) {
1.882 + ckfree(tclNativeExecutableName);
1.883 + tclNativeExecutableName = NULL;
1.884 + }
1.885 + if (tclDefaultEncodingDir != NULL) {
1.886 + ckfree(tclDefaultEncodingDir);
1.887 + tclDefaultEncodingDir = NULL;
1.888 + }
1.889 + if (tclLibraryPathStr != NULL) {
1.890 + ckfree(tclLibraryPathStr);
1.891 + tclLibraryPathStr = NULL;
1.892 + }
1.893 +
1.894 + Tcl_SetPanicProc(NULL);
1.895 +
1.896 + /*
1.897 + * There have been several bugs in the past that cause
1.898 + * exit handlers to be established during Tcl_Finalize
1.899 + * processing. Such exit handlers leave malloc'ed memory,
1.900 + * and Tcl_FinalizeThreadAlloc or Tcl_FinalizeMemorySubsystem
1.901 + * will result in a corrupted heap. The result can be a
1.902 + * mysterious crash on process exit. Check here that
1.903 + * nobody's done this.
1.904 + */
1.905 +
1.906 +#ifdef TCL_MEM_DEBUG
1.907 + if ( firstExitPtr != NULL ) {
1.908 + Tcl_Panic( "exit handlers were created during Tcl_Finalize" );
1.909 + }
1.910 +#endif
1.911 +
1.912 + TclFinalizePreserve();
1.913 +
1.914 + /*
1.915 + * Free synchronization objects. There really should only be one
1.916 + * thread alive at this moment.
1.917 + */
1.918 +
1.919 + TclFinalizeSynchronization();
1.920 +
1.921 +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG) && !defined(PURIFY)
1.922 + TclFinalizeThreadAlloc();
1.923 +#endif
1.924 +
1.925 + /*
1.926 + * We defer unloading of packages until very late
1.927 + * to avoid memory access issues. Both exit callbacks and
1.928 + * synchronization variables may be stored in packages.
1.929 + *
1.930 + * Note that TclFinalizeLoad unloads packages in the reverse
1.931 + * of the order they were loaded in (i.e. last to be loaded
1.932 + * is the first to be unloaded). This can be important for
1.933 + * correct unloading when dependencies exist.
1.934 + *
1.935 + * Once load has been finalized, we will have deleted any
1.936 + * temporary copies of shared libraries and can therefore
1.937 + * reset the filesystem to its original state.
1.938 + */
1.939 +
1.940 + TclFinalizeLoad();
1.941 + TclResetFilesystem();
1.942 +
1.943 + /*
1.944 + * At this point, there should no longer be any ckalloc'ed memory.
1.945 + */
1.946 +
1.947 + TclFinalizeMemorySubsystem();
1.948 + inFinalize = 0;
1.949 + }
1.950 + TclFinalizeLock();
1.951 +}
1.952 +
1.953 +/*
1.954 + *----------------------------------------------------------------------
1.955 + *
1.956 + * Tcl_FinalizeThread --
1.957 + *
1.958 + * Runs the exit handlers to allow Tcl to clean up its state
1.959 + * about a particular thread.
1.960 + *
1.961 + * Results:
1.962 + * None.
1.963 + *
1.964 + * Side effects:
1.965 + * Varied, see the respective finalization routines.
1.966 + *
1.967 + *----------------------------------------------------------------------
1.968 + */
1.969 +
1.970 +EXPORT_C void
1.971 +Tcl_FinalizeThread()
1.972 +{
1.973 + ExitHandler *exitPtr;
1.974 + ThreadSpecificData *tsdPtr;
1.975 +
1.976 + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
1.977 + if (tsdPtr != NULL) {
1.978 + tsdPtr->inExit = 1;
1.979 +
1.980 + /*
1.981 + * Clean up the library path now, before we invalidate thread-local
1.982 + * storage or calling thread exit handlers.
1.983 + */
1.984 +
1.985 + if (tsdPtr->tclLibraryPath != NULL) {
1.986 + Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
1.987 + tsdPtr->tclLibraryPath = NULL;
1.988 + }
1.989 +
1.990 + for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
1.991 + exitPtr = tsdPtr->firstExitPtr) {
1.992 + /*
1.993 + * Be careful to remove the handler from the list before invoking
1.994 + * its callback. This protects us against double-freeing if the
1.995 + * callback should call Tcl_DeleteThreadExitHandler on itself.
1.996 + */
1.997 +
1.998 + tsdPtr->firstExitPtr = exitPtr->nextPtr;
1.999 + (*exitPtr->proc)(exitPtr->clientData);
1.1000 + ckfree((char *) exitPtr);
1.1001 + }
1.1002 + TclFinalizeIOSubsystem();
1.1003 + TclFinalizeNotifier();
1.1004 + TclFinalizeAsync();
1.1005 + }
1.1006 +
1.1007 + /*
1.1008 + * Blow away all thread local storage blocks.
1.1009 + *
1.1010 + * Note that Tcl API allows creation of threads which do not use any
1.1011 + * Tcl interp or other Tcl subsytems. Those threads might, however,
1.1012 + * use thread local storage, so we must unconditionally finalize it.
1.1013 + *
1.1014 + * Fix [Bug #571002]
1.1015 + */
1.1016 +
1.1017 + TclFinalizeThreadData();
1.1018 +}
1.1019 +
1.1020 +/*
1.1021 + *----------------------------------------------------------------------
1.1022 + *
1.1023 + * TclInExit --
1.1024 + *
1.1025 + * Determines if we are in the middle of exit-time cleanup.
1.1026 + *
1.1027 + * Results:
1.1028 + * If we are in the middle of exiting, 1, otherwise 0.
1.1029 + *
1.1030 + * Side effects:
1.1031 + * None.
1.1032 + *
1.1033 + *----------------------------------------------------------------------
1.1034 + */
1.1035 +
1.1036 +int
1.1037 +TclInExit()
1.1038 +{
1.1039 + return inFinalize;
1.1040 +}
1.1041 +
1.1042 +/*
1.1043 + *----------------------------------------------------------------------
1.1044 + *
1.1045 + * TclInThreadExit --
1.1046 + *
1.1047 + * Determines if we are in the middle of thread exit-time cleanup.
1.1048 + *
1.1049 + * Results:
1.1050 + * If we are in the middle of exiting this thread, 1, otherwise 0.
1.1051 + *
1.1052 + * Side effects:
1.1053 + * None.
1.1054 + *
1.1055 + *----------------------------------------------------------------------
1.1056 + */
1.1057 +
1.1058 +int
1.1059 +TclInThreadExit()
1.1060 +{
1.1061 + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
1.1062 + TclThreadDataKeyGet(&dataKey);
1.1063 + if (tsdPtr == NULL) {
1.1064 + return 0;
1.1065 + } else {
1.1066 + return tsdPtr->inExit;
1.1067 + }
1.1068 +}
1.1069 +
1.1070 +/*
1.1071 + *----------------------------------------------------------------------
1.1072 + *
1.1073 + * Tcl_VwaitObjCmd --
1.1074 + *
1.1075 + * This procedure is invoked to process the "vwait" Tcl command.
1.1076 + * See the user documentation for details on what it does.
1.1077 + *
1.1078 + * Results:
1.1079 + * A standard Tcl result.
1.1080 + *
1.1081 + * Side effects:
1.1082 + * See the user documentation.
1.1083 + *
1.1084 + *----------------------------------------------------------------------
1.1085 + */
1.1086 +
1.1087 + /* ARGSUSED */
1.1088 +int
1.1089 +Tcl_VwaitObjCmd(clientData, interp, objc, objv)
1.1090 + ClientData clientData; /* Not used. */
1.1091 + Tcl_Interp *interp; /* Current interpreter. */
1.1092 + int objc; /* Number of arguments. */
1.1093 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1094 +{
1.1095 + int done, foundEvent;
1.1096 + char *nameString;
1.1097 +
1.1098 + if (objc != 2) {
1.1099 + Tcl_WrongNumArgs(interp, 1, objv, "name");
1.1100 + return TCL_ERROR;
1.1101 + }
1.1102 + nameString = Tcl_GetString(objv[1]);
1.1103 + if (Tcl_TraceVar(interp, nameString,
1.1104 + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1.1105 + VwaitVarProc, (ClientData) &done) != TCL_OK) {
1.1106 + return TCL_ERROR;
1.1107 + };
1.1108 + done = 0;
1.1109 + foundEvent = 1;
1.1110 + while (!done && foundEvent) {
1.1111 + foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
1.1112 + }
1.1113 + Tcl_UntraceVar(interp, nameString,
1.1114 + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
1.1115 + VwaitVarProc, (ClientData) &done);
1.1116 +
1.1117 + /*
1.1118 + * Clear out the interpreter's result, since it may have been set
1.1119 + * by event handlers.
1.1120 + */
1.1121 +
1.1122 + Tcl_ResetResult(interp);
1.1123 + if (!foundEvent) {
1.1124 + Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
1.1125 + "\": would wait forever", (char *) NULL);
1.1126 + return TCL_ERROR;
1.1127 + }
1.1128 + return TCL_OK;
1.1129 +}
1.1130 +
1.1131 + /* ARGSUSED */
1.1132 +static char *
1.1133 +VwaitVarProc(clientData, interp, name1, name2, flags)
1.1134 + ClientData clientData; /* Pointer to integer to set to 1. */
1.1135 + Tcl_Interp *interp; /* Interpreter containing variable. */
1.1136 + CONST char *name1; /* Name of variable. */
1.1137 + CONST char *name2; /* Second part of variable name. */
1.1138 + int flags; /* Information about what happened. */
1.1139 +{
1.1140 + int *donePtr = (int *) clientData;
1.1141 +
1.1142 + *donePtr = 1;
1.1143 + return (char *) NULL;
1.1144 +}
1.1145 +
1.1146 +/*
1.1147 + *----------------------------------------------------------------------
1.1148 + *
1.1149 + * Tcl_UpdateObjCmd --
1.1150 + *
1.1151 + * This procedure is invoked to process the "update" Tcl command.
1.1152 + * See the user documentation for details on what it does.
1.1153 + *
1.1154 + * Results:
1.1155 + * A standard Tcl result.
1.1156 + *
1.1157 + * Side effects:
1.1158 + * See the user documentation.
1.1159 + *
1.1160 + *----------------------------------------------------------------------
1.1161 + */
1.1162 +
1.1163 + /* ARGSUSED */
1.1164 +int
1.1165 +Tcl_UpdateObjCmd(clientData, interp, objc, objv)
1.1166 + ClientData clientData; /* Not used. */
1.1167 + Tcl_Interp *interp; /* Current interpreter. */
1.1168 + int objc; /* Number of arguments. */
1.1169 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.1170 +{
1.1171 + int optionIndex;
1.1172 + int flags = 0; /* Initialized to avoid compiler warning. */
1.1173 + static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
1.1174 + enum updateOptions {REGEXP_IDLETASKS};
1.1175 +
1.1176 + if (objc == 1) {
1.1177 + flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
1.1178 + } else if (objc == 2) {
1.1179 + if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
1.1180 + "option", 0, &optionIndex) != TCL_OK) {
1.1181 + return TCL_ERROR;
1.1182 + }
1.1183 + switch ((enum updateOptions) optionIndex) {
1.1184 + case REGEXP_IDLETASKS: {
1.1185 + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
1.1186 + break;
1.1187 + }
1.1188 + default: {
1.1189 + panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
1.1190 + }
1.1191 + }
1.1192 + } else {
1.1193 + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
1.1194 + return TCL_ERROR;
1.1195 + }
1.1196 +
1.1197 + while (Tcl_DoOneEvent(flags) != 0) {
1.1198 + /* Empty loop body */
1.1199 + }
1.1200 +
1.1201 + /*
1.1202 + * Must clear the interpreter's result because event handlers could
1.1203 + * have executed commands.
1.1204 + */
1.1205 +
1.1206 + Tcl_ResetResult(interp);
1.1207 + return TCL_OK;
1.1208 +}
1.1209 +
1.1210 +#ifdef TCL_THREADS
1.1211 +/*
1.1212 + *-----------------------------------------------------------------------------
1.1213 + *
1.1214 + * NewThreadProc --
1.1215 + *
1.1216 + * Bootstrap function of a new Tcl thread.
1.1217 + *
1.1218 + * Results:
1.1219 + * None.
1.1220 + *
1.1221 + * Side Effects:
1.1222 + * Initializes Tcl notifier for the current thread.
1.1223 + *
1.1224 + *-----------------------------------------------------------------------------
1.1225 + */
1.1226 +
1.1227 +static Tcl_ThreadCreateType
1.1228 +NewThreadProc(ClientData clientData)
1.1229 +{
1.1230 + ThreadClientData *cdPtr;
1.1231 + ClientData threadClientData;
1.1232 + Tcl_ThreadCreateProc *threadProc;
1.1233 +
1.1234 + cdPtr = (ThreadClientData*)clientData;
1.1235 + threadProc = cdPtr->proc;
1.1236 + threadClientData = cdPtr->clientData;
1.1237 + ckfree((char*)clientData); /* Allocated in Tcl_CreateThread() */
1.1238 +
1.1239 + (*threadProc)(threadClientData);
1.1240 +
1.1241 + TCL_THREAD_CREATE_RETURN;
1.1242 +}
1.1243 +#endif
1.1244 +/*
1.1245 + *----------------------------------------------------------------------
1.1246 + *
1.1247 + * Tcl_CreateThread --
1.1248 + *
1.1249 + * This procedure creates a new thread. This actually belongs
1.1250 + * to the tclThread.c file but since we use some private
1.1251 + * data structures local to this file, it is placed here.
1.1252 + *
1.1253 + * Results:
1.1254 + * TCL_OK if the thread could be created. The thread ID is
1.1255 + * returned in a parameter.
1.1256 + *
1.1257 + * Side effects:
1.1258 + * A new thread is created.
1.1259 + *
1.1260 + *----------------------------------------------------------------------
1.1261 + */
1.1262 +
1.1263 +EXPORT_C int
1.1264 +Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
1.1265 + Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
1.1266 + Tcl_ThreadCreateProc proc; /* Main() function of the thread */
1.1267 + ClientData clientData; /* The one argument to Main() */
1.1268 + int stackSize; /* Size of stack for the new thread */
1.1269 + int flags; /* Flags controlling behaviour of
1.1270 + * the new thread */
1.1271 +{
1.1272 +#ifdef TCL_THREADS
1.1273 + ThreadClientData *cdPtr;
1.1274 +
1.1275 + cdPtr = (ThreadClientData*)ckalloc(sizeof(ThreadClientData));
1.1276 + cdPtr->proc = proc;
1.1277 + cdPtr->clientData = clientData;
1.1278 +
1.1279 + return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
1.1280 + stackSize, flags);
1.1281 +#else
1.1282 + return TCL_ERROR;
1.1283 +#endif /* TCL_THREADS */
1.1284 +}