tclEvent.c

Go to the documentation of this file.
00001 /*
00002  * tclEvent.c --
00003  *
00004  *      This file implements some general event related interfaces including
00005  *      background errors, exit handlers, and the "vwait" and "update" command
00006  *      functions.
00007  *
00008  * Copyright (c) 1990-1994 The Regents of the University of California.
00009  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
00010  * Copyright (c) 2004 by Zoran Vasiljevic.
00011  *
00012  * See the file "license.terms" for information on usage and redistribution of
00013  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00014  *
00015  * RCS: @(#) $Id: tclEvent.c,v 1.78 2007/12/13 15:23:16 dgp Exp $
00016  */
00017 
00018 #include "tclInt.h"
00019 
00020 /*
00021  * The data structure below is used to report background errors. One such
00022  * structure is allocated for each error; it holds information about the
00023  * interpreter and the error until an idle handler command can be invoked.
00024  */
00025 
00026 typedef struct BgError {
00027     Tcl_Obj *errorMsg;          /* Copy of the error message (the interp's
00028                                  * result when the error occurred). */
00029     Tcl_Obj *returnOpts;        /* Active return options when the error
00030                                  * occurred */
00031     struct BgError *nextPtr;    /* Next in list of all pending error reports
00032                                  * for this interpreter, or NULL for end of
00033                                  * list. */
00034 } BgError;
00035 
00036 /*
00037  * One of the structures below is associated with the "tclBgError" assoc data
00038  * for each interpreter. It keeps track of the head and tail of the list of
00039  * pending background errors for the interpreter.
00040  */
00041 
00042 typedef struct ErrAssocData {
00043     Tcl_Interp *interp;         /* Interpreter in which error occurred. */
00044     Tcl_Obj *cmdPrefix;         /* First word(s) of the handler command */
00045     BgError *firstBgPtr;        /* First in list of all background errors
00046                                  * waiting to be processed for this
00047                                  * interpreter (NULL if none). */
00048     BgError *lastBgPtr;         /* Last in list of all background errors
00049                                  * waiting to be processed for this
00050                                  * interpreter (NULL if none). */
00051 } ErrAssocData;
00052 
00053 /*
00054  * For each exit handler created with a call to Tcl_CreateExitHandler there is
00055  * a structure of the following type:
00056  */
00057 
00058 typedef struct ExitHandler {
00059     Tcl_ExitProc *proc;         /* Function to call when process exits. */
00060     ClientData clientData;      /* One word of information to pass to proc. */
00061     struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
00062                                  * application, or NULL for end of list. */
00063 } ExitHandler;
00064 
00065 /*
00066  * There is both per-process and per-thread exit handlers. The first list is
00067  * controlled by a mutex. The other is in thread local storage.
00068  */
00069 
00070 static ExitHandler *firstExitPtr = NULL;
00071                                 /* First in list of all exit handlers for
00072                                  * application. */
00073 TCL_DECLARE_MUTEX(exitMutex)
00074 
00075 /*
00076  * This variable is set to 1 when Tcl_Finalize is called, and at the end of
00077  * its work, it is reset to 0. The variable is checked by TclInExit() to allow
00078  * different behavior for exit-time processing, e.g. in closing of files and
00079  * pipes.
00080  */
00081 
00082 static int inFinalize = 0;
00083 static int subsystemsInitialized = 0;
00084 
00085 /*
00086  * This variable contains the application wide exit handler. It will be
00087  * called by Tcl_Exit instead of the C-runtime exit if this variable is set
00088  * to a non-NULL value.
00089  */
00090 
00091 static Tcl_ExitProc *appExitPtr = NULL;
00092 
00093 typedef struct ThreadSpecificData {
00094     ExitHandler *firstExitPtr;  /* First in list of all exit handlers for this
00095                                  * thread. */
00096     int inExit;                 /* True when this thread is exiting. This is
00097                                  * used as a hack to decide to close the
00098                                  * standard channels. */
00099 } ThreadSpecificData;
00100 static Tcl_ThreadDataKey dataKey;
00101 
00102 #ifdef TCL_THREADS
00103 typedef struct {
00104     Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
00105     ClientData clientData;      /* The one argument to Main() */
00106 } ThreadClientData;
00107 static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
00108 #endif /* TCL_THREADS */
00109 
00110 /*
00111  * Prototypes for functions referenced only in this file:
00112  */
00113 
00114 static void             BgErrorDeleteProc(ClientData clientData,
00115                             Tcl_Interp *interp);
00116 static void             HandleBgErrors(ClientData clientData);
00117 static char *           VwaitVarProc(ClientData clientData, Tcl_Interp *interp,
00118                             CONST char *name1, CONST char *name2, int flags);
00119 
00120 /*
00121  *----------------------------------------------------------------------
00122  *
00123  * Tcl_BackgroundError --
00124  *
00125  *      This function is invoked to handle errors that occur in Tcl commands
00126  *      that are invoked in "background" (e.g. from event or timer bindings).
00127  *
00128  * Results:
00129  *      None.
00130  *
00131  * Side effects:
00132  *      A handler command is invoked later as an idle handler to process the
00133  *      error, passing it the interp result and return options.
00134  *
00135  *----------------------------------------------------------------------
00136  */
00137 
00138 void
00139 Tcl_BackgroundError(
00140     Tcl_Interp *interp)         /* Interpreter in which an error has
00141                                  * occurred. */
00142 {
00143     TclBackgroundException(interp, TCL_ERROR);
00144 }
00145 void
00146 TclBackgroundException(
00147     Tcl_Interp *interp,         /* Interpreter in which an exception has
00148                                  * occurred. */
00149     int code)                   /* The exception code value */
00150 {
00151     BgError *errPtr;
00152     ErrAssocData *assocPtr;
00153 
00154     if (code == TCL_OK) {
00155         return;
00156     }
00157 
00158     errPtr = (BgError *) ckalloc(sizeof(BgError));
00159     errPtr->errorMsg = Tcl_GetObjResult(interp);
00160     Tcl_IncrRefCount(errPtr->errorMsg);
00161     errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
00162     Tcl_IncrRefCount(errPtr->returnOpts);
00163     errPtr->nextPtr = NULL;
00164 
00165     (void) TclGetBgErrorHandler(interp);
00166     assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError", NULL);
00167     if (assocPtr->firstBgPtr == NULL) {
00168         assocPtr->firstBgPtr = errPtr;
00169         Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
00170     } else {
00171         assocPtr->lastBgPtr->nextPtr = errPtr;
00172     }
00173     assocPtr->lastBgPtr = errPtr;
00174     Tcl_ResetResult(interp);
00175 }
00176 
00177 /*
00178  *----------------------------------------------------------------------
00179  *
00180  * HandleBgErrors --
00181  *
00182  *      This function is invoked as an idle handler to process all of the
00183  *      accumulated background errors.
00184  *
00185  * Results:
00186  *      None.
00187  *
00188  * Side effects:
00189  *      Depends on what actions the handler command takes for the errors.
00190  *
00191  *----------------------------------------------------------------------
00192  */
00193 
00194 static void
00195 HandleBgErrors(
00196     ClientData clientData)      /* Pointer to ErrAssocData structure. */
00197 {
00198     ErrAssocData *assocPtr = (ErrAssocData *) clientData;
00199     Tcl_Interp *interp = assocPtr->interp;
00200     BgError *errPtr;
00201 
00202     /*
00203      * Not bothering to save/restore the interp state. Assume that any code
00204      * that has interp state it needs to keep will make its own
00205      * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
00206      * that could lead us here.
00207      */
00208 
00209     Tcl_Preserve((ClientData) assocPtr);
00210     Tcl_Preserve((ClientData) interp);
00211     while (assocPtr->firstBgPtr != NULL) {
00212         int code, prefixObjc;
00213         Tcl_Obj **prefixObjv, **tempObjv;
00214 
00215         /*
00216          * Note we copy the handler command prefix each pass through, so
00217          * we do support one handler setting another handler.
00218          */
00219 
00220         Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
00221 
00222         errPtr = assocPtr->firstBgPtr;
00223 
00224         Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
00225         tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *));
00226         memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
00227         tempObjv[prefixObjc] = errPtr->errorMsg;
00228         tempObjv[prefixObjc+1] = errPtr->returnOpts;
00229         Tcl_AllowExceptions(interp);
00230         code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
00231 
00232         /*
00233          * Discard the command and the information about the error report.
00234          */
00235 
00236         Tcl_DecrRefCount(copyObj);
00237         Tcl_DecrRefCount(errPtr->errorMsg);
00238         Tcl_DecrRefCount(errPtr->returnOpts);
00239         assocPtr->firstBgPtr = errPtr->nextPtr;
00240         ckfree((char *) errPtr);
00241         ckfree((char *) tempObjv);
00242 
00243         if (code == TCL_BREAK) {
00244             /*
00245              * Break means cancel any remaining error reports for this
00246              * interpreter.
00247              */
00248 
00249             while (assocPtr->firstBgPtr != NULL) {
00250                 errPtr = assocPtr->firstBgPtr;
00251                 assocPtr->firstBgPtr = errPtr->nextPtr;
00252                 Tcl_DecrRefCount(errPtr->errorMsg);
00253                 Tcl_DecrRefCount(errPtr->returnOpts);
00254                 ckfree((char *) errPtr);
00255             }
00256         } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
00257             Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
00258 
00259             if (errChannel != (Tcl_Channel) NULL) {
00260                 Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
00261                 Tcl_Obj *keyPtr, *valuePtr;
00262 
00263                 TclNewLiteralStringObj(keyPtr, "-errorinfo");
00264                 Tcl_IncrRefCount(keyPtr);
00265                 Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
00266                 Tcl_DecrRefCount(keyPtr);
00267 
00268                 Tcl_WriteChars(errChannel,
00269                         "error in background error handler:\n", -1);
00270                 if (valuePtr) {
00271                     Tcl_WriteObj(errChannel, valuePtr);
00272                 } else {
00273                     Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
00274                 }
00275                 Tcl_WriteChars(errChannel, "\n", 1);
00276                 Tcl_Flush(errChannel);
00277             }
00278         }
00279     }
00280     assocPtr->lastBgPtr = NULL;
00281     Tcl_Release((ClientData) interp);
00282     Tcl_Release((ClientData) assocPtr);
00283 }
00284 
00285 /*
00286  *----------------------------------------------------------------------
00287  *
00288  * TclDefaultBgErrorHandlerObjCmd --
00289  *
00290  *      This function is invoked to process the "::tcl::Bgerror" Tcl command.
00291  *      It is the default handler command registered with [interp bgerror] for
00292  *      the sake of compatibility with older Tcl releases.
00293  *
00294  * Results:
00295  *      A standard Tcl object result.
00296  *
00297  * Side effects:
00298  *      Depends on what actions the "bgerror" command takes for the errors.
00299  *
00300  *----------------------------------------------------------------------
00301  */
00302 
00303 int
00304 TclDefaultBgErrorHandlerObjCmd(
00305     ClientData dummy,           /* Not used. */
00306     Tcl_Interp *interp,         /* Current interpreter. */
00307     int objc,                   /* Number of arguments. */
00308     Tcl_Obj *CONST objv[])      /* Argument objects. */
00309 {
00310     Tcl_Obj *keyPtr, *valuePtr;
00311     Tcl_Obj *tempObjv[2];
00312     int code, level;
00313     Tcl_InterpState saved;
00314 
00315     if (objc != 3) {
00316         Tcl_WrongNumArgs(interp, 1, objv, "msg options");
00317         return TCL_ERROR;
00318     }
00319 
00320     /* Construct the bgerror command */
00321     TclNewLiteralStringObj(tempObjv[0], "bgerror");
00322     Tcl_IncrRefCount(tempObjv[0]);
00323 
00324     /*
00325      * Determine error message argument.  Check the return options in case
00326      * a non-error exception brought us here.
00327      */
00328 
00329     TclNewLiteralStringObj(keyPtr, "-level");
00330     Tcl_IncrRefCount(keyPtr);
00331     Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
00332     Tcl_DecrRefCount(keyPtr);
00333     Tcl_GetIntFromObj(NULL, valuePtr, &level);
00334     if (level != 0) {
00335         /* We're handling a TCL_RETURN exception */
00336         code = TCL_RETURN;
00337     } else {
00338         TclNewLiteralStringObj(keyPtr, "-code");
00339         Tcl_IncrRefCount(keyPtr);
00340         Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
00341         Tcl_DecrRefCount(keyPtr);
00342         Tcl_GetIntFromObj(NULL, valuePtr, &code);
00343     }
00344     switch (code) {
00345     case TCL_ERROR:
00346         tempObjv[1] = objv[1];
00347         break;
00348     case TCL_BREAK:
00349         TclNewLiteralStringObj(tempObjv[1],
00350                 "invoked \"break\" outside of a loop");
00351         break;
00352     case TCL_CONTINUE:
00353         TclNewLiteralStringObj(tempObjv[1],
00354                 "invoked \"continue\" outside of a loop");
00355         break;
00356     default:
00357         tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code);
00358         break;
00359     }
00360     Tcl_IncrRefCount(tempObjv[1]);
00361 
00362     if (code != TCL_ERROR) {
00363         Tcl_SetObjResult(interp, tempObjv[1]);
00364     }
00365 
00366     TclNewLiteralStringObj(keyPtr, "-errorcode");
00367     Tcl_IncrRefCount(keyPtr);
00368     Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
00369     Tcl_DecrRefCount(keyPtr);
00370     if (valuePtr) {
00371         Tcl_SetObjErrorCode(interp, valuePtr);
00372     }
00373 
00374     TclNewLiteralStringObj(keyPtr, "-errorinfo");
00375     Tcl_IncrRefCount(keyPtr);
00376     Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
00377     Tcl_DecrRefCount(keyPtr);
00378     if (valuePtr) {
00379         Tcl_IncrRefCount(valuePtr);
00380         Tcl_AppendObjToErrorInfo(interp, valuePtr);
00381     }
00382 
00383     if (code == TCL_ERROR) {
00384         Tcl_SetObjResult(interp, tempObjv[1]);
00385     }
00386 
00387     /*
00388      * Save interpreter state so we can restore it if multiple handler
00389      * attempts are needed.
00390      */
00391 
00392     saved = Tcl_SaveInterpState(interp, code);
00393     
00394     /* Invoke the bgerror command. */
00395     Tcl_AllowExceptions(interp);
00396     code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
00397     if (code == TCL_ERROR) {
00398         /*
00399          * If the interpreter is safe, we look for a hidden command named
00400          * "bgerror" and call that with the error information. Otherwise,
00401          * simply ignore the error. The rationale is that this could be an
00402          * error caused by a malicious applet trying to cause an infinite
00403          * barrage of error messages. The hidden "bgerror" command can be used
00404          * by a security policy to interpose on such attacks and e.g. kill the
00405          * applet after a few attempts.
00406          */
00407 
00408         if (Tcl_IsSafe(interp)) {
00409             Tcl_RestoreInterpState(interp, saved);
00410             TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
00411         } else {
00412             Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
00413             if (errChannel != (Tcl_Channel) NULL) {
00414                 Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
00415 
00416                 Tcl_IncrRefCount(resultPtr);
00417                 if (Tcl_FindCommand(interp, "bgerror", NULL,
00418                         TCL_GLOBAL_ONLY) == NULL) {
00419                     Tcl_RestoreInterpState(interp, saved);
00420                     Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
00421                             "errorInfo", NULL, TCL_GLOBAL_ONLY));
00422                     Tcl_WriteChars(errChannel, "\n", -1);
00423                 } else {
00424                     Tcl_DiscardInterpState(saved);
00425                     Tcl_WriteChars(errChannel,
00426                             "bgerror failed to handle background error.\n",-1);
00427                     Tcl_WriteChars(errChannel, "    Original error: ", -1);
00428                     Tcl_WriteObj(errChannel, tempObjv[1]);
00429                     Tcl_WriteChars(errChannel, "\n", -1);
00430                     Tcl_WriteChars(errChannel, "    Error in bgerror: ", -1);
00431                     Tcl_WriteObj(errChannel, resultPtr);
00432                     Tcl_WriteChars(errChannel, "\n", -1);
00433                 }
00434                 Tcl_DecrRefCount(resultPtr);
00435                 Tcl_Flush(errChannel);
00436             } else {
00437                 Tcl_DiscardInterpState(saved);
00438             }
00439         }
00440         code = TCL_OK;
00441     } else {
00442         Tcl_DiscardInterpState(saved);
00443     }
00444 
00445     Tcl_DecrRefCount(tempObjv[0]);
00446     Tcl_DecrRefCount(tempObjv[1]);
00447     Tcl_ResetResult(interp);
00448     return code;
00449 }
00450 
00451 /*
00452  *----------------------------------------------------------------------
00453  *
00454  * TclSetBgErrorHandler --
00455  *
00456  *      This function sets the command prefix to be used to handle background
00457  *      errors in interp.
00458  *
00459  * Results:
00460  *      None.
00461  *
00462  * Side effects:
00463  *      Error handler is registered.
00464  *
00465  *----------------------------------------------------------------------
00466  */
00467 
00468 void
00469 TclSetBgErrorHandler(
00470     Tcl_Interp *interp,
00471     Tcl_Obj *cmdPrefix)
00472 {
00473     ErrAssocData *assocPtr = (ErrAssocData *)
00474             Tcl_GetAssocData(interp, "tclBgError", NULL);
00475 
00476     if (cmdPrefix == NULL) {
00477         Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
00478     }
00479     if (assocPtr == NULL) {
00480         /*
00481          * First access: initialize.
00482          */
00483 
00484         assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
00485         assocPtr->interp = interp;
00486         assocPtr->cmdPrefix = NULL;
00487         assocPtr->firstBgPtr = NULL;
00488         assocPtr->lastBgPtr = NULL;
00489         Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
00490                 (ClientData) assocPtr);
00491     }
00492     if (assocPtr->cmdPrefix) {
00493         Tcl_DecrRefCount(assocPtr->cmdPrefix);
00494     }
00495     assocPtr->cmdPrefix = cmdPrefix;
00496     Tcl_IncrRefCount(assocPtr->cmdPrefix);
00497 }
00498 
00499 /*
00500  *----------------------------------------------------------------------
00501  *
00502  * TclGetBgErrorHandler --
00503  *
00504  *      This function retrieves the command prefix currently used to handle
00505  *      background errors in interp.
00506  *
00507  * Results:
00508  *      A (Tcl_Obj *) to a list of words (command prefix).
00509  *
00510  * Side effects:
00511  *      None.
00512  *
00513  *----------------------------------------------------------------------
00514  */
00515 
00516 Tcl_Obj *
00517 TclGetBgErrorHandler(
00518     Tcl_Interp *interp)
00519 {
00520     ErrAssocData *assocPtr = (ErrAssocData *)
00521             Tcl_GetAssocData(interp, "tclBgError", NULL);
00522 
00523     if (assocPtr == NULL) {
00524         Tcl_Obj *bgerrorObj;
00525 
00526         TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
00527         TclSetBgErrorHandler(interp, bgerrorObj);
00528         assocPtr = (ErrAssocData *)
00529                 Tcl_GetAssocData(interp, "tclBgError", NULL);
00530     }
00531     return assocPtr->cmdPrefix;
00532 }
00533 
00534 /*
00535  *----------------------------------------------------------------------
00536  *
00537  * BgErrorDeleteProc --
00538  *
00539  *      This function is associated with the "tclBgError" assoc data for an
00540  *      interpreter; it is invoked when the interpreter is deleted in order to
00541  *      free the information assoicated with any pending error reports.
00542  *
00543  * Results:
00544  *      None.
00545  *
00546  * Side effects:
00547  *      Background error information is freed: if there were any pending error
00548  *      reports, they are cancelled.
00549  *
00550  *----------------------------------------------------------------------
00551  */
00552 
00553 static void
00554 BgErrorDeleteProc(
00555     ClientData clientData,      /* Pointer to ErrAssocData structure. */
00556     Tcl_Interp *interp)         /* Interpreter being deleted. */
00557 {
00558     ErrAssocData *assocPtr = (ErrAssocData *) clientData;
00559     BgError *errPtr;
00560 
00561     while (assocPtr->firstBgPtr != NULL) {
00562         errPtr = assocPtr->firstBgPtr;
00563         assocPtr->firstBgPtr = errPtr->nextPtr;
00564         Tcl_DecrRefCount(errPtr->errorMsg);
00565         Tcl_DecrRefCount(errPtr->returnOpts);
00566         ckfree((char *) errPtr);
00567     }
00568     Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
00569     Tcl_DecrRefCount(assocPtr->cmdPrefix);
00570     Tcl_EventuallyFree((ClientData) assocPtr, TCL_DYNAMIC);
00571 }
00572 
00573 /*
00574  *----------------------------------------------------------------------
00575  *
00576  * Tcl_CreateExitHandler --
00577  *
00578  *      Arrange for a given function to be invoked just before the application
00579  *      exits.
00580  *
00581  * Results:
00582  *      None.
00583  *
00584  * Side effects:
00585  *      Proc will be invoked with clientData as argument when the application
00586  *      exits.
00587  *
00588  *----------------------------------------------------------------------
00589  */
00590 
00591 void
00592 Tcl_CreateExitHandler(
00593     Tcl_ExitProc *proc,         /* Function to invoke. */
00594     ClientData clientData)      /* Arbitrary value to pass to proc. */
00595 {
00596     ExitHandler *exitPtr;
00597 
00598     exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
00599     exitPtr->proc = proc;
00600     exitPtr->clientData = clientData;
00601     Tcl_MutexLock(&exitMutex);
00602     exitPtr->nextPtr = firstExitPtr;
00603     firstExitPtr = exitPtr;
00604     Tcl_MutexUnlock(&exitMutex);
00605 }
00606 
00607 /*
00608  *----------------------------------------------------------------------
00609  *
00610  * Tcl_DeleteExitHandler --
00611  *
00612  *      This function cancels an existing exit handler matching proc and
00613  *      clientData, if such a handler exits.
00614  *
00615  * Results:
00616  *      None.
00617  *
00618  * Side effects:
00619  *      If there is an exit handler corresponding to proc and clientData then
00620  *      it is cancelled; if no such handler exists then nothing happens.
00621  *
00622  *----------------------------------------------------------------------
00623  */
00624 
00625 void
00626 Tcl_DeleteExitHandler(
00627     Tcl_ExitProc *proc,         /* Function that was previously registered. */
00628     ClientData clientData)      /* Arbitrary value to pass to proc. */
00629 {
00630     ExitHandler *exitPtr, *prevPtr;
00631 
00632     Tcl_MutexLock(&exitMutex);
00633     for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
00634             prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
00635         if ((exitPtr->proc == proc)
00636                 && (exitPtr->clientData == clientData)) {
00637             if (prevPtr == NULL) {
00638                 firstExitPtr = exitPtr->nextPtr;
00639             } else {
00640                 prevPtr->nextPtr = exitPtr->nextPtr;
00641             }
00642             ckfree((char *) exitPtr);
00643             break;
00644         }
00645     }
00646     Tcl_MutexUnlock(&exitMutex);
00647     return;
00648 }
00649 
00650 /*
00651  *----------------------------------------------------------------------
00652  *
00653  * Tcl_CreateThreadExitHandler --
00654  *
00655  *      Arrange for a given function to be invoked just before the current
00656  *      thread exits.
00657  *
00658  * Results:
00659  *      None.
00660  *
00661  * Side effects:
00662  *      Proc will be invoked with clientData as argument when the application
00663  *      exits.
00664  *
00665  *----------------------------------------------------------------------
00666  */
00667 
00668 void
00669 Tcl_CreateThreadExitHandler(
00670     Tcl_ExitProc *proc,         /* Function to invoke. */
00671     ClientData clientData)      /* Arbitrary value to pass to proc. */
00672 {
00673     ExitHandler *exitPtr;
00674     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
00675 
00676     exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
00677     exitPtr->proc = proc;
00678     exitPtr->clientData = clientData;
00679     exitPtr->nextPtr = tsdPtr->firstExitPtr;
00680     tsdPtr->firstExitPtr = exitPtr;
00681 }
00682 
00683 /*
00684  *----------------------------------------------------------------------
00685  *
00686  * Tcl_DeleteThreadExitHandler --
00687  *
00688  *      This function cancels an existing exit handler matching proc and
00689  *      clientData, if such a handler exits.
00690  *
00691  * Results:
00692  *      None.
00693  *
00694  * Side effects:
00695  *      If there is an exit handler corresponding to proc and clientData then
00696  *      it is cancelled; if no such handler exists then nothing happens.
00697  *
00698  *----------------------------------------------------------------------
00699  */
00700 
00701 void
00702 Tcl_DeleteThreadExitHandler(
00703     Tcl_ExitProc *proc,         /* Function that was previously registered. */
00704     ClientData clientData)      /* Arbitrary value to pass to proc. */
00705 {
00706     ExitHandler *exitPtr, *prevPtr;
00707     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
00708 
00709     for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
00710             prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
00711         if ((exitPtr->proc == proc)
00712                 && (exitPtr->clientData == clientData)) {
00713             if (prevPtr == NULL) {
00714                 tsdPtr->firstExitPtr = exitPtr->nextPtr;
00715             } else {
00716                 prevPtr->nextPtr = exitPtr->nextPtr;
00717             }
00718             ckfree((char *) exitPtr);
00719             return;
00720         }
00721     }
00722 }
00723 
00724 /*
00725  *----------------------------------------------------------------------
00726  *
00727  * Tcl_SetExitProc --
00728  *
00729  *      This function sets the application wide exit handler that will be
00730  *      called by Tcl_Exit in place of the C-runtime exit. If the application
00731  *      wide exit handler is NULL, the C-runtime exit will be used instead.
00732  *
00733  * Results:
00734  *      The previously set application wide exit handler.
00735  *
00736  * Side effects:
00737  *      Sets the application wide exit handler to the specified value.
00738  *
00739  *----------------------------------------------------------------------
00740  */
00741 
00742 Tcl_ExitProc *
00743 Tcl_SetExitProc(
00744     Tcl_ExitProc *proc)         /* New exit handler for app or NULL */
00745 {
00746     Tcl_ExitProc *prevExitProc;
00747 
00748     /*
00749      * Swap the old exit proc for the new one, saving the old one for our
00750      * return value.
00751      */
00752 
00753     Tcl_MutexLock(&exitMutex);
00754     prevExitProc = appExitPtr;
00755     appExitPtr = proc;
00756     Tcl_MutexUnlock(&exitMutex);
00757 
00758     return prevExitProc;
00759 }
00760 
00761 /*
00762  *----------------------------------------------------------------------
00763  *
00764  * Tcl_Exit --
00765  *
00766  *      This function is called to terminate the application.
00767  *
00768  * Results:
00769  *      None.
00770  *
00771  * Side effects:
00772  *      All existing exit handlers are invoked, then the application ends.
00773  *
00774  *----------------------------------------------------------------------
00775  */
00776 
00777 void
00778 Tcl_Exit(
00779     int status)                 /* Exit status for application; typically 0
00780                                  * for normal return, 1 for error return. */
00781 {
00782     Tcl_ExitProc *currentAppExitPtr;
00783 
00784     Tcl_MutexLock(&exitMutex);
00785     currentAppExitPtr = appExitPtr;
00786     Tcl_MutexUnlock(&exitMutex);
00787 
00788     if (currentAppExitPtr) {
00789         /*
00790          * Warning: this code SHOULD NOT return, as there is code that depends
00791          * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone
00792          * returns, so critical is this dependcy.
00793          */
00794 
00795         currentAppExitPtr((ClientData) INT2PTR(status));
00796         Tcl_Panic("AppExitProc returned unexpectedly");
00797     } else {
00798         /*
00799          * Use default handling.
00800          */
00801 
00802         Tcl_Finalize();
00803         TclpExit(status);
00804         Tcl_Panic("OS exit failed!");
00805     }
00806 }
00807 
00808 /*
00809  *-------------------------------------------------------------------------
00810  *
00811  * TclInitSubsystems --
00812  *
00813  *      Initialize various subsytems in Tcl. This should be called the first
00814  *      time an interp is created, or before any of the subsystems are used.
00815  *      This function ensures an order for the initialization of subsystems:
00816  *
00817  *      1. that cannot be initialized in lazy order because they are mutually
00818  *      dependent.
00819  *
00820  *      2. so that they can be finalized in a known order w/o causing the
00821  *      subsequent re-initialization of a subsystem in the act of shutting
00822  *      down another.
00823  *
00824  * Results:
00825  *      None.
00826  *
00827  * Side effects:
00828  *      Varied, see the respective initialization routines.
00829  *
00830  *-------------------------------------------------------------------------
00831  */
00832 
00833 void
00834 TclInitSubsystems(void)
00835 {
00836     if (inFinalize != 0) {
00837         Tcl_Panic("TclInitSubsystems called while finalizing");
00838     }
00839 
00840     if (subsystemsInitialized == 0) {
00841         /*
00842          * Double check inside the mutex. There are definitly calls back into
00843          * this routine from some of the functions below.
00844          */
00845 
00846         TclpInitLock();
00847         if (subsystemsInitialized == 0) {
00848             /*
00849              * Have to set this bit here to avoid deadlock with the routines
00850              * below us that call into TclInitSubsystems.
00851              */
00852 
00853             subsystemsInitialized = 1;
00854 
00855             /*
00856              * Initialize locks used by the memory allocators before anything
00857              * interesting happens so we can use the allocators in the
00858              * implementation of self-initializing locks.
00859              */
00860 
00861             TclInitThreadStorage();     /* Creates master hash table for
00862                                          * thread local storage */
00863 #if USE_TCLALLOC
00864             TclInitAlloc();             /* Process wide mutex init */
00865 #endif
00866 #ifdef TCL_MEM_DEBUG
00867             TclInitDbCkalloc();         /* Process wide mutex init */
00868 #endif
00869 
00870             TclpInitPlatform();         /* Creates signal handler(s) */
00871             TclInitDoubleConversion();  /* Initializes constants for
00872                                          * converting to/from double. */
00873             TclInitObjSubsystem();      /* Register obj types, create
00874                                          * mutexes. */
00875             TclInitIOSubsystem();       /* Inits a tsd key (noop). */
00876             TclInitEncodingSubsystem(); /* Process wide encoding init. */
00877             TclpSetInterfaces();
00878             TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
00879         }
00880         TclpInitUnlock();
00881     }
00882     TclInitNotifier();
00883 }
00884 
00885 /*
00886  *----------------------------------------------------------------------
00887  *
00888  * Tcl_Finalize --
00889  *
00890  *      Shut down Tcl. First calls registered exit handlers, then carefully
00891  *      shuts down various subsystems. Called by Tcl_Exit or when the Tcl
00892  *      shared library is being unloaded.
00893  *
00894  * Results:
00895  *      None.
00896  *
00897  * Side effects:
00898  *      Varied, see the respective finalization routines.
00899  *
00900  *----------------------------------------------------------------------
00901  */
00902 
00903 void
00904 Tcl_Finalize(void)
00905 {
00906     ExitHandler *exitPtr;
00907 
00908     /*
00909      * Invoke exit handlers first.
00910      */
00911 
00912     Tcl_MutexLock(&exitMutex);
00913     inFinalize = 1;
00914     for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
00915         /*
00916          * Be careful to remove the handler from the list before invoking its
00917          * callback. This protects us against double-freeing if the callback
00918          * should call Tcl_DeleteExitHandler on itself.
00919          */
00920 
00921         firstExitPtr = exitPtr->nextPtr;
00922         Tcl_MutexUnlock(&exitMutex);
00923         (*exitPtr->proc)(exitPtr->clientData);
00924         ckfree((char *) exitPtr);
00925         Tcl_MutexLock(&exitMutex);
00926     }
00927     firstExitPtr = NULL;
00928     Tcl_MutexUnlock(&exitMutex);
00929 
00930     TclpInitLock();
00931     if (subsystemsInitialized == 0) {
00932         goto alreadyFinalized;
00933     }
00934     subsystemsInitialized = 0;
00935 
00936     /*
00937      * Ensure the thread-specific data is initialised as it is used in
00938      * Tcl_FinalizeThread()
00939      */
00940 
00941     (void) TCL_TSD_INIT(&dataKey);
00942 
00943     /*
00944      * Clean up after the current thread now, after exit handlers. In
00945      * particular, the testexithandler command sets up something that writes
00946      * to standard output, which gets closed. Note that there is no
00947      * thread-local storage or IO subsystem after this call.
00948      */
00949 
00950     Tcl_FinalizeThread();
00951 
00952     /*
00953      * Now finalize the Tcl execution environment. Note that this must be done
00954      * after the exit handlers, because there are order dependencies.
00955      */
00956 
00957     TclFinalizeExecution();
00958     TclFinalizeEnvironment();
00959 
00960     /*
00961      * Finalizing the filesystem must come after anything which might
00962      * conceivably interact with the 'Tcl_FS' API.
00963      */
00964 
00965     TclFinalizeFilesystem();
00966 
00967     /*
00968      * Undo all Tcl_ObjType registrations, and reset the master list of free
00969      * Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or
00970      * freed.
00971      *
00972      * Note in particular that TclFinalizeObjects() must follow
00973      * TclFinalizeFilesystem() because TclFinalizeFilesystem free's the
00974      * Tcl_Obj that holds the path of the current working directory.
00975      */
00976 
00977     TclFinalizeObjects();
00978 
00979     /*
00980      * We must be sure the encoding finalization doesn't need to examine the
00981      * filesystem in any way. Since it only needs to clean up internal data
00982      * structures, this is fine.
00983      */
00984 
00985     TclFinalizeEncodingSubsystem();
00986 
00987     Tcl_SetPanicProc(NULL);
00988 
00989     /*
00990      * Repeat finalization of the thread local storage once more. Although
00991      * this step is already done by the Tcl_FinalizeThread call above, series
00992      * of events happening afterwards may re-initialize TSD slots. Those need
00993      * to be finalized again, otherwise we're leaking memory chunks. Very
00994      * important to note is that things happening afterwards should not
00995      * reference anything which may re-initialize TSD's. This includes freeing
00996      * Tcl_Objs's, among other things.
00997      *
00998      * This fixes the Tcl Bug #990552.
00999      */
01000 
01001     TclFinalizeThreadData();
01002 
01003     /*
01004      * Now we can free constants for conversions to/from double.
01005      */
01006 
01007     TclFinalizeDoubleConversion();
01008 
01009     /*
01010      * There have been several bugs in the past that cause exit handlers to be
01011      * established during Tcl_Finalize processing. Such exit handlers leave
01012      * malloc'ed memory, and Tcl_FinalizeThreadAlloc or
01013      * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The result
01014      * can be a mysterious crash on process exit. Check here that nobody's
01015      * done this.
01016      */
01017 
01018     if (firstExitPtr != NULL) {
01019         Tcl_Panic("exit handlers were created during Tcl_Finalize");
01020     }
01021 
01022     TclFinalizePreserve();
01023 
01024     /*
01025      * Free synchronization objects. There really should only be one thread
01026      * alive at this moment.
01027      */
01028 
01029     TclFinalizeSynchronization();
01030 
01031     /*
01032      * Close down the thread-specific object allocator.
01033      */
01034 
01035 #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
01036     TclFinalizeThreadAlloc();
01037 #endif
01038 
01039     /*
01040      * We defer unloading of packages until very late to avoid memory access
01041      * issues. Both exit callbacks and synchronization variables may be stored
01042      * in packages.
01043      *
01044      * Note that TclFinalizeLoad unloads packages in the reverse of the order
01045      * they were loaded in (i.e. last to be loaded is the first to be
01046      * unloaded). This can be important for correct unloading when
01047      * dependencies exist.
01048      *
01049      * Once load has been finalized, we will have deleted any temporary copies
01050      * of shared libraries and can therefore reset the filesystem to its
01051      * original state.
01052      */
01053 
01054     TclFinalizeLoad();
01055     TclResetFilesystem();
01056 
01057     /*
01058      * At this point, there should no longer be any ckalloc'ed memory.
01059      */
01060 
01061     TclFinalizeMemorySubsystem();
01062     inFinalize = 0;
01063 
01064   alreadyFinalized:
01065     TclFinalizeLock();
01066 }
01067 
01068 /*
01069  *----------------------------------------------------------------------
01070  *
01071  * Tcl_FinalizeThread --
01072  *
01073  *      Runs the exit handlers to allow Tcl to clean up its state about a
01074  *      particular thread.
01075  *
01076  * Results:
01077  *      None.
01078  *
01079  * Side effects:
01080  *      Varied, see the respective finalization routines.
01081  *
01082  *----------------------------------------------------------------------
01083  */
01084 
01085 void
01086 Tcl_FinalizeThread(void)
01087 {
01088     ExitHandler *exitPtr;
01089     ThreadSpecificData *tsdPtr;
01090 
01091     /*
01092      * We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
01093      * we don't want to initialize the data block if it hasn't been
01094      * initialized already.
01095      */
01096 
01097     tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
01098     if (tsdPtr != NULL) {
01099         tsdPtr->inExit = 1;
01100 
01101         for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
01102                 exitPtr = tsdPtr->firstExitPtr) {
01103             /*
01104              * Be careful to remove the handler from the list before invoking
01105              * its callback. This protects us against double-freeing if the
01106              * callback should call Tcl_DeleteThreadExitHandler on itself.
01107              */
01108 
01109             tsdPtr->firstExitPtr = exitPtr->nextPtr;
01110             (*exitPtr->proc)(exitPtr->clientData);
01111             ckfree((char *) exitPtr);
01112         }
01113         TclFinalizeIOSubsystem();
01114         TclFinalizeNotifier();
01115         TclFinalizeAsync();
01116     }
01117 
01118     /*
01119      * Blow away all thread local storage blocks.
01120      *
01121      * Note that Tcl API allows creation of threads which do not use any Tcl
01122      * interp or other Tcl subsytems. Those threads might, however, use thread
01123      * local storage, so we must unconditionally finalize it.
01124      *
01125      * Fix [Bug #571002]
01126      */
01127 
01128     TclFinalizeThreadData();
01129 }
01130 
01131 /*
01132  *----------------------------------------------------------------------
01133  *
01134  * TclInExit --
01135  *
01136  *      Determines if we are in the middle of exit-time cleanup.
01137  *
01138  * Results:
01139  *      If we are in the middle of exiting, 1, otherwise 0.
01140  *
01141  * Side effects:
01142  *      None.
01143  *
01144  *----------------------------------------------------------------------
01145  */
01146 
01147 int
01148 TclInExit(void)
01149 {
01150     return inFinalize;
01151 }
01152 
01153 /*
01154  *----------------------------------------------------------------------
01155  *
01156  * TclInThreadExit --
01157  *
01158  *      Determines if we are in the middle of thread exit-time cleanup.
01159  *
01160  * Results:
01161  *      If we are in the middle of exiting this thread, 1, otherwise 0.
01162  *
01163  * Side effects:
01164  *      None.
01165  *
01166  *----------------------------------------------------------------------
01167  */
01168 
01169 int
01170 TclInThreadExit(void)
01171 {
01172     ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
01173             TclThreadDataKeyGet(&dataKey);
01174     if (tsdPtr == NULL) {
01175         return 0;
01176     } else {
01177         return tsdPtr->inExit;
01178     }
01179 }
01180 
01181 /*
01182  *----------------------------------------------------------------------
01183  *
01184  * Tcl_VwaitObjCmd --
01185  *
01186  *      This function is invoked to process the "vwait" Tcl command. See the
01187  *      user documentation for details on what it does.
01188  *
01189  * Results:
01190  *      A standard Tcl result.
01191  *
01192  * Side effects:
01193  *      See the user documentation.
01194  *
01195  *----------------------------------------------------------------------
01196  */
01197 
01198         /* ARGSUSED */
01199 int
01200 Tcl_VwaitObjCmd(
01201     ClientData clientData,      /* Not used. */
01202     Tcl_Interp *interp,         /* Current interpreter. */
01203     int objc,                   /* Number of arguments. */
01204     Tcl_Obj *CONST objv[])      /* Argument objects. */
01205 {
01206     int done, foundEvent;
01207     char *nameString;
01208 
01209     if (objc != 2) {
01210         Tcl_WrongNumArgs(interp, 1, objv, "name");
01211         return TCL_ERROR;
01212     }
01213     nameString = Tcl_GetString(objv[1]);
01214     if (Tcl_TraceVar(interp, nameString,
01215             TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
01216             VwaitVarProc, (ClientData) &done) != TCL_OK) {
01217         return TCL_ERROR;
01218     };
01219     done = 0;
01220     foundEvent = 1;
01221     while (!done && foundEvent) {
01222         foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
01223         if (Tcl_LimitExceeded(interp)) {
01224             break;
01225         }
01226     }
01227     Tcl_UntraceVar(interp, nameString,
01228             TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
01229             VwaitVarProc, (ClientData) &done);
01230 
01231     /*
01232      * Clear out the interpreter's result, since it may have been set by event
01233      * handlers.
01234      */
01235 
01236     Tcl_ResetResult(interp);
01237     if (!foundEvent) {
01238         Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
01239                 "\": would wait forever", NULL);
01240         return TCL_ERROR;
01241     }
01242     if (!done) {
01243         Tcl_AppendResult(interp, "limit exceeded", NULL);
01244         return TCL_ERROR;
01245     }
01246     return TCL_OK;
01247 }
01248 
01249         /* ARGSUSED */
01250 static char *
01251 VwaitVarProc(
01252     ClientData clientData,      /* Pointer to integer to set to 1. */
01253     Tcl_Interp *interp,         /* Interpreter containing variable. */
01254     CONST char *name1,          /* Name of variable. */
01255     CONST char *name2,          /* Second part of variable name. */
01256     int flags)                  /* Information about what happened. */
01257 {
01258     int *donePtr = (int *) clientData;
01259 
01260     *donePtr = 1;
01261     return NULL;
01262 }
01263 
01264 /*
01265  *----------------------------------------------------------------------
01266  *
01267  * Tcl_UpdateObjCmd --
01268  *
01269  *      This function is invoked to process the "update" Tcl command. See the
01270  *      user documentation for details on what it does.
01271  *
01272  * Results:
01273  *      A standard Tcl result.
01274  *
01275  * Side effects:
01276  *      See the user documentation.
01277  *
01278  *----------------------------------------------------------------------
01279  */
01280 
01281         /* ARGSUSED */
01282 int
01283 Tcl_UpdateObjCmd(
01284     ClientData clientData,      /* Not used. */
01285     Tcl_Interp *interp,         /* Current interpreter. */
01286     int objc,                   /* Number of arguments. */
01287     Tcl_Obj *CONST objv[])      /* Argument objects. */
01288 {
01289     int optionIndex;
01290     int flags = 0;              /* Initialized to avoid compiler warning. */
01291     static CONST char *updateOptions[] = {"idletasks", NULL};
01292     enum updateOptions {REGEXP_IDLETASKS};
01293 
01294     if (objc == 1) {
01295         flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
01296     } else if (objc == 2) {
01297         if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
01298                 "option", 0, &optionIndex) != TCL_OK) {
01299             return TCL_ERROR;
01300         }
01301         switch ((enum updateOptions) optionIndex) {
01302         case REGEXP_IDLETASKS:
01303             flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
01304             break;
01305         default:
01306             Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
01307         }
01308     } else {
01309         Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
01310         return TCL_ERROR;
01311     }
01312 
01313     while (Tcl_DoOneEvent(flags) != 0) {
01314         if (Tcl_LimitExceeded(interp)) {
01315             Tcl_ResetResult(interp);
01316             Tcl_AppendResult(interp, "limit exceeded", NULL);
01317             return TCL_ERROR;
01318         }
01319     }
01320 
01321     /*
01322      * Must clear the interpreter's result because event handlers could have
01323      * executed commands.
01324      */
01325 
01326     Tcl_ResetResult(interp);
01327     return TCL_OK;
01328 }
01329 
01330 #ifdef TCL_THREADS
01331 /*
01332  *-----------------------------------------------------------------------------
01333  *
01334  * NewThreadProc --
01335  *
01336  *      Bootstrap function of a new Tcl thread.
01337  *
01338  * Results:
01339  *      None.
01340  *
01341  * Side Effects:
01342  *      Initializes Tcl notifier for the current thread.
01343  *
01344  *-----------------------------------------------------------------------------
01345  */
01346 
01347 static Tcl_ThreadCreateType
01348 NewThreadProc(
01349     ClientData clientData)
01350 {
01351     ThreadClientData *cdPtr;
01352     ClientData threadClientData;
01353     Tcl_ThreadCreateProc *threadProc;
01354 
01355     cdPtr = (ThreadClientData *) clientData;
01356     threadProc = cdPtr->proc;
01357     threadClientData = cdPtr->clientData;
01358     ckfree((char *) clientData);        /* Allocated in Tcl_CreateThread() */
01359 
01360     (*threadProc)(threadClientData);
01361 
01362     TCL_THREAD_CREATE_RETURN;
01363 }
01364 #endif
01365 
01366 /*
01367  *----------------------------------------------------------------------
01368  *
01369  * Tcl_CreateThread --
01370  *
01371  *      This function creates a new thread. This actually belongs to the
01372  *      tclThread.c file but since we use some private data structures local
01373  *      to this file, it is placed here.
01374  *
01375  * Results:
01376  *      TCL_OK if the thread could be created. The thread ID is returned in a
01377  *      parameter.
01378  *
01379  * Side effects:
01380  *      A new thread is created.
01381  *
01382  *----------------------------------------------------------------------
01383  */
01384 
01385 int
01386 Tcl_CreateThread(
01387     Tcl_ThreadId *idPtr,        /* Return, the ID of the thread */
01388     Tcl_ThreadCreateProc proc,  /* Main() function of the thread */
01389     ClientData clientData,      /* The one argument to Main() */
01390     int stackSize,              /* Size of stack for the new thread */
01391     int flags)                  /* Flags controlling behaviour of the new
01392                                  * thread. */
01393 {
01394 #ifdef TCL_THREADS
01395     ThreadClientData *cdPtr;
01396 
01397     cdPtr = (ThreadClientData *) ckalloc(sizeof(ThreadClientData));
01398     cdPtr->proc = proc;
01399     cdPtr->clientData = clientData;
01400 
01401     return TclpThreadCreate(idPtr, NewThreadProc, (ClientData) cdPtr,
01402             stackSize, flags);
01403 #else
01404     return TCL_ERROR;
01405 #endif /* TCL_THREADS */
01406 }
01407 
01408 /*
01409  * Local Variables:
01410  * mode: c
01411  * c-basic-offset: 4
01412  * fill-column: 78
01413  * End:
01414  */



Generated on Wed Mar 12 12:18:15 2008 by  doxygen 1.5.1