[25] | 1 | /* |
---|
| 2 | * tclEvent.c -- |
---|
| 3 | * |
---|
| 4 | * This file implements some general event related interfaces including |
---|
| 5 | * background errors, exit handlers, and the "vwait" and "update" command |
---|
| 6 | * functions. |
---|
| 7 | * |
---|
| 8 | * Copyright (c) 1990-1994 The Regents of the University of California. |
---|
| 9 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. |
---|
| 10 | * Copyright (c) 2004 by Zoran Vasiljevic. |
---|
| 11 | * |
---|
| 12 | * See the file "license.terms" for information on usage and redistribution of |
---|
| 13 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 14 | * |
---|
| 15 | * RCS: @(#) $Id: tclEvent.c,v 1.80 2008/03/10 17:54:47 dgp Exp $ |
---|
| 16 | */ |
---|
| 17 | |
---|
| 18 | #include "tclInt.h" |
---|
| 19 | |
---|
| 20 | /* |
---|
| 21 | * The data structure below is used to report background errors. One such |
---|
| 22 | * structure is allocated for each error; it holds information about the |
---|
| 23 | * interpreter and the error until an idle handler command can be invoked. |
---|
| 24 | */ |
---|
| 25 | |
---|
| 26 | typedef struct BgError { |
---|
| 27 | Tcl_Obj *errorMsg; /* Copy of the error message (the interp's |
---|
| 28 | * result when the error occurred). */ |
---|
| 29 | Tcl_Obj *returnOpts; /* Active return options when the error |
---|
| 30 | * occurred */ |
---|
| 31 | struct BgError *nextPtr; /* Next in list of all pending error reports |
---|
| 32 | * for this interpreter, or NULL for end of |
---|
| 33 | * list. */ |
---|
| 34 | } BgError; |
---|
| 35 | |
---|
| 36 | /* |
---|
| 37 | * One of the structures below is associated with the "tclBgError" assoc data |
---|
| 38 | * for each interpreter. It keeps track of the head and tail of the list of |
---|
| 39 | * pending background errors for the interpreter. |
---|
| 40 | */ |
---|
| 41 | |
---|
| 42 | typedef struct ErrAssocData { |
---|
| 43 | Tcl_Interp *interp; /* Interpreter in which error occurred. */ |
---|
| 44 | Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ |
---|
| 45 | BgError *firstBgPtr; /* First in list of all background errors |
---|
| 46 | * waiting to be processed for this |
---|
| 47 | * interpreter (NULL if none). */ |
---|
| 48 | BgError *lastBgPtr; /* Last in list of all background errors |
---|
| 49 | * waiting to be processed for this |
---|
| 50 | * interpreter (NULL if none). */ |
---|
| 51 | } ErrAssocData; |
---|
| 52 | |
---|
| 53 | /* |
---|
| 54 | * For each exit handler created with a call to Tcl_CreateExitHandler there is |
---|
| 55 | * a structure of the following type: |
---|
| 56 | */ |
---|
| 57 | |
---|
| 58 | typedef struct ExitHandler { |
---|
| 59 | Tcl_ExitProc *proc; /* Function to call when process exits. */ |
---|
| 60 | ClientData clientData; /* One word of information to pass to proc. */ |
---|
| 61 | struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this |
---|
| 62 | * application, or NULL for end of list. */ |
---|
| 63 | } ExitHandler; |
---|
| 64 | |
---|
| 65 | /* |
---|
| 66 | * There is both per-process and per-thread exit handlers. The first list is |
---|
| 67 | * controlled by a mutex. The other is in thread local storage. |
---|
| 68 | */ |
---|
| 69 | |
---|
| 70 | static ExitHandler *firstExitPtr = NULL; |
---|
| 71 | /* First in list of all exit handlers for |
---|
| 72 | * application. */ |
---|
| 73 | TCL_DECLARE_MUTEX(exitMutex) |
---|
| 74 | |
---|
| 75 | /* |
---|
| 76 | * This variable is set to 1 when Tcl_Finalize is called, and at the end of |
---|
| 77 | * its work, it is reset to 0. The variable is checked by TclInExit() to allow |
---|
| 78 | * different behavior for exit-time processing, e.g. in closing of files and |
---|
| 79 | * pipes. |
---|
| 80 | */ |
---|
| 81 | |
---|
| 82 | static int inFinalize = 0; |
---|
| 83 | static int subsystemsInitialized = 0; |
---|
| 84 | |
---|
| 85 | /* |
---|
| 86 | * This variable contains the application wide exit handler. It will be |
---|
| 87 | * called by Tcl_Exit instead of the C-runtime exit if this variable is set |
---|
| 88 | * to a non-NULL value. |
---|
| 89 | */ |
---|
| 90 | |
---|
| 91 | static Tcl_ExitProc *appExitPtr = NULL; |
---|
| 92 | |
---|
| 93 | typedef struct ThreadSpecificData { |
---|
| 94 | ExitHandler *firstExitPtr; /* First in list of all exit handlers for this |
---|
| 95 | * thread. */ |
---|
| 96 | int inExit; /* True when this thread is exiting. This is |
---|
| 97 | * used as a hack to decide to close the |
---|
| 98 | * standard channels. */ |
---|
| 99 | } ThreadSpecificData; |
---|
| 100 | static Tcl_ThreadDataKey dataKey; |
---|
| 101 | |
---|
| 102 | #ifdef TCL_THREADS |
---|
| 103 | typedef struct { |
---|
| 104 | Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ |
---|
| 105 | ClientData clientData; /* The one argument to Main() */ |
---|
| 106 | } ThreadClientData; |
---|
| 107 | static Tcl_ThreadCreateType NewThreadProc(ClientData clientData); |
---|
| 108 | #endif /* TCL_THREADS */ |
---|
| 109 | |
---|
| 110 | /* |
---|
| 111 | * Prototypes for functions referenced only in this file: |
---|
| 112 | */ |
---|
| 113 | |
---|
| 114 | static void BgErrorDeleteProc(ClientData clientData, |
---|
| 115 | Tcl_Interp *interp); |
---|
| 116 | static void HandleBgErrors(ClientData clientData); |
---|
| 117 | static char * VwaitVarProc(ClientData clientData, Tcl_Interp *interp, |
---|
| 118 | CONST char *name1, CONST char *name2, int flags); |
---|
| 119 | |
---|
| 120 | /* |
---|
| 121 | *---------------------------------------------------------------------- |
---|
| 122 | * |
---|
| 123 | * Tcl_BackgroundError -- |
---|
| 124 | * |
---|
| 125 | * This function is invoked to handle errors that occur in Tcl commands |
---|
| 126 | * that are invoked in "background" (e.g. from event or timer bindings). |
---|
| 127 | * |
---|
| 128 | * Results: |
---|
| 129 | * None. |
---|
| 130 | * |
---|
| 131 | * Side effects: |
---|
| 132 | * A handler command is invoked later as an idle handler to process the |
---|
| 133 | * error, passing it the interp result and return options. |
---|
| 134 | * |
---|
| 135 | *---------------------------------------------------------------------- |
---|
| 136 | */ |
---|
| 137 | |
---|
| 138 | void |
---|
| 139 | Tcl_BackgroundError( |
---|
| 140 | Tcl_Interp *interp) /* Interpreter in which an error has |
---|
| 141 | * occurred. */ |
---|
| 142 | { |
---|
| 143 | TclBackgroundException(interp, TCL_ERROR); |
---|
| 144 | } |
---|
| 145 | void |
---|
| 146 | TclBackgroundException( |
---|
| 147 | Tcl_Interp *interp, /* Interpreter in which an exception has |
---|
| 148 | * occurred. */ |
---|
| 149 | int code) /* The exception code value */ |
---|
| 150 | { |
---|
| 151 | BgError *errPtr; |
---|
| 152 | ErrAssocData *assocPtr; |
---|
| 153 | |
---|
| 154 | if (code == TCL_OK) { |
---|
| 155 | return; |
---|
| 156 | } |
---|
| 157 | |
---|
| 158 | errPtr = (BgError *) ckalloc(sizeof(BgError)); |
---|
| 159 | errPtr->errorMsg = Tcl_GetObjResult(interp); |
---|
| 160 | Tcl_IncrRefCount(errPtr->errorMsg); |
---|
| 161 | errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); |
---|
| 162 | Tcl_IncrRefCount(errPtr->returnOpts); |
---|
| 163 | errPtr->nextPtr = NULL; |
---|
| 164 | |
---|
| 165 | (void) TclGetBgErrorHandler(interp); |
---|
| 166 | assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL); |
---|
| 167 | if (assocPtr->firstBgPtr == NULL) { |
---|
| 168 | assocPtr->firstBgPtr = errPtr; |
---|
| 169 | Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr); |
---|
| 170 | } else { |
---|
| 171 | assocPtr->lastBgPtr->nextPtr = errPtr; |
---|
| 172 | } |
---|
| 173 | assocPtr->lastBgPtr = errPtr; |
---|
| 174 | Tcl_ResetResult(interp); |
---|
| 175 | } |
---|
| 176 | |
---|
| 177 | /* |
---|
| 178 | *---------------------------------------------------------------------- |
---|
| 179 | * |
---|
| 180 | * HandleBgErrors -- |
---|
| 181 | * |
---|
| 182 | * This function is invoked as an idle handler to process all of the |
---|
| 183 | * accumulated background errors. |
---|
| 184 | * |
---|
| 185 | * Results: |
---|
| 186 | * None. |
---|
| 187 | * |
---|
| 188 | * Side effects: |
---|
| 189 | * Depends on what actions the handler command takes for the errors. |
---|
| 190 | * |
---|
| 191 | *---------------------------------------------------------------------- |
---|
| 192 | */ |
---|
| 193 | |
---|
| 194 | static void |
---|
| 195 | HandleBgErrors( |
---|
| 196 | ClientData clientData) /* Pointer to ErrAssocData structure. */ |
---|
| 197 | { |
---|
| 198 | ErrAssocData *assocPtr = (ErrAssocData *) clientData; |
---|
| 199 | Tcl_Interp *interp = assocPtr->interp; |
---|
| 200 | BgError *errPtr; |
---|
| 201 | |
---|
| 202 | /* |
---|
| 203 | * Not bothering to save/restore the interp state. Assume that any code |
---|
| 204 | * that has interp state it needs to keep will make its own |
---|
| 205 | * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() |
---|
| 206 | * that could lead us here. |
---|
| 207 | */ |
---|
| 208 | |
---|
| 209 | Tcl_Preserve((ClientData) assocPtr); |
---|
| 210 | Tcl_Preserve((ClientData) interp); |
---|
| 211 | while (assocPtr->firstBgPtr != NULL) { |
---|
| 212 | int code, prefixObjc; |
---|
| 213 | Tcl_Obj **prefixObjv, **tempObjv; |
---|
| 214 | |
---|
| 215 | /* |
---|
| 216 | * Note we copy the handler command prefix each pass through, so |
---|
| 217 | * we do support one handler setting another handler. |
---|
| 218 | */ |
---|
| 219 | |
---|
| 220 | Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); |
---|
| 221 | |
---|
| 222 | errPtr = assocPtr->firstBgPtr; |
---|
| 223 | |
---|
| 224 | Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); |
---|
| 225 | tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *)); |
---|
| 226 | memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); |
---|
| 227 | tempObjv[prefixObjc] = errPtr->errorMsg; |
---|
| 228 | tempObjv[prefixObjc+1] = errPtr->returnOpts; |
---|
| 229 | Tcl_AllowExceptions(interp); |
---|
| 230 | code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL); |
---|
| 231 | |
---|
| 232 | /* |
---|
| 233 | * Discard the command and the information about the error report. |
---|
| 234 | */ |
---|
| 235 | |
---|
| 236 | Tcl_DecrRefCount(copyObj); |
---|
| 237 | Tcl_DecrRefCount(errPtr->errorMsg); |
---|
| 238 | Tcl_DecrRefCount(errPtr->returnOpts); |
---|
| 239 | assocPtr->firstBgPtr = errPtr->nextPtr; |
---|
| 240 | ckfree((char *) errPtr); |
---|
| 241 | ckfree((char *) tempObjv); |
---|
| 242 | |
---|
| 243 | if (code == TCL_BREAK) { |
---|
| 244 | /* |
---|
| 245 | * Break means cancel any remaining error reports for this |
---|
| 246 | * interpreter. |
---|
| 247 | */ |
---|
| 248 | |
---|
| 249 | while (assocPtr->firstBgPtr != NULL) { |
---|
| 250 | errPtr = assocPtr->firstBgPtr; |
---|
| 251 | assocPtr->firstBgPtr = errPtr->nextPtr; |
---|
| 252 | Tcl_DecrRefCount(errPtr->errorMsg); |
---|
| 253 | Tcl_DecrRefCount(errPtr->returnOpts); |
---|
| 254 | ckfree((char *) errPtr); |
---|
| 255 | } |
---|
| 256 | } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { |
---|
| 257 | Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
| 258 | |
---|
| 259 | if (errChannel != (Tcl_Channel) NULL) { |
---|
| 260 | Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); |
---|
| 261 | Tcl_Obj *keyPtr, *valuePtr; |
---|
| 262 | |
---|
| 263 | TclNewLiteralStringObj(keyPtr, "-errorinfo"); |
---|
| 264 | Tcl_IncrRefCount(keyPtr); |
---|
| 265 | Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); |
---|
| 266 | Tcl_DecrRefCount(keyPtr); |
---|
| 267 | |
---|
| 268 | Tcl_WriteChars(errChannel, |
---|
| 269 | "error in background error handler:\n", -1); |
---|
| 270 | if (valuePtr) { |
---|
| 271 | Tcl_WriteObj(errChannel, valuePtr); |
---|
| 272 | } else { |
---|
| 273 | Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); |
---|
| 274 | } |
---|
| 275 | Tcl_WriteChars(errChannel, "\n", 1); |
---|
| 276 | Tcl_Flush(errChannel); |
---|
| 277 | } |
---|
| 278 | } |
---|
| 279 | } |
---|
| 280 | assocPtr->lastBgPtr = NULL; |
---|
| 281 | Tcl_Release((ClientData) interp); |
---|
| 282 | Tcl_Release((ClientData) assocPtr); |
---|
| 283 | } |
---|
| 284 | |
---|
| 285 | /* |
---|
| 286 | *---------------------------------------------------------------------- |
---|
| 287 | * |
---|
| 288 | * TclDefaultBgErrorHandlerObjCmd -- |
---|
| 289 | * |
---|
| 290 | * This function is invoked to process the "::tcl::Bgerror" Tcl command. |
---|
| 291 | * It is the default handler command registered with [interp bgerror] for |
---|
| 292 | * the sake of compatibility with older Tcl releases. |
---|
| 293 | * |
---|
| 294 | * Results: |
---|
| 295 | * A standard Tcl object result. |
---|
| 296 | * |
---|
| 297 | * Side effects: |
---|
| 298 | * Depends on what actions the "bgerror" command takes for the errors. |
---|
| 299 | * |
---|
| 300 | *---------------------------------------------------------------------- |
---|
| 301 | */ |
---|
| 302 | |
---|
| 303 | int |
---|
| 304 | TclDefaultBgErrorHandlerObjCmd( |
---|
| 305 | ClientData dummy, /* Not used. */ |
---|
| 306 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 307 | int objc, /* Number of arguments. */ |
---|
| 308 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 309 | { |
---|
| 310 | Tcl_Obj *keyPtr, *valuePtr; |
---|
| 311 | Tcl_Obj *tempObjv[2]; |
---|
| 312 | int code, level; |
---|
| 313 | Tcl_InterpState saved; |
---|
| 314 | |
---|
| 315 | if (objc != 3) { |
---|
| 316 | Tcl_WrongNumArgs(interp, 1, objv, "msg options"); |
---|
| 317 | return TCL_ERROR; |
---|
| 318 | } |
---|
| 319 | |
---|
| 320 | /* |
---|
| 321 | * Check for a valid return options dictionary. |
---|
| 322 | */ |
---|
| 323 | |
---|
| 324 | TclNewLiteralStringObj(keyPtr, "-level"); |
---|
| 325 | Tcl_IncrRefCount(keyPtr); |
---|
| 326 | Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); |
---|
| 327 | Tcl_DecrRefCount(keyPtr); |
---|
| 328 | if (valuePtr == NULL) { |
---|
| 329 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 330 | "missing return option \"-level\"", -1)); |
---|
| 331 | return TCL_ERROR; |
---|
| 332 | } |
---|
| 333 | if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) { |
---|
| 334 | return TCL_ERROR; |
---|
| 335 | } |
---|
| 336 | TclNewLiteralStringObj(keyPtr, "-code"); |
---|
| 337 | Tcl_IncrRefCount(keyPtr); |
---|
| 338 | Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); |
---|
| 339 | Tcl_DecrRefCount(keyPtr); |
---|
| 340 | if (valuePtr == NULL) { |
---|
| 341 | Tcl_SetObjResult(interp, Tcl_NewStringObj( |
---|
| 342 | "missing return option \"-code\"", -1)); |
---|
| 343 | return TCL_ERROR; |
---|
| 344 | } |
---|
| 345 | if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) { |
---|
| 346 | return TCL_ERROR; |
---|
| 347 | } |
---|
| 348 | |
---|
| 349 | if (level != 0) { |
---|
| 350 | /* We're handling a TCL_RETURN exception */ |
---|
| 351 | code = TCL_RETURN; |
---|
| 352 | } |
---|
| 353 | if (code == TCL_OK) { |
---|
| 354 | /* |
---|
| 355 | * Somehow we got to exception handling with no exception. |
---|
| 356 | * (Pass TCL_OK to TclBackgroundException()?) |
---|
| 357 | * Just return without doing anything. |
---|
| 358 | */ |
---|
| 359 | return TCL_OK; |
---|
| 360 | } |
---|
| 361 | |
---|
| 362 | /* Construct the bgerror command */ |
---|
| 363 | TclNewLiteralStringObj(tempObjv[0], "bgerror"); |
---|
| 364 | Tcl_IncrRefCount(tempObjv[0]); |
---|
| 365 | |
---|
| 366 | /* |
---|
| 367 | * Determine error message argument. Check the return options in case |
---|
| 368 | * a non-error exception brought us here. |
---|
| 369 | */ |
---|
| 370 | |
---|
| 371 | switch (code) { |
---|
| 372 | case TCL_ERROR: |
---|
| 373 | tempObjv[1] = objv[1]; |
---|
| 374 | break; |
---|
| 375 | case TCL_BREAK: |
---|
| 376 | TclNewLiteralStringObj(tempObjv[1], |
---|
| 377 | "invoked \"break\" outside of a loop"); |
---|
| 378 | break; |
---|
| 379 | case TCL_CONTINUE: |
---|
| 380 | TclNewLiteralStringObj(tempObjv[1], |
---|
| 381 | "invoked \"continue\" outside of a loop"); |
---|
| 382 | break; |
---|
| 383 | default: |
---|
| 384 | tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code); |
---|
| 385 | break; |
---|
| 386 | } |
---|
| 387 | Tcl_IncrRefCount(tempObjv[1]); |
---|
| 388 | |
---|
| 389 | if (code != TCL_ERROR) { |
---|
| 390 | Tcl_SetObjResult(interp, tempObjv[1]); |
---|
| 391 | } |
---|
| 392 | |
---|
| 393 | TclNewLiteralStringObj(keyPtr, "-errorcode"); |
---|
| 394 | Tcl_IncrRefCount(keyPtr); |
---|
| 395 | Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); |
---|
| 396 | Tcl_DecrRefCount(keyPtr); |
---|
| 397 | if (valuePtr) { |
---|
| 398 | Tcl_SetObjErrorCode(interp, valuePtr); |
---|
| 399 | } |
---|
| 400 | |
---|
| 401 | TclNewLiteralStringObj(keyPtr, "-errorinfo"); |
---|
| 402 | Tcl_IncrRefCount(keyPtr); |
---|
| 403 | Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr); |
---|
| 404 | Tcl_DecrRefCount(keyPtr); |
---|
| 405 | if (valuePtr) { |
---|
| 406 | Tcl_AppendObjToErrorInfo(interp, valuePtr); |
---|
| 407 | } |
---|
| 408 | |
---|
| 409 | if (code == TCL_ERROR) { |
---|
| 410 | Tcl_SetObjResult(interp, tempObjv[1]); |
---|
| 411 | } |
---|
| 412 | |
---|
| 413 | /* |
---|
| 414 | * Save interpreter state so we can restore it if multiple handler |
---|
| 415 | * attempts are needed. |
---|
| 416 | */ |
---|
| 417 | |
---|
| 418 | saved = Tcl_SaveInterpState(interp, code); |
---|
| 419 | |
---|
| 420 | /* Invoke the bgerror command. */ |
---|
| 421 | Tcl_AllowExceptions(interp); |
---|
| 422 | code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); |
---|
| 423 | if (code == TCL_ERROR) { |
---|
| 424 | /* |
---|
| 425 | * If the interpreter is safe, we look for a hidden command named |
---|
| 426 | * "bgerror" and call that with the error information. Otherwise, |
---|
| 427 | * simply ignore the error. The rationale is that this could be an |
---|
| 428 | * error caused by a malicious applet trying to cause an infinite |
---|
| 429 | * barrage of error messages. The hidden "bgerror" command can be used |
---|
| 430 | * by a security policy to interpose on such attacks and e.g. kill the |
---|
| 431 | * applet after a few attempts. |
---|
| 432 | */ |
---|
| 433 | |
---|
| 434 | if (Tcl_IsSafe(interp)) { |
---|
| 435 | Tcl_RestoreInterpState(interp, saved); |
---|
| 436 | TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN); |
---|
| 437 | } else { |
---|
| 438 | Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); |
---|
| 439 | if (errChannel != (Tcl_Channel) NULL) { |
---|
| 440 | Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); |
---|
| 441 | |
---|
| 442 | Tcl_IncrRefCount(resultPtr); |
---|
| 443 | if (Tcl_FindCommand(interp, "bgerror", NULL, |
---|
| 444 | TCL_GLOBAL_ONLY) == NULL) { |
---|
| 445 | Tcl_RestoreInterpState(interp, saved); |
---|
| 446 | Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, |
---|
| 447 | "errorInfo", NULL, TCL_GLOBAL_ONLY)); |
---|
| 448 | Tcl_WriteChars(errChannel, "\n", -1); |
---|
| 449 | } else { |
---|
| 450 | Tcl_DiscardInterpState(saved); |
---|
| 451 | Tcl_WriteChars(errChannel, |
---|
| 452 | "bgerror failed to handle background error.\n",-1); |
---|
| 453 | Tcl_WriteChars(errChannel, " Original error: ", -1); |
---|
| 454 | Tcl_WriteObj(errChannel, tempObjv[1]); |
---|
| 455 | Tcl_WriteChars(errChannel, "\n", -1); |
---|
| 456 | Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); |
---|
| 457 | Tcl_WriteObj(errChannel, resultPtr); |
---|
| 458 | Tcl_WriteChars(errChannel, "\n", -1); |
---|
| 459 | } |
---|
| 460 | Tcl_DecrRefCount(resultPtr); |
---|
| 461 | Tcl_Flush(errChannel); |
---|
| 462 | } else { |
---|
| 463 | Tcl_DiscardInterpState(saved); |
---|
| 464 | } |
---|
| 465 | } |
---|
| 466 | code = TCL_OK; |
---|
| 467 | } else { |
---|
| 468 | Tcl_DiscardInterpState(saved); |
---|
| 469 | } |
---|
| 470 | |
---|
| 471 | Tcl_DecrRefCount(tempObjv[0]); |
---|
| 472 | Tcl_DecrRefCount(tempObjv[1]); |
---|
| 473 | Tcl_ResetResult(interp); |
---|
| 474 | return code; |
---|
| 475 | } |
---|
| 476 | |
---|
| 477 | /* |
---|
| 478 | *---------------------------------------------------------------------- |
---|
| 479 | * |
---|
| 480 | * TclSetBgErrorHandler -- |
---|
| 481 | * |
---|
| 482 | * This function sets the command prefix to be used to handle background |
---|
| 483 | * errors in interp. |
---|
| 484 | * |
---|
| 485 | * Results: |
---|
| 486 | * None. |
---|
| 487 | * |
---|
| 488 | * Side effects: |
---|
| 489 | * Error handler is registered. |
---|
| 490 | * |
---|
| 491 | *---------------------------------------------------------------------- |
---|
| 492 | */ |
---|
| 493 | |
---|
| 494 | void |
---|
| 495 | TclSetBgErrorHandler( |
---|
| 496 | Tcl_Interp *interp, |
---|
| 497 | Tcl_Obj *cmdPrefix) |
---|
| 498 | { |
---|
| 499 | ErrAssocData *assocPtr = (ErrAssocData *) |
---|
| 500 | Tcl_GetAssocData(interp, "tclBgError", NULL); |
---|
| 501 | |
---|
| 502 | if (cmdPrefix == NULL) { |
---|
| 503 | Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument"); |
---|
| 504 | } |
---|
| 505 | if (assocPtr == NULL) { |
---|
| 506 | /* |
---|
| 507 | * First access: initialize. |
---|
| 508 | */ |
---|
| 509 | |
---|
| 510 | assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData)); |
---|
| 511 | assocPtr->interp = interp; |
---|
| 512 | assocPtr->cmdPrefix = NULL; |
---|
| 513 | assocPtr->firstBgPtr = NULL; |
---|
| 514 | assocPtr->lastBgPtr = NULL; |
---|
| 515 | Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, |
---|
| 516 | (ClientData) assocPtr); |
---|
| 517 | } |
---|
| 518 | if (assocPtr->cmdPrefix) { |
---|
| 519 | Tcl_DecrRefCount(assocPtr->cmdPrefix); |
---|
| 520 | } |
---|
| 521 | assocPtr->cmdPrefix = cmdPrefix; |
---|
| 522 | Tcl_IncrRefCount(assocPtr->cmdPrefix); |
---|
| 523 | } |
---|
| 524 | |
---|
| 525 | /* |
---|
| 526 | *---------------------------------------------------------------------- |
---|
| 527 | * |
---|
| 528 | * TclGetBgErrorHandler -- |
---|
| 529 | * |
---|
| 530 | * This function retrieves the command prefix currently used to handle |
---|
| 531 | * background errors in interp. |
---|
| 532 | * |
---|
| 533 | * Results: |
---|
| 534 | * A (Tcl_Obj *) to a list of words (command prefix). |
---|
| 535 | * |
---|
| 536 | * Side effects: |
---|
| 537 | * None. |
---|
| 538 | * |
---|
| 539 | *---------------------------------------------------------------------- |
---|
| 540 | */ |
---|
| 541 | |
---|
| 542 | Tcl_Obj * |
---|
| 543 | TclGetBgErrorHandler( |
---|
| 544 | Tcl_Interp *interp) |
---|
| 545 | { |
---|
| 546 | ErrAssocData *assocPtr = (ErrAssocData *) |
---|
| 547 | Tcl_GetAssocData(interp, "tclBgError", NULL); |
---|
| 548 | |
---|
| 549 | if (assocPtr == NULL) { |
---|
| 550 | Tcl_Obj *bgerrorObj; |
---|
| 551 | |
---|
| 552 | TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror"); |
---|
| 553 | TclSetBgErrorHandler(interp, bgerrorObj); |
---|
| 554 | assocPtr = (ErrAssocData *) |
---|
| 555 | Tcl_GetAssocData(interp, "tclBgError", NULL); |
---|
| 556 | } |
---|
| 557 | return assocPtr->cmdPrefix; |
---|
| 558 | } |
---|
| 559 | |
---|
| 560 | /* |
---|
| 561 | *---------------------------------------------------------------------- |
---|
| 562 | * |
---|
| 563 | * BgErrorDeleteProc -- |
---|
| 564 | * |
---|
| 565 | * This function is associated with the "tclBgError" assoc data for an |
---|
| 566 | * interpreter; it is invoked when the interpreter is deleted in order to |
---|
| 567 | * free the information assoicated with any pending error reports. |
---|
| 568 | * |
---|
| 569 | * Results: |
---|
| 570 | * None. |
---|
| 571 | * |
---|
| 572 | * Side effects: |
---|
| 573 | * Background error information is freed: if there were any pending error |
---|
| 574 | * reports, they are cancelled. |
---|
| 575 | * |
---|
| 576 | *---------------------------------------------------------------------- |
---|
| 577 | */ |
---|
| 578 | |
---|
| 579 | static void |
---|
| 580 | BgErrorDeleteProc( |
---|
| 581 | ClientData clientData, /* Pointer to ErrAssocData structure. */ |
---|
| 582 | Tcl_Interp *interp) /* Interpreter being deleted. */ |
---|
| 583 | { |
---|
| 584 | ErrAssocData *assocPtr = (ErrAssocData *) clientData; |
---|
| 585 | BgError *errPtr; |
---|
| 586 | |
---|
| 587 | while (assocPtr->firstBgPtr != NULL) { |
---|
| 588 | errPtr = assocPtr->firstBgPtr; |
---|
| 589 | assocPtr->firstBgPtr = errPtr->nextPtr; |
---|
| 590 | Tcl_DecrRefCount(errPtr->errorMsg); |
---|
| 591 | Tcl_DecrRefCount(errPtr->returnOpts); |
---|
| 592 | ckfree((char *) errPtr); |
---|
| 593 | } |
---|
| 594 | Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr); |
---|
| 595 | Tcl_DecrRefCount(assocPtr->cmdPrefix); |
---|
| 596 | Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC); |
---|
| 597 | } |
---|
| 598 | |
---|
| 599 | /* |
---|
| 600 | *---------------------------------------------------------------------- |
---|
| 601 | * |
---|
| 602 | * Tcl_CreateExitHandler -- |
---|
| 603 | * |
---|
| 604 | * Arrange for a given function to be invoked just before the application |
---|
| 605 | * exits. |
---|
| 606 | * |
---|
| 607 | * Results: |
---|
| 608 | * None. |
---|
| 609 | * |
---|
| 610 | * Side effects: |
---|
| 611 | * Proc will be invoked with clientData as argument when the application |
---|
| 612 | * exits. |
---|
| 613 | * |
---|
| 614 | *---------------------------------------------------------------------- |
---|
| 615 | */ |
---|
| 616 | |
---|
| 617 | void |
---|
| 618 | Tcl_CreateExitHandler( |
---|
| 619 | Tcl_ExitProc *proc, /* Function to invoke. */ |
---|
| 620 | ClientData clientData) /* Arbitrary value to pass to proc. */ |
---|
| 621 | { |
---|
| 622 | ExitHandler *exitPtr; |
---|
| 623 | |
---|
| 624 | exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); |
---|
| 625 | exitPtr->proc = proc; |
---|
| 626 | exitPtr->clientData = clientData; |
---|
| 627 | Tcl_MutexLock(&exitMutex); |
---|
| 628 | exitPtr->nextPtr = firstExitPtr; |
---|
| 629 | firstExitPtr = exitPtr; |
---|
| 630 | Tcl_MutexUnlock(&exitMutex); |
---|
| 631 | } |
---|
| 632 | |
---|
| 633 | /* |
---|
| 634 | *---------------------------------------------------------------------- |
---|
| 635 | * |
---|
| 636 | * Tcl_DeleteExitHandler -- |
---|
| 637 | * |
---|
| 638 | * This function cancels an existing exit handler matching proc and |
---|
| 639 | * clientData, if such a handler exits. |
---|
| 640 | * |
---|
| 641 | * Results: |
---|
| 642 | * None. |
---|
| 643 | * |
---|
| 644 | * Side effects: |
---|
| 645 | * If there is an exit handler corresponding to proc and clientData then |
---|
| 646 | * it is cancelled; if no such handler exists then nothing happens. |
---|
| 647 | * |
---|
| 648 | *---------------------------------------------------------------------- |
---|
| 649 | */ |
---|
| 650 | |
---|
| 651 | void |
---|
| 652 | Tcl_DeleteExitHandler( |
---|
| 653 | Tcl_ExitProc *proc, /* Function that was previously registered. */ |
---|
| 654 | ClientData clientData) /* Arbitrary value to pass to proc. */ |
---|
| 655 | { |
---|
| 656 | ExitHandler *exitPtr, *prevPtr; |
---|
| 657 | |
---|
| 658 | Tcl_MutexLock(&exitMutex); |
---|
| 659 | for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL; |
---|
| 660 | prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { |
---|
| 661 | if ((exitPtr->proc == proc) |
---|
| 662 | && (exitPtr->clientData == clientData)) { |
---|
| 663 | if (prevPtr == NULL) { |
---|
| 664 | firstExitPtr = exitPtr->nextPtr; |
---|
| 665 | } else { |
---|
| 666 | prevPtr->nextPtr = exitPtr->nextPtr; |
---|
| 667 | } |
---|
| 668 | ckfree((char *) exitPtr); |
---|
| 669 | break; |
---|
| 670 | } |
---|
| 671 | } |
---|
| 672 | Tcl_MutexUnlock(&exitMutex); |
---|
| 673 | return; |
---|
| 674 | } |
---|
| 675 | |
---|
| 676 | /* |
---|
| 677 | *---------------------------------------------------------------------- |
---|
| 678 | * |
---|
| 679 | * Tcl_CreateThreadExitHandler -- |
---|
| 680 | * |
---|
| 681 | * Arrange for a given function to be invoked just before the current |
---|
| 682 | * thread exits. |
---|
| 683 | * |
---|
| 684 | * Results: |
---|
| 685 | * None. |
---|
| 686 | * |
---|
| 687 | * Side effects: |
---|
| 688 | * Proc will be invoked with clientData as argument when the application |
---|
| 689 | * exits. |
---|
| 690 | * |
---|
| 691 | *---------------------------------------------------------------------- |
---|
| 692 | */ |
---|
| 693 | |
---|
| 694 | void |
---|
| 695 | Tcl_CreateThreadExitHandler( |
---|
| 696 | Tcl_ExitProc *proc, /* Function to invoke. */ |
---|
| 697 | ClientData clientData) /* Arbitrary value to pass to proc. */ |
---|
| 698 | { |
---|
| 699 | ExitHandler *exitPtr; |
---|
| 700 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
---|
| 701 | |
---|
| 702 | exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler)); |
---|
| 703 | exitPtr->proc = proc; |
---|
| 704 | exitPtr->clientData = clientData; |
---|
| 705 | exitPtr->nextPtr = tsdPtr->firstExitPtr; |
---|
| 706 | tsdPtr->firstExitPtr = exitPtr; |
---|
| 707 | } |
---|
| 708 | |
---|
| 709 | /* |
---|
| 710 | *---------------------------------------------------------------------- |
---|
| 711 | * |
---|
| 712 | * Tcl_DeleteThreadExitHandler -- |
---|
| 713 | * |
---|
| 714 | * This function cancels an existing exit handler matching proc and |
---|
| 715 | * clientData, if such a handler exits. |
---|
| 716 | * |
---|
| 717 | * Results: |
---|
| 718 | * None. |
---|
| 719 | * |
---|
| 720 | * Side effects: |
---|
| 721 | * If there is an exit handler corresponding to proc and clientData then |
---|
| 722 | * it is cancelled; if no such handler exists then nothing happens. |
---|
| 723 | * |
---|
| 724 | *---------------------------------------------------------------------- |
---|
| 725 | */ |
---|
| 726 | |
---|
| 727 | void |
---|
| 728 | Tcl_DeleteThreadExitHandler( |
---|
| 729 | Tcl_ExitProc *proc, /* Function that was previously registered. */ |
---|
| 730 | ClientData clientData) /* Arbitrary value to pass to proc. */ |
---|
| 731 | { |
---|
| 732 | ExitHandler *exitPtr, *prevPtr; |
---|
| 733 | ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
---|
| 734 | |
---|
| 735 | for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; |
---|
| 736 | prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) { |
---|
| 737 | if ((exitPtr->proc == proc) |
---|
| 738 | && (exitPtr->clientData == clientData)) { |
---|
| 739 | if (prevPtr == NULL) { |
---|
| 740 | tsdPtr->firstExitPtr = exitPtr->nextPtr; |
---|
| 741 | } else { |
---|
| 742 | prevPtr->nextPtr = exitPtr->nextPtr; |
---|
| 743 | } |
---|
| 744 | ckfree((char *) exitPtr); |
---|
| 745 | return; |
---|
| 746 | } |
---|
| 747 | } |
---|
| 748 | } |
---|
| 749 | |
---|
| 750 | /* |
---|
| 751 | *---------------------------------------------------------------------- |
---|
| 752 | * |
---|
| 753 | * Tcl_SetExitProc -- |
---|
| 754 | * |
---|
| 755 | * This function sets the application wide exit handler that will be |
---|
| 756 | * called by Tcl_Exit in place of the C-runtime exit. If the application |
---|
| 757 | * wide exit handler is NULL, the C-runtime exit will be used instead. |
---|
| 758 | * |
---|
| 759 | * Results: |
---|
| 760 | * The previously set application wide exit handler. |
---|
| 761 | * |
---|
| 762 | * Side effects: |
---|
| 763 | * Sets the application wide exit handler to the specified value. |
---|
| 764 | * |
---|
| 765 | *---------------------------------------------------------------------- |
---|
| 766 | */ |
---|
| 767 | |
---|
| 768 | Tcl_ExitProc * |
---|
| 769 | Tcl_SetExitProc( |
---|
| 770 | Tcl_ExitProc *proc) /* New exit handler for app or NULL */ |
---|
| 771 | { |
---|
| 772 | Tcl_ExitProc *prevExitProc; |
---|
| 773 | |
---|
| 774 | /* |
---|
| 775 | * Swap the old exit proc for the new one, saving the old one for our |
---|
| 776 | * return value. |
---|
| 777 | */ |
---|
| 778 | |
---|
| 779 | Tcl_MutexLock(&exitMutex); |
---|
| 780 | prevExitProc = appExitPtr; |
---|
| 781 | appExitPtr = proc; |
---|
| 782 | Tcl_MutexUnlock(&exitMutex); |
---|
| 783 | |
---|
| 784 | return prevExitProc; |
---|
| 785 | } |
---|
| 786 | |
---|
| 787 | /* |
---|
| 788 | *---------------------------------------------------------------------- |
---|
| 789 | * |
---|
| 790 | * Tcl_Exit -- |
---|
| 791 | * |
---|
| 792 | * This function is called to terminate the application. |
---|
| 793 | * |
---|
| 794 | * Results: |
---|
| 795 | * None. |
---|
| 796 | * |
---|
| 797 | * Side effects: |
---|
| 798 | * All existing exit handlers are invoked, then the application ends. |
---|
| 799 | * |
---|
| 800 | *---------------------------------------------------------------------- |
---|
| 801 | */ |
---|
| 802 | |
---|
| 803 | void |
---|
| 804 | Tcl_Exit( |
---|
| 805 | int status) /* Exit status for application; typically 0 |
---|
| 806 | * for normal return, 1 for error return. */ |
---|
| 807 | { |
---|
| 808 | Tcl_ExitProc *currentAppExitPtr; |
---|
| 809 | |
---|
| 810 | Tcl_MutexLock(&exitMutex); |
---|
| 811 | currentAppExitPtr = appExitPtr; |
---|
| 812 | Tcl_MutexUnlock(&exitMutex); |
---|
| 813 | |
---|
| 814 | if (currentAppExitPtr) { |
---|
| 815 | /* |
---|
| 816 | * Warning: this code SHOULD NOT return, as there is code that depends |
---|
| 817 | * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone |
---|
| 818 | * returns, so critical is this dependcy. |
---|
| 819 | */ |
---|
| 820 | |
---|
| 821 | currentAppExitPtr((ClientData) INT2PTR(status)); |
---|
| 822 | Tcl_Panic("AppExitProc returned unexpectedly"); |
---|
| 823 | } else { |
---|
| 824 | /* |
---|
| 825 | * Use default handling. |
---|
| 826 | */ |
---|
| 827 | |
---|
| 828 | Tcl_Finalize(); |
---|
| 829 | TclpExit(status); |
---|
| 830 | Tcl_Panic("OS exit failed!"); |
---|
| 831 | } |
---|
| 832 | } |
---|
| 833 | |
---|
| 834 | /* |
---|
| 835 | *------------------------------------------------------------------------- |
---|
| 836 | * |
---|
| 837 | * TclInitSubsystems -- |
---|
| 838 | * |
---|
| 839 | * Initialize various subsytems in Tcl. This should be called the first |
---|
| 840 | * time an interp is created, or before any of the subsystems are used. |
---|
| 841 | * This function ensures an order for the initialization of subsystems: |
---|
| 842 | * |
---|
| 843 | * 1. that cannot be initialized in lazy order because they are mutually |
---|
| 844 | * dependent. |
---|
| 845 | * |
---|
| 846 | * 2. so that they can be finalized in a known order w/o causing the |
---|
| 847 | * subsequent re-initialization of a subsystem in the act of shutting |
---|
| 848 | * down another. |
---|
| 849 | * |
---|
| 850 | * Results: |
---|
| 851 | * None. |
---|
| 852 | * |
---|
| 853 | * Side effects: |
---|
| 854 | * Varied, see the respective initialization routines. |
---|
| 855 | * |
---|
| 856 | *------------------------------------------------------------------------- |
---|
| 857 | */ |
---|
| 858 | |
---|
| 859 | void |
---|
| 860 | TclInitSubsystems(void) |
---|
| 861 | { |
---|
| 862 | if (inFinalize != 0) { |
---|
| 863 | Tcl_Panic("TclInitSubsystems called while finalizing"); |
---|
| 864 | } |
---|
| 865 | |
---|
| 866 | if (subsystemsInitialized == 0) { |
---|
| 867 | /* |
---|
| 868 | * Double check inside the mutex. There are definitly calls back into |
---|
| 869 | * this routine from some of the functions below. |
---|
| 870 | */ |
---|
| 871 | |
---|
| 872 | TclpInitLock(); |
---|
| 873 | if (subsystemsInitialized == 0) { |
---|
| 874 | /* |
---|
| 875 | * Have to set this bit here to avoid deadlock with the routines |
---|
| 876 | * below us that call into TclInitSubsystems. |
---|
| 877 | */ |
---|
| 878 | |
---|
| 879 | subsystemsInitialized = 1; |
---|
| 880 | |
---|
| 881 | /* |
---|
| 882 | * Initialize locks used by the memory allocators before anything |
---|
| 883 | * interesting happens so we can use the allocators in the |
---|
| 884 | * implementation of self-initializing locks. |
---|
| 885 | */ |
---|
| 886 | |
---|
| 887 | TclInitThreadStorage(); /* Creates master hash table for |
---|
| 888 | * thread local storage */ |
---|
| 889 | #if USE_TCLALLOC |
---|
| 890 | TclInitAlloc(); /* Process wide mutex init */ |
---|
| 891 | #endif |
---|
| 892 | #ifdef TCL_MEM_DEBUG |
---|
| 893 | TclInitDbCkalloc(); /* Process wide mutex init */ |
---|
| 894 | #endif |
---|
| 895 | |
---|
| 896 | TclpInitPlatform(); /* Creates signal handler(s) */ |
---|
| 897 | TclInitDoubleConversion(); /* Initializes constants for |
---|
| 898 | * converting to/from double. */ |
---|
| 899 | TclInitObjSubsystem(); /* Register obj types, create |
---|
| 900 | * mutexes. */ |
---|
| 901 | TclInitIOSubsystem(); /* Inits a tsd key (noop). */ |
---|
| 902 | TclInitEncodingSubsystem(); /* Process wide encoding init. */ |
---|
| 903 | TclpSetInterfaces(); |
---|
| 904 | TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ |
---|
| 905 | } |
---|
| 906 | TclpInitUnlock(); |
---|
| 907 | } |
---|
| 908 | TclInitNotifier(); |
---|
| 909 | } |
---|
| 910 | |
---|
| 911 | /* |
---|
| 912 | *---------------------------------------------------------------------- |
---|
| 913 | * |
---|
| 914 | * Tcl_Finalize -- |
---|
| 915 | * |
---|
| 916 | * Shut down Tcl. First calls registered exit handlers, then carefully |
---|
| 917 | * shuts down various subsystems. Called by Tcl_Exit or when the Tcl |
---|
| 918 | * shared library is being unloaded. |
---|
| 919 | * |
---|
| 920 | * Results: |
---|
| 921 | * None. |
---|
| 922 | * |
---|
| 923 | * Side effects: |
---|
| 924 | * Varied, see the respective finalization routines. |
---|
| 925 | * |
---|
| 926 | *---------------------------------------------------------------------- |
---|
| 927 | */ |
---|
| 928 | |
---|
| 929 | void |
---|
| 930 | Tcl_Finalize(void) |
---|
| 931 | { |
---|
| 932 | ExitHandler *exitPtr; |
---|
| 933 | |
---|
| 934 | /* |
---|
| 935 | * Invoke exit handlers first. |
---|
| 936 | */ |
---|
| 937 | |
---|
| 938 | Tcl_MutexLock(&exitMutex); |
---|
| 939 | inFinalize = 1; |
---|
| 940 | for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { |
---|
| 941 | /* |
---|
| 942 | * Be careful to remove the handler from the list before invoking its |
---|
| 943 | * callback. This protects us against double-freeing if the callback |
---|
| 944 | * should call Tcl_DeleteExitHandler on itself. |
---|
| 945 | */ |
---|
| 946 | |
---|
| 947 | firstExitPtr = exitPtr->nextPtr; |
---|
| 948 | Tcl_MutexUnlock(&exitMutex); |
---|
| 949 | (*exitPtr->proc)(exitPtr->clientData); |
---|
| 950 | ckfree((char *) exitPtr); |
---|
| 951 | Tcl_MutexLock(&exitMutex); |
---|
| 952 | } |
---|
| 953 | firstExitPtr = NULL; |
---|
| 954 | Tcl_MutexUnlock(&exitMutex); |
---|
| 955 | |
---|
| 956 | TclpInitLock(); |
---|
| 957 | if (subsystemsInitialized == 0) { |
---|
| 958 | goto alreadyFinalized; |
---|
| 959 | } |
---|
| 960 | subsystemsInitialized = 0; |
---|
| 961 | |
---|
| 962 | /* |
---|
| 963 | * Ensure the thread-specific data is initialised as it is used in |
---|
| 964 | * Tcl_FinalizeThread() |
---|
| 965 | */ |
---|
| 966 | |
---|
| 967 | (void) TCL_TSD_INIT(&dataKey); |
---|
| 968 | |
---|
| 969 | /* |
---|
| 970 | * Clean up after the current thread now, after exit handlers. In |
---|
| 971 | * particular, the testexithandler command sets up something that writes |
---|
| 972 | * to standard output, which gets closed. Note that there is no |
---|
| 973 | * thread-local storage or IO subsystem after this call. |
---|
| 974 | */ |
---|
| 975 | |
---|
| 976 | Tcl_FinalizeThread(); |
---|
| 977 | |
---|
| 978 | /* |
---|
| 979 | * Now finalize the Tcl execution environment. Note that this must be done |
---|
| 980 | * after the exit handlers, because there are order dependencies. |
---|
| 981 | */ |
---|
| 982 | |
---|
| 983 | TclFinalizeExecution(); |
---|
| 984 | TclFinalizeEnvironment(); |
---|
| 985 | |
---|
| 986 | /* |
---|
| 987 | * Finalizing the filesystem must come after anything which might |
---|
| 988 | * conceivably interact with the 'Tcl_FS' API. |
---|
| 989 | */ |
---|
| 990 | |
---|
| 991 | TclFinalizeFilesystem(); |
---|
| 992 | |
---|
| 993 | /* |
---|
| 994 | * Undo all Tcl_ObjType registrations, and reset the master list of free |
---|
| 995 | * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or |
---|
| 996 | * freed. |
---|
| 997 | * |
---|
| 998 | * Note in particular that TclFinalizeObjects() must follow |
---|
| 999 | * TclFinalizeFilesystem() because TclFinalizeFilesystem free's the |
---|
| 1000 | * Tcl_Obj that holds the path of the current working directory. |
---|
| 1001 | */ |
---|
| 1002 | |
---|
| 1003 | TclFinalizeObjects(); |
---|
| 1004 | |
---|
| 1005 | /* |
---|
| 1006 | * We must be sure the encoding finalization doesn't need to examine the |
---|
| 1007 | * filesystem in any way. Since it only needs to clean up internal data |
---|
| 1008 | * structures, this is fine. |
---|
| 1009 | */ |
---|
| 1010 | |
---|
| 1011 | TclFinalizeEncodingSubsystem(); |
---|
| 1012 | |
---|
| 1013 | Tcl_SetPanicProc(NULL); |
---|
| 1014 | |
---|
| 1015 | /* |
---|
| 1016 | * Repeat finalization of the thread local storage once more. Although |
---|
| 1017 | * this step is already done by the Tcl_FinalizeThread call above, series |
---|
| 1018 | * of events happening afterwards may re-initialize TSD slots. Those need |
---|
| 1019 | * to be finalized again, otherwise we're leaking memory chunks. Very |
---|
| 1020 | * important to note is that things happening afterwards should not |
---|
| 1021 | * reference anything which may re-initialize TSD's. This includes freeing |
---|
| 1022 | * Tcl_Objs's, among other things. |
---|
| 1023 | * |
---|
| 1024 | * This fixes the Tcl Bug #990552. |
---|
| 1025 | */ |
---|
| 1026 | |
---|
| 1027 | TclFinalizeThreadData(); |
---|
| 1028 | |
---|
| 1029 | /* |
---|
| 1030 | * Now we can free constants for conversions to/from double. |
---|
| 1031 | */ |
---|
| 1032 | |
---|
| 1033 | TclFinalizeDoubleConversion(); |
---|
| 1034 | |
---|
| 1035 | /* |
---|
| 1036 | * There have been several bugs in the past that cause exit handlers to be |
---|
| 1037 | * established during Tcl_Finalize processing. Such exit handlers leave |
---|
| 1038 | * malloc'ed memory, and Tcl_FinalizeThreadAlloc or |
---|
| 1039 | * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result |
---|
| 1040 | * can be a mysterious crash on process exit. Check here that nobody's |
---|
| 1041 | * done this. |
---|
| 1042 | */ |
---|
| 1043 | |
---|
| 1044 | if (firstExitPtr != NULL) { |
---|
| 1045 | Tcl_Panic("exit handlers were created during Tcl_Finalize"); |
---|
| 1046 | } |
---|
| 1047 | |
---|
| 1048 | TclFinalizePreserve(); |
---|
| 1049 | |
---|
| 1050 | /* |
---|
| 1051 | * Free synchronization objects. There really should only be one thread |
---|
| 1052 | * alive at this moment. |
---|
| 1053 | */ |
---|
| 1054 | |
---|
| 1055 | TclFinalizeSynchronization(); |
---|
| 1056 | |
---|
| 1057 | /* |
---|
| 1058 | * Close down the thread-specific object allocator. |
---|
| 1059 | */ |
---|
| 1060 | |
---|
| 1061 | #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) |
---|
| 1062 | TclFinalizeThreadAlloc(); |
---|
| 1063 | #endif |
---|
| 1064 | |
---|
| 1065 | /* |
---|
| 1066 | * We defer unloading of packages until very late to avoid memory access |
---|
| 1067 | * issues. Both exit callbacks and synchronization variables may be stored |
---|
| 1068 | * in packages. |
---|
| 1069 | * |
---|
| 1070 | * Note that TclFinalizeLoad unloads packages in the reverse of the order |
---|
| 1071 | * they were loaded in (i.e. last to be loaded is the first to be |
---|
| 1072 | * unloaded). This can be important for correct unloading when |
---|
| 1073 | * dependencies exist. |
---|
| 1074 | * |
---|
| 1075 | * Once load has been finalized, we will have deleted any temporary copies |
---|
| 1076 | * of shared libraries and can therefore reset the filesystem to its |
---|
| 1077 | * original state. |
---|
| 1078 | */ |
---|
| 1079 | |
---|
| 1080 | TclFinalizeLoad(); |
---|
| 1081 | TclResetFilesystem(); |
---|
| 1082 | |
---|
| 1083 | /* |
---|
| 1084 | * At this point, there should no longer be any ckalloc'ed memory. |
---|
| 1085 | */ |
---|
| 1086 | |
---|
| 1087 | TclFinalizeMemorySubsystem(); |
---|
| 1088 | inFinalize = 0; |
---|
| 1089 | |
---|
| 1090 | alreadyFinalized: |
---|
| 1091 | TclFinalizeLock(); |
---|
| 1092 | } |
---|
| 1093 | |
---|
| 1094 | /* |
---|
| 1095 | *---------------------------------------------------------------------- |
---|
| 1096 | * |
---|
| 1097 | * Tcl_FinalizeThread -- |
---|
| 1098 | * |
---|
| 1099 | * Runs the exit handlers to allow Tcl to clean up its state about a |
---|
| 1100 | * particular thread. |
---|
| 1101 | * |
---|
| 1102 | * Results: |
---|
| 1103 | * None. |
---|
| 1104 | * |
---|
| 1105 | * Side effects: |
---|
| 1106 | * Varied, see the respective finalization routines. |
---|
| 1107 | * |
---|
| 1108 | *---------------------------------------------------------------------- |
---|
| 1109 | */ |
---|
| 1110 | |
---|
| 1111 | void |
---|
| 1112 | Tcl_FinalizeThread(void) |
---|
| 1113 | { |
---|
| 1114 | ExitHandler *exitPtr; |
---|
| 1115 | ThreadSpecificData *tsdPtr; |
---|
| 1116 | |
---|
| 1117 | /* |
---|
| 1118 | * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because |
---|
| 1119 | * we don't want to initialize the data block if it hasn't been |
---|
| 1120 | * initialized already. |
---|
| 1121 | */ |
---|
| 1122 | |
---|
| 1123 | tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); |
---|
| 1124 | if (tsdPtr != NULL) { |
---|
| 1125 | tsdPtr->inExit = 1; |
---|
| 1126 | |
---|
| 1127 | for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; |
---|
| 1128 | exitPtr = tsdPtr->firstExitPtr) { |
---|
| 1129 | /* |
---|
| 1130 | * Be careful to remove the handler from the list before invoking |
---|
| 1131 | * its callback. This protects us against double-freeing if the |
---|
| 1132 | * callback should call Tcl_DeleteThreadExitHandler on itself. |
---|
| 1133 | */ |
---|
| 1134 | |
---|
| 1135 | tsdPtr->firstExitPtr = exitPtr->nextPtr; |
---|
| 1136 | (*exitPtr->proc)(exitPtr->clientData); |
---|
| 1137 | ckfree((char *) exitPtr); |
---|
| 1138 | } |
---|
| 1139 | TclFinalizeIOSubsystem(); |
---|
| 1140 | TclFinalizeNotifier(); |
---|
| 1141 | TclFinalizeAsync(); |
---|
| 1142 | } |
---|
| 1143 | |
---|
| 1144 | /* |
---|
| 1145 | * Blow away all thread local storage blocks. |
---|
| 1146 | * |
---|
| 1147 | * Note that Tcl API allows creation of threads which do not use any Tcl |
---|
| 1148 | * interp or other Tcl subsytems. Those threads might, however, use thread |
---|
| 1149 | * local storage, so we must unconditionally finalize it. |
---|
| 1150 | * |
---|
| 1151 | * Fix [Bug #571002] |
---|
| 1152 | */ |
---|
| 1153 | |
---|
| 1154 | TclFinalizeThreadData(); |
---|
| 1155 | } |
---|
| 1156 | |
---|
| 1157 | /* |
---|
| 1158 | *---------------------------------------------------------------------- |
---|
| 1159 | * |
---|
| 1160 | * TclInExit -- |
---|
| 1161 | * |
---|
| 1162 | * Determines if we are in the middle of exit-time cleanup. |
---|
| 1163 | * |
---|
| 1164 | * Results: |
---|
| 1165 | * If we are in the middle of exiting, 1, otherwise 0. |
---|
| 1166 | * |
---|
| 1167 | * Side effects: |
---|
| 1168 | * None. |
---|
| 1169 | * |
---|
| 1170 | *---------------------------------------------------------------------- |
---|
| 1171 | */ |
---|
| 1172 | |
---|
| 1173 | int |
---|
| 1174 | TclInExit(void) |
---|
| 1175 | { |
---|
| 1176 | return inFinalize; |
---|
| 1177 | } |
---|
| 1178 | |
---|
| 1179 | /* |
---|
| 1180 | *---------------------------------------------------------------------- |
---|
| 1181 | * |
---|
| 1182 | * TclInThreadExit -- |
---|
| 1183 | * |
---|
| 1184 | * Determines if we are in the middle of thread exit-time cleanup. |
---|
| 1185 | * |
---|
| 1186 | * Results: |
---|
| 1187 | * If we are in the middle of exiting this thread, 1, otherwise 0. |
---|
| 1188 | * |
---|
| 1189 | * Side effects: |
---|
| 1190 | * None. |
---|
| 1191 | * |
---|
| 1192 | *---------------------------------------------------------------------- |
---|
| 1193 | */ |
---|
| 1194 | |
---|
| 1195 | int |
---|
| 1196 | TclInThreadExit(void) |
---|
| 1197 | { |
---|
| 1198 | ThreadSpecificData *tsdPtr = (ThreadSpecificData *) |
---|
| 1199 | TclThreadDataKeyGet(&dataKey); |
---|
| 1200 | if (tsdPtr == NULL) { |
---|
| 1201 | return 0; |
---|
| 1202 | } else { |
---|
| 1203 | return tsdPtr->inExit; |
---|
| 1204 | } |
---|
| 1205 | } |
---|
| 1206 | |
---|
| 1207 | /* |
---|
| 1208 | *---------------------------------------------------------------------- |
---|
| 1209 | * |
---|
| 1210 | * Tcl_VwaitObjCmd -- |
---|
| 1211 | * |
---|
| 1212 | * This function is invoked to process the "vwait" Tcl command. See the |
---|
| 1213 | * user documentation for details on what it does. |
---|
| 1214 | * |
---|
| 1215 | * Results: |
---|
| 1216 | * A standard Tcl result. |
---|
| 1217 | * |
---|
| 1218 | * Side effects: |
---|
| 1219 | * See the user documentation. |
---|
| 1220 | * |
---|
| 1221 | *---------------------------------------------------------------------- |
---|
| 1222 | */ |
---|
| 1223 | |
---|
| 1224 | /* ARGSUSED */ |
---|
| 1225 | int |
---|
| 1226 | Tcl_VwaitObjCmd( |
---|
| 1227 | ClientData clientData, /* Not used. */ |
---|
| 1228 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1229 | int objc, /* Number of arguments. */ |
---|
| 1230 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 1231 | { |
---|
| 1232 | int done, foundEvent; |
---|
| 1233 | char *nameString; |
---|
| 1234 | |
---|
| 1235 | if (objc != 2) { |
---|
| 1236 | Tcl_WrongNumArgs(interp, 1, objv, "name"); |
---|
| 1237 | return TCL_ERROR; |
---|
| 1238 | } |
---|
| 1239 | nameString = Tcl_GetString(objv[1]); |
---|
| 1240 | if (Tcl_TraceVar(interp, nameString, |
---|
| 1241 | TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, |
---|
| 1242 | VwaitVarProc, (ClientData) &done) != TCL_OK) { |
---|
| 1243 | return TCL_ERROR; |
---|
| 1244 | }; |
---|
| 1245 | done = 0; |
---|
| 1246 | foundEvent = 1; |
---|
| 1247 | while (!done && foundEvent) { |
---|
| 1248 | foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS); |
---|
| 1249 | if (Tcl_LimitExceeded(interp)) { |
---|
| 1250 | break; |
---|
| 1251 | } |
---|
| 1252 | } |
---|
| 1253 | Tcl_UntraceVar(interp, nameString, |
---|
| 1254 | TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, |
---|
| 1255 | VwaitVarProc, (ClientData) &done); |
---|
| 1256 | |
---|
| 1257 | /* |
---|
| 1258 | * Clear out the interpreter's result, since it may have been set by event |
---|
| 1259 | * handlers. |
---|
| 1260 | */ |
---|
| 1261 | |
---|
| 1262 | Tcl_ResetResult(interp); |
---|
| 1263 | if (!foundEvent) { |
---|
| 1264 | Tcl_AppendResult(interp, "can't wait for variable \"", nameString, |
---|
| 1265 | "\": would wait forever", NULL); |
---|
| 1266 | return TCL_ERROR; |
---|
| 1267 | } |
---|
| 1268 | if (!done) { |
---|
| 1269 | Tcl_AppendResult(interp, "limit exceeded", NULL); |
---|
| 1270 | return TCL_ERROR; |
---|
| 1271 | } |
---|
| 1272 | return TCL_OK; |
---|
| 1273 | } |
---|
| 1274 | |
---|
| 1275 | /* ARGSUSED */ |
---|
| 1276 | static char * |
---|
| 1277 | VwaitVarProc( |
---|
| 1278 | ClientData clientData, /* Pointer to integer to set to 1. */ |
---|
| 1279 | Tcl_Interp *interp, /* Interpreter containing variable. */ |
---|
| 1280 | CONST char *name1, /* Name of variable. */ |
---|
| 1281 | CONST char *name2, /* Second part of variable name. */ |
---|
| 1282 | int flags) /* Information about what happened. */ |
---|
| 1283 | { |
---|
| 1284 | int *donePtr = (int *) clientData; |
---|
| 1285 | |
---|
| 1286 | *donePtr = 1; |
---|
| 1287 | return NULL; |
---|
| 1288 | } |
---|
| 1289 | |
---|
| 1290 | /* |
---|
| 1291 | *---------------------------------------------------------------------- |
---|
| 1292 | * |
---|
| 1293 | * Tcl_UpdateObjCmd -- |
---|
| 1294 | * |
---|
| 1295 | * This function is invoked to process the "update" Tcl command. See the |
---|
| 1296 | * user documentation for details on what it does. |
---|
| 1297 | * |
---|
| 1298 | * Results: |
---|
| 1299 | * A standard Tcl result. |
---|
| 1300 | * |
---|
| 1301 | * Side effects: |
---|
| 1302 | * See the user documentation. |
---|
| 1303 | * |
---|
| 1304 | *---------------------------------------------------------------------- |
---|
| 1305 | */ |
---|
| 1306 | |
---|
| 1307 | /* ARGSUSED */ |
---|
| 1308 | int |
---|
| 1309 | Tcl_UpdateObjCmd( |
---|
| 1310 | ClientData clientData, /* Not used. */ |
---|
| 1311 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
| 1312 | int objc, /* Number of arguments. */ |
---|
| 1313 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
| 1314 | { |
---|
| 1315 | int optionIndex; |
---|
| 1316 | int flags = 0; /* Initialized to avoid compiler warning. */ |
---|
| 1317 | static CONST char *updateOptions[] = {"idletasks", NULL}; |
---|
| 1318 | enum updateOptions {REGEXP_IDLETASKS}; |
---|
| 1319 | |
---|
| 1320 | if (objc == 1) { |
---|
| 1321 | flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; |
---|
| 1322 | } else if (objc == 2) { |
---|
| 1323 | if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, |
---|
| 1324 | "option", 0, &optionIndex) != TCL_OK) { |
---|
| 1325 | return TCL_ERROR; |
---|
| 1326 | } |
---|
| 1327 | switch ((enum updateOptions) optionIndex) { |
---|
| 1328 | case REGEXP_IDLETASKS: |
---|
| 1329 | flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; |
---|
| 1330 | break; |
---|
| 1331 | default: |
---|
| 1332 | Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); |
---|
| 1333 | } |
---|
| 1334 | } else { |
---|
| 1335 | Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); |
---|
| 1336 | return TCL_ERROR; |
---|
| 1337 | } |
---|
| 1338 | |
---|
| 1339 | while (Tcl_DoOneEvent(flags) != 0) { |
---|
| 1340 | if (Tcl_LimitExceeded(interp)) { |
---|
| 1341 | Tcl_ResetResult(interp); |
---|
| 1342 | Tcl_AppendResult(interp, "limit exceeded", NULL); |
---|
| 1343 | return TCL_ERROR; |
---|
| 1344 | } |
---|
| 1345 | } |
---|
| 1346 | |
---|
| 1347 | /* |
---|
| 1348 | * Must clear the interpreter's result because event handlers could have |
---|
| 1349 | * executed commands. |
---|
| 1350 | */ |
---|
| 1351 | |
---|
| 1352 | Tcl_ResetResult(interp); |
---|
| 1353 | return TCL_OK; |
---|
| 1354 | } |
---|
| 1355 | |
---|
| 1356 | #ifdef TCL_THREADS |
---|
| 1357 | /* |
---|
| 1358 | *----------------------------------------------------------------------------- |
---|
| 1359 | * |
---|
| 1360 | * NewThreadProc -- |
---|
| 1361 | * |
---|
| 1362 | * Bootstrap function of a new Tcl thread. |
---|
| 1363 | * |
---|
| 1364 | * Results: |
---|
| 1365 | * None. |
---|
| 1366 | * |
---|
| 1367 | * Side Effects: |
---|
| 1368 | * Initializes Tcl notifier for the current thread. |
---|
| 1369 | * |
---|
| 1370 | *----------------------------------------------------------------------------- |
---|
| 1371 | */ |
---|
| 1372 | |
---|
| 1373 | static Tcl_ThreadCreateType |
---|
| 1374 | NewThreadProc( |
---|
| 1375 | ClientData clientData) |
---|
| 1376 | { |
---|
| 1377 | ThreadClientData *cdPtr; |
---|
| 1378 | ClientData threadClientData; |
---|
| 1379 | Tcl_ThreadCreateProc *threadProc; |
---|
| 1380 | |
---|
| 1381 | cdPtr = (ThreadClientData *) clientData; |
---|
| 1382 | threadProc = cdPtr->proc; |
---|
| 1383 | threadClientData = cdPtr->clientData; |
---|
| 1384 | ckfree((char *) clientData); /* Allocated in Tcl_CreateThread() */ |
---|
| 1385 | |
---|
| 1386 | (*threadProc)(threadClientData); |
---|
| 1387 | |
---|
| 1388 | TCL_THREAD_CREATE_RETURN; |
---|
| 1389 | } |
---|
| 1390 | #endif |
---|
| 1391 | |
---|
| 1392 | /* |
---|
| 1393 | *---------------------------------------------------------------------- |
---|
| 1394 | * |
---|
| 1395 | * Tcl_CreateThread -- |
---|
| 1396 | * |
---|
| 1397 | * This function creates a new thread. This actually belongs to the |
---|
| 1398 | * tclThread.c file but since we use some private data structures local |
---|
| 1399 | * to this file, it is placed here. |
---|
| 1400 | * |
---|
| 1401 | * Results: |
---|
| 1402 | * TCL_OK if the thread could be created. The thread ID is returned in a |
---|
| 1403 | * parameter. |
---|
| 1404 | * |
---|
| 1405 | * Side effects: |
---|
| 1406 | * A new thread is created. |
---|
| 1407 | * |
---|
| 1408 | *---------------------------------------------------------------------- |
---|
| 1409 | */ |
---|
| 1410 | |
---|
| 1411 | int |
---|
| 1412 | Tcl_CreateThread( |
---|
| 1413 | Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ |
---|
| 1414 | Tcl_ThreadCreateProc proc, /* Main() function of the thread */ |
---|
| 1415 | ClientData clientData, /* The one argument to Main() */ |
---|
| 1416 | int stackSize, /* Size of stack for the new thread */ |
---|
| 1417 | int flags) /* Flags controlling behaviour of the new |
---|
| 1418 | * thread. */ |
---|
| 1419 | { |
---|
| 1420 | #ifdef TCL_THREADS |
---|
| 1421 | ThreadClientData *cdPtr; |
---|
| 1422 | |
---|
| 1423 | cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData)); |
---|
| 1424 | cdPtr->proc = proc; |
---|
| 1425 | cdPtr->clientData = clientData; |
---|
| 1426 | |
---|
| 1427 | return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr, |
---|
| 1428 | stackSize, flags); |
---|
| 1429 | #else |
---|
| 1430 | return TCL_ERROR; |
---|
| 1431 | #endif /* TCL_THREADS */ |
---|
| 1432 | } |
---|
| 1433 | |
---|
| 1434 | /* |
---|
| 1435 | * Local Variables: |
---|
| 1436 | * mode: c |
---|
| 1437 | * c-basic-offset: 4 |
---|
| 1438 | * fill-column: 78 |
---|
| 1439 | * End: |
---|
| 1440 | */ |
---|