Content-Security-Policy: default-src 'none'
Content-Type: text/plain; charset=UTF-8
Content-Length: 43217
Content-Disposition: inline; filename="tclEvent.c"
Last-Modified: Tue, 20 Aug 2024 18:27:32 GMT
Expires: Fri, 18 Aug 2034 18:27:32 GMT
ETag: "0b585b6e903106c6dd9da9d3be90a17c11e44d6c"
/*
* tclEvent.c --
*
* This file implements some general event related interfaces including
* background errors, exit handlers, and the "vwait" and "update" command
* functions.
*
* Copyright (c) 1990-1994 The Regents of the University of California.
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 2004 by Zoran Vasiljevic.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* The data structure below is used to report background errors. One such
* structure is allocated for each error; it holds information about the
* interpreter and the error until an idle handler command can be invoked.
*/
typedef struct BgError {
Tcl_Obj *errorMsg; /* Copy of the error message (the interp's
* result when the error occurred). */
Tcl_Obj *returnOpts; /* Active return options when the error
* occurred */
struct BgError *nextPtr; /* Next in list of all pending error reports
* for this interpreter, or NULL for end of
* list. */
} BgError;
/*
* One of the structures below is associated with the "tclBgError" assoc data
* for each interpreter. It keeps track of the head and tail of the list of
* pending background errors for the interpreter.
*/
typedef struct ErrAssocData {
Tcl_Interp *interp; /* Interpreter in which error occurred. */
Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */
BgError *firstBgPtr; /* First in list of all background errors
* waiting to be processed for this
* interpreter (NULL if none). */
BgError *lastBgPtr; /* Last in list of all background errors
* waiting to be processed for this
* interpreter (NULL if none). */
} ErrAssocData;
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
ClientData clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
* application, or NULL for end of list. */
} ExitHandler;
/*
* There is both per-process and per-thread exit handlers. The first list is
* controlled by a mutex. The other is in thread local storage.
*/
static ExitHandler *firstExitPtr = NULL;
/* First in list of all exit handlers for
* application. */
static ExitHandler *firstLateExitPtr = NULL;
/* First in list of all late exit handlers for
* application. */
TCL_DECLARE_MUTEX(exitMutex)
/*
* This variable is set to 1 when Tcl_Exit is called. The variable is checked
* by TclInExit() to allow different behavior for exit-time processing, e.g.,
* in closing of files and pipes.
*/
static int inExit = 0;
static int subsystemsInitialized = 0;
/*
* This variable contains the application wide exit handler. It will be called
* by Tcl_Exit instead of the C-runtime exit if this variable is set to a
* non-NULL value.
*/
static Tcl_ExitProc *appExitPtr = NULL;
typedef struct ThreadSpecificData {
ExitHandler *firstExitPtr; /* First in list of all exit handlers for this
* thread. */
int inExit; /* True when this thread is exiting. This is
* used as a hack to decide to close the
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#ifdef TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc(ClientData clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
static void BgErrorDeleteProc(ClientData clientData,
Tcl_Interp *interp);
static void HandleBgErrors(ClientData clientData);
static char * VwaitVarProc(ClientData clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
static void InvokeExitHandlers(void);
/*
*----------------------------------------------------------------------
*
* Tcl_BackgroundError --
*
* This function is invoked to handle errors that occur in Tcl commands
* that are invoked in "background" (e.g. from event or timer bindings).
*
* Results:
* None.
*
* Side effects:
* A handler command is invoked later as an idle handler to process the
* error, passing it the interp result and return options.
*
*----------------------------------------------------------------------
*/
void
Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
* occurred. */
{
Tcl_BackgroundException(interp, TCL_ERROR);
}
void
Tcl_BackgroundException(
Tcl_Interp *interp, /* Interpreter in which an exception has
* occurred. */
int code) /* The exception code value */
{
BgError *errPtr;
ErrAssocData *assocPtr;
if (code == TCL_OK) {
return;
}
errPtr = ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
assocPtr->lastBgPtr = errPtr;
Tcl_ResetResult(interp);
}
/*
*----------------------------------------------------------------------
*
* HandleBgErrors --
*
* This function is invoked as an idle handler to process all of the
* accumulated background errors.
*
* Results:
* None.
*
* Side effects:
* Depends on what actions the handler command takes for the errors.
*
*----------------------------------------------------------------------
*/
static void
HandleBgErrors(
ClientData clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
/*
* Not bothering to save/restore the interp state. Assume that any code
* that has interp state it needs to keep will make its own
* Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
* that could lead us here.
*/
Tcl_Preserve(assocPtr);
Tcl_Preserve(interp);
while (assocPtr->firstBgPtr != NULL) {
int code, prefixObjc;
Tcl_Obj **prefixObjv, **tempObjv;
/*
* Note we copy the handler command prefix each pass through, so we do
* support one handler setting another handler.
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
/*
* Discard the command and the information about the error report.
*/
Tcl_DecrRefCount(copyObj);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
ckfree(errPtr);
ckfree(tempObjv);
if (code == TCL_BREAK) {
/*
* Break means cancel any remaining error reports for this
* interpreter.
*/
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
ckfree(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
Tcl_WriteChars(errChannel,
"error in background error handler:\n", -1);
if (valuePtr) {
Tcl_WriteObj(errChannel, valuePtr);
} else {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
}
Tcl_WriteChars(errChannel, "\n", 1);
Tcl_Flush(errChannel);
Tcl_DecrRefCount(options);
}
}
}
assocPtr->lastBgPtr = NULL;
Tcl_Release(interp);
Tcl_Release(assocPtr);
}
/*
*----------------------------------------------------------------------
*
* TclDefaultBgErrorHandlerObjCmd --
*
* This function is invoked to process the "::tcl::Bgerror" Tcl command.
* It is the default handler command registered with [interp bgerror] for
* the sake of compatibility with older Tcl releases.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* Depends on what actions the "bgerror" command takes for the errors.
*
*----------------------------------------------------------------------
*/
int
TclDefaultBgErrorHandlerObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *keyPtr, *valuePtr;
Tcl_Obj *tempObjv[2];
int code, level;
Tcl_InterpState saved;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "msg options");
return TCL_ERROR;
}
/*
* Check for a valid return options dictionary.
*/
TclNewLiteralStringObj(keyPtr, "-level");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-level\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
return TCL_ERROR;
}
TclNewLiteralStringObj(keyPtr, "-code");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing return option \"-code\"", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
return TCL_ERROR;
}
if (level != 0) {
/*
* We're handling a TCL_RETURN exception.
*/
code = TCL_RETURN;
}
if (code == TCL_OK) {
/*
* Somehow we got to exception handling with no exception. (Pass
* TCL_OK to Tcl_BackgroundException()?) Just return without doing
* anything.
*/
return TCL_OK;
}
/*
* Construct the bgerror command.
*/
TclNewLiteralStringObj(tempObjv[0], "bgerror");
Tcl_IncrRefCount(tempObjv[0]);
/*
* Determine error message argument. Check the return options in case
* a non-error exception brought us here.
*/
switch (code) {
case TCL_ERROR:
tempObjv[1] = objv[1];
break;
case TCL_BREAK:
TclNewLiteralStringObj(tempObjv[1],
"invoked \"break\" outside of a loop");
break;
case TCL_CONTINUE:
TclNewLiteralStringObj(tempObjv[1],
"invoked \"continue\" outside of a loop");
break;
default:
tempObjv[1] = Tcl_ObjPrintf("command returned bad code: %d", code);
break;
}
Tcl_IncrRefCount(tempObjv[1]);
if (code != TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
TclNewLiteralStringObj(keyPtr, "-errorcode");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_SetObjErrorCode(interp, valuePtr);
}
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, objv[2], keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_AppendObjToErrorInfo(interp, valuePtr);
}
if (code == TCL_ERROR) {
Tcl_SetObjResult(interp, tempObjv[1]);
}
/*
* Save interpreter state so we can restore it if multiple handler
* attempts are needed.
*/
saved = Tcl_SaveInterpState(interp, code);
/*
* Invoke the bgerror command.
*/
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL);
if (code == TCL_ERROR) {
/*
* If the interpreter is safe, we look for a hidden command named
* "bgerror" and call that with the error information. Otherwise,
* simply ignore the error. The rationale is that this could be an
* error caused by a malicious applet trying to cause an infinite
* barrage of error messages. The hidden "bgerror" command can be used
* by a security policy to interpose on such attacks and e.g. kill the
* applet after a few attempts.
*/
if (Tcl_IsSafe(interp)) {
Tcl_RestoreInterpState(interp, saved);
TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN);
} else {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != NULL) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
if (Tcl_FindCommand(interp, "bgerror", NULL,
TCL_GLOBAL_ONLY) == NULL) {
Tcl_RestoreInterpState(interp, saved);
Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp,
"errorInfo", NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", -1);
} else {
Tcl_DiscardInterpState(saved);
Tcl_WriteChars(errChannel,
"bgerror failed to handle background error.\n",-1);
Tcl_WriteChars(errChannel, " Original error: ", -1);
Tcl_WriteObj(errChannel, tempObjv[1]);
Tcl_WriteChars(errChannel, "\n", -1);
Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
Tcl_WriteObj(errChannel, resultPtr);
Tcl_WriteChars(errChannel, "\n", -1);
}
Tcl_DecrRefCount(resultPtr);
Tcl_Flush(errChannel);
} else {
Tcl_DiscardInterpState(saved);
}
}
code = TCL_OK;
} else {
Tcl_DiscardInterpState(saved);
}
Tcl_DecrRefCount(tempObjv[0]);
Tcl_DecrRefCount(tempObjv[1]);
Tcl_ResetResult(interp);
return code;
}
/*
*----------------------------------------------------------------------
*
* TclSetBgErrorHandler --
*
* This function sets the command prefix to be used to handle background
* errors in interp.
*
* Results:
* None.
*
* Side effects:
* Error handler is registered.
*
*----------------------------------------------------------------------
*/
void
TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
}
if (assocPtr == NULL) {
/*
* First access: initialize.
*/
assocPtr = ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
Tcl_DecrRefCount(assocPtr->cmdPrefix);
}
assocPtr->cmdPrefix = cmdPrefix;
Tcl_IncrRefCount(assocPtr->cmdPrefix);
}
/*
*----------------------------------------------------------------------
*
* TclGetBgErrorHandler --
*
* This function retrieves the command prefix currently used to handle
* background errors in interp.
*
* Results:
* A (Tcl_Obj *) to a list of words (command prefix).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
ErrAssocData *assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
assocPtr = Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
/*
*----------------------------------------------------------------------
*
* BgErrorDeleteProc --
*
* This function is associated with the "tclBgError" assoc data for an
* interpreter; it is invoked when the interpreter is deleted in order to
* free the information assoicated with any pending error reports.
*
* Results:
* None.
*
* Side effects:
* Background error information is freed: if there were any pending error
* reports, they are canceled.
*
*----------------------------------------------------------------------
*/
static void
BgErrorDeleteProc(
ClientData clientData, /* Pointer to ErrAssocData structure. */
Tcl_Interp *interp) /* Interpreter being deleted. */
{
ErrAssocData *assocPtr = clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
ckfree(errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateExitHandler --
*
* Arrange for a given function to be invoked just before the application
* exits.
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the application
* exits.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* TclCreateLateExitHandler --
*
* Arrange for a given function to be invoked after all pre-thread
* cleanups.
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the application
* exits.
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
firstLateExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteExitHandler --
*
* This function cancels an existing exit handler matching proc and
* clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
* it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree(exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
/*
*----------------------------------------------------------------------
*
* TclDeleteLateExitHandler --
*
* This function cancels an existing late exit handler matching proc and
* clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is a late exit handler corresponding to proc and clientData
* then it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstLateExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree(exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThreadExitHandler --
*
* Arrange for a given function to be invoked just before the current
* thread exits.
*
* Results:
* None.
*
* Side effects:
* Proc will be invoked with clientData as argument when the application
* exits.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
tsdPtr->firstExitPtr = exitPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteThreadExitHandler --
*
* This function cancels an existing exit handler matching proc and
* clientData, if such a handler exits.
*
* Results:
* None.
*
* Side effects:
* If there is an exit handler corresponding to proc and clientData then
* it is canceled; if no such handler exists then nothing happens.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
tsdPtr->firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree(exitPtr);
return;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetExitProc --
*
* This function sets the application wide exit handler that will be
* called by Tcl_Exit in place of the C-runtime exit. If the application
* wide exit handler is NULL, the C-runtime exit will be used instead.
*
* Results:
* The previously set application wide exit handler.
*
* Side effects:
* Sets the application wide exit handler to the specified value.
*
*----------------------------------------------------------------------
*/
Tcl_ExitProc *
Tcl_SetExitProc(
Tcl_ExitProc *proc) /* New exit handler for app or NULL */
{
Tcl_ExitProc *prevExitProc;
/*
* Swap the old exit proc for the new one, saving the old one for our
* return value.
*/
Tcl_MutexLock(&exitMutex);
prevExitProc = appExitPtr;
appExitPtr = proc;
Tcl_MutexUnlock(&exitMutex);
return prevExitProc;
}
/*
*----------------------------------------------------------------------
*
* InvokeExitHandlers --
*
* Call the registered exit handlers.
*
* Results:
* None.
*
* Side effects:
* The exit handlers are invoked, and the ExitHandler struct is
* freed.
*
*----------------------------------------------------------------------
*/
static void
InvokeExitHandlers(void)
{
ExitHandler *exitPtr;
Tcl_MutexLock(&exitMutex);
inExit = 1;
for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
* Be careful to remove the handler from the list before invoking its
* callback. This protects us against double-freeing if the callback
* should call Tcl_DeleteExitHandler on itself.
*/
firstExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
ckfree(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Exit --
*
* This function is called to terminate the application.
*
* Results:
* None.
*
* Side effects:
* All existing exit handlers are invoked, then the application ends.
*
*----------------------------------------------------------------------
*/
void
Tcl_Exit(
int status) /* Exit status for application; typically 0
* for normal return, 1 for error return. */
{
Tcl_ExitProc *currentAppExitPtr;
Tcl_MutexLock(&exitMutex);
currentAppExitPtr = appExitPtr;
Tcl_MutexUnlock(&exitMutex);
if (currentAppExitPtr) {
/*
* Warning: this code SHOULD NOT return, as there is code that depends
* on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone
* returns, so critical is this dependcy.
*/
currentAppExitPtr(INT2PTR(status));
Tcl_Panic("AppExitProc returned unexpectedly");
} else {
if (TclFullFinalizationRequested()) {
/*
* Thorough finalization for Valgrind et al.
*/
Tcl_Finalize();
} else {
/*
* Fast and deterministic exit (default behavior)
*/
InvokeExitHandlers();
/*
* Ensure the thread-specific data is initialised as it is used in
* Tcl_FinalizeThread()
*/
(void) TCL_TSD_INIT(&dataKey);
/*
* Now finalize the calling thread only (others are not safely
* reachable). Among other things, this triggers a flush of the
* Tcl_Channels that may have data enqueued.
*/
Tcl_FinalizeThread();
}
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
}
/*
*-------------------------------------------------------------------------
*
* TclInitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
* This function ensures an order for the initialization of subsystems:
*
* 1. that cannot be initialized in lazy order because they are mutually
* dependent.
*
* 2. so that they can be finalized in a known order w/o causing the
* subsequent re-initialization of a subsystem in the act of shutting
* down another.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective initialization routines.
*
*-------------------------------------------------------------------------
*/
void
TclInitSubsystems(void)
{
if (inExit != 0) {
Tcl_Panic("TclInitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
/*
* Double check inside the mutex. There are definitly calls back into
* this routine from some of the functions below.
*/
TclpInitLock();
if (subsystemsInitialized == 0) {
/*
* Have to set this bit here to avoid deadlock with the routines
* below us that call into TclInitSubsystems.
*/
subsystemsInitialized = 1;
/*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
*/
TclInitThreadStorage(); /* Creates master hash table for
* thread local storage */
#if USE_TCLALLOC
TclInitAlloc(); /* Process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
#endif
TclpInitPlatform(); /* Creates signal handler(s) */
TclInitDoubleConversion(); /* Initializes constants for
* converting to/from double. */
TclInitObjSubsystem(); /* Register obj types, create
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
TclpSetInterfaces();
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
}
TclpInitUnlock();
}
TclInitNotifier();
}
/*
*----------------------------------------------------------------------
*
* Tcl_Finalize --
*
* Shut down Tcl. First calls registered exit handlers, then carefully
* shuts down various subsystems. Should be invoked by user before the
* Tcl shared library is being unloaded in an embedded context.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
void
Tcl_Finalize(void)
{
ExitHandler *exitPtr;
/*
* Invoke exit handlers first.
*/
InvokeExitHandlers();
TclpInitLock();
if (subsystemsInitialized == 0) {
goto alreadyFinalized;
}
subsystemsInitialized = 0;
/*
* Ensure the thread-specific data is initialised as it is used in
* Tcl_FinalizeThread()
*/
(void) TCL_TSD_INIT(&dataKey);
/*
* Clean up after the current thread now, after exit handlers. In
* particular, the testexithandler command sets up something that writes
* to standard output, which gets closed. Note that there is no
* thread-local storage or IO subsystem after this call.
*/
Tcl_FinalizeThread();
/*
* Now invoke late (process-wide) exit handlers.
*/
Tcl_MutexLock(&exitMutex);
for (exitPtr = firstLateExitPtr; exitPtr != NULL;
exitPtr = firstLateExitPtr) {
/*
* Be careful to remove the handler from the list before invoking its
* callback. This protects us against double-freeing if the callback
* should call Tcl_DeleteLateExitHandler on itself.
*/
firstLateExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
ckfree(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
/*
* Now finalize the Tcl execution environment. Note that this must be done
* after the exit handlers, because there are order dependencies.
*/
TclFinalizeEvaluation();
TclFinalizeExecution();
TclFinalizeEnvironment();
/*
* Finalizing the filesystem must come after anything which might
* conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* Undo all Tcl_ObjType registrations, and reset the master list of free
* Tcl_Obj's. After this returns, no more Tcl_Obj's should be allocated or
* freed.
*
* Note in particular that TclFinalizeObjects() must follow
* TclFinalizeFilesystem() because TclFinalizeFilesystem free's the
* Tcl_Obj that holds the path of the current working directory.
*/
TclFinalizeObjects();
/*
* We must be sure the encoding finalization doesn't need to examine the
* filesystem in any way. Since it only needs to clean up internal data
* structures, this is fine.
*/
TclFinalizeEncodingSubsystem();
Tcl_SetPanicProc(NULL);
/*
* Repeat finalization of the thread local storage once more. Although
* this step is already done by the Tcl_FinalizeThread call above, series
* of events happening afterwards may re-initialize TSD slots. Those need
* to be finalized again, otherwise we're leaking memory chunks. Very
* important to note is that things happening afterwards should not
* reference anything which may re-initialize TSD's. This includes freeing
* Tcl_Objs's, among other things.
*
* This fixes the Tcl Bug #990552.
*/
TclFinalizeThreadData();
/*
* Now we can free constants for conversions to/from double.
*/
TclFinalizeDoubleConversion();
/*
* There have been several bugs in the past that cause exit handlers to be
* established during Tcl_Finalize processing. Such exit handlers leave
* malloc'ed memory, and Tcl_FinalizeMemorySubsystem or
* Tcl_FinalizeThreadAlloc will result in a corrupted heap. The result can
* be a mysterious crash on process exit. Check here that nobody's done
* this.
*/
if (firstExitPtr != NULL) {
Tcl_Panic("exit handlers were created during Tcl_Finalize");
}
TclFinalizePreserve();
/*
* Free synchronization objects. There really should only be one thread
* alive at this moment.
*/
TclFinalizeSynchronization();
/*
* Close down the thread-specific object allocator.
*/
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
TclFinalizeThreadAlloc();
#endif
/*
* We defer unloading of packages until very late to avoid memory access
* issues. Both exit callbacks and synchronization variables may be stored
* in packages.
*
* Note that TclFinalizeLoad unloads packages in the reverse of the order
* they were loaded in (i.e. last to be loaded is the first to be
* unloaded). This can be important for correct unloading when
* dependencies exist.
*
* Once load has been finalized, we will have deleted any temporary copies
* of shared libraries and can therefore reset the filesystem to its
* original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
* At this point, there should no longer be any ckalloc'ed memory.
*/
TclFinalizeMemorySubsystem();
alreadyFinalized:
TclFinalizeLock();
}
/*
*----------------------------------------------------------------------
*
* Tcl_FinalizeThread --
*
* Runs the exit handlers to allow Tcl to clean up its state about a
* particular thread.
*
* Results:
* None.
*
* Side effects:
* Varied, see the respective finalization routines.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeThread(void)
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr;
/*
* We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
* we don't want to initialize the data block if it hasn't been
* initialized already.
*/
tsdPtr = TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->firstExitPtr) {
/*
* Be careful to remove the handler from the list before invoking
* its callback. This protects us against double-freeing if the
* callback should call Tcl_DeleteThreadExitHandler on itself.
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
exitPtr->proc(exitPtr->clientData);
ckfree(exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
TclFinalizeThreadObjects();
}
/*
* Blow away all thread local storage blocks.
*
* Note that Tcl API allows creation of threads which do not use any Tcl
* interp or other Tcl subsytems. Those threads might, however, use thread
* local storage, so we must unconditionally finalize it.
*
* Fix [Bug #571002]
*/
TclFinalizeThreadData();
}
/*
*----------------------------------------------------------------------
*
* TclInExit --
*
* Determines if we are in the middle of exit-time cleanup.
*
* Results:
* If we are in the middle of exiting, 1, otherwise 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclInExit(void)
{
return inExit;
}
/*
*----------------------------------------------------------------------
*
* TclInThreadExit --
*
* Determines if we are in the middle of thread exit-time cleanup.
*
* Results:
* If we are in the middle of exiting this thread, 1, otherwise 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit(void)
{
ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
}
return tsdPtr->inExit;
}
/*
*----------------------------------------------------------------------
*
* Tcl_VwaitObjCmd --
*
* This function is invoked to process the "vwait" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_VwaitObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
while (!done && foundEvent) {
foundEvent = Tcl_DoOneEvent(TCL_ALL_EVENTS);
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
break;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
break;
}
}
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done);
if (!foundEvent) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't wait for variable \"%s\": would wait forever",
nameString));
Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", NULL);
return TCL_ERROR;
}
if (!done) {
/*
* The interpreter's result was already set to the right error message
* prior to exiting the loop above.
*/
return TCL_ERROR;
}
/*
* Clear out the interpreter's result, since it may have been set by event
* handlers.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
/* ARGSUSED */
static char *
VwaitVarProc(
ClientData clientData, /* Pointer to integer to set to 1. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
int *donePtr = clientData;
*donePtr = 1;
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpdateObjCmd --
*
* This function is invoked to process the "update" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_UpdateObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
int flags = 0; /* Initialized to avoid compiler warning. */
static const char *const updateOptions[] = {"idletasks", NULL};
enum updateOptions {OPT_IDLETASKS};
if (objc == 1) {
flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
} else if (objc == 2) {
if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum updateOptions) optionIndex) {
case OPT_IDLETASKS:
flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
break;
default:
Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions");
}
} else {
Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?");
return TCL_ERROR;
}
while (Tcl_DoOneEvent(flags) != 0) {
if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
return TCL_ERROR;
}
if (Tcl_LimitExceeded(interp)) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj("limit exceeded", -1));
return TCL_ERROR;
}
}
/*
* Must clear the interpreter's result because event handlers could have
* executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
#ifdef TCL_THREADS
/*
*----------------------------------------------------------------------
*
* NewThreadProc --
*
* Bootstrap function of a new Tcl thread.
*
* Results:
* None.
*
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
*----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
ClientData clientData)
{
ThreadClientData *cdPtr = clientData;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
ckfree(clientData); /* Allocated in Tcl_CreateThread() */
threadProc(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThread --
*
* This function creates a new thread. This actually belongs to the
* tclThread.c file but since we use some private data structures local
* to this file, it is placed here.
*
* Results:
* TCL_OK if the thread could be created. The thread ID is returned in a
* parameter.
*
* Side effects:
* A new thread is created.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#ifdef TCL_THREADS
ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
int result;
cdPtr->proc = proc;
cdPtr->clientData = clientData;
result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
if (result != TCL_OK) {
ckfree(cdPtr);
}
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
d='n116' href='#n116'>116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
/*
* tclOOInt.h --
*
* This file contains the structure definitions and some of the function
* declarations for the object-system (NB: not Tcl_Obj, but ::oo).
*
* Copyright (c) 2006-2012 by Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef TCL_OO_INTERNAL_H
#define TCL_OO_INTERNAL_H 1
#include "tclInt.h"
#include "tclOO.h"
/*
* Hack to make things work with Objective C. Note that ObjC isn't really
* supported, but we don't want to to be actively hostile to it. [Bug 2163447]
*/
#ifdef __OBJC__
#define Class TclOOClass
#define Object TclOOObject
#endif /* __OBJC__ */
/*
* Forward declarations.
*/
struct CallChain;
struct Class;
struct Foundation;
struct Object;
/*
* The data that needs to be stored per method. This record is used to collect
* information about all sorts of methods, including forwards, constructors
* and destructors.
*/
typedef struct Method {
const Tcl_MethodType *typePtr;
/* The type of method. If NULL, this is a
* special flag record which is just used for
* the setting of the flags field. */
int refCount;
ClientData clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
struct Object *declaringObjectPtr;
/* The object that declares this method, or
* NULL if it was declared by a class. */
struct Class *declaringClassPtr;
/* The class that declares this method, or
* NULL if it was declared directly on an
* object. */
int flags; /* Assorted flags. Includes whether this
* method is public/exported or not. */
} Method;
/*
* Pre- and post-call callbacks, to allow procedure-like methods to be fine
* tuned in their behaviour.
*/
typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished);
typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
typedef void (TclOO_PmCDDeleteProc)(ClientData clientData);
typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData);
/*
* Procedure-like methods have the following extra information.
*/
typedef struct ProcedureMethod {
int version; /* Version of this structure. Currently must
* be 0. */
Proc *procPtr; /* Core of the implementation of the method;
* includes the argument definition and the
* body bytecodes. */
int flags; /* Flags to control features. */
int refCount;
ClientData clientData;
TclOO_PmCDDeleteProc *deleteClientdataProc;
TclOO_PmCDCloneProc *cloneClientdataProc;
ProcErrorProc *errProc; /* Replacement error handler. */
TclOO_PreCallProc *preCallProc;
/* Callback to allow for additional setup
* before the method executes. */
TclOO_PostCallProc *postCallProc;
/* Callback to allow for additional cleanup
* after the method executes. */
GetFrameInfoValueProc *gfivProc;
/* Callback to allow for fine tuning of how
* the method reports itself. */
} ProcedureMethod;
#define TCLOO_PROCEDURE_METHOD_VERSION 0
/*
* Flags for use in a ProcedureMethod.
*
* When the USE_DECLARER_NS flag is set, the method will use the namespace of
* the object or class that declared it (or the clone of it, if it was from
* such that the implementation of the method came to the particular use)
* instead of the namespace of the object on which the method was invoked.
* This flag must be distinct from all others that are associated with
* methods.
*/
#define USE_DECLARER_NS 0x80
/*
* Forwarded methods have the following extra information.
*/
typedef struct ForwardMethod {
Tcl_Obj *prefixObj; /* The list of values to use to replace the
* object and method name with. Will be a
* non-empty list. */
int fullyQualified; /* If 1, the command name is fully qualified
* and we should let the default Tcl mechanism
* handle the command lookup because it is
* more efficient. If 0, we need to do a
* specialized lookup based on the current
* object's namespace. */
} ForwardMethod;
/*
* Helper definitions that declare a "list" array. The two varieties are
* either optimized for simplicity (in the case that the whole array is
* typically assigned at once) or efficiency (in the case that the array is
* expected to be expanded over time). These lists are designed to be iterated
* over with the help of the FOREACH macro (see later in this file).
*
* The "num" field always counts the number of listType_t elements used in the
* "list" field. When a "size" field exists, it describes how many elements
* are present in the list; when absent, exactly "num" elements are present.
*/
#define LIST_STATIC(listType_t) \
struct { int num; listType_t *list; }
#define LIST_DYNAMIC(listType_t) \
struct { int num, size; listType_t *list; }
/*
* Now, the definition of what an object actually is.
*/
typedef struct Object {
struct Foundation *fPtr; /* The basis for the object system. Putting
* this here allows the avoidance of quite a
* lot of hash lookups on the critical path
* for object invokation and creation. */
Tcl_Namespace *namespacePtr;/* This object's tame namespace. */
Tcl_Command command; /* Reference to this object's public
* command. */
Tcl_Command myCommand; /* Reference to this object's internal
* command. */
struct Class *selfCls; /* This object's class. */
Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to
* Method* mapping. */
LIST_STATIC(struct Class *) mixins;
/* Classes mixed into this object. */
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* All classes have this non-NULL; it points
* to the class structure. Everything else has
* this NULL. */
int refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism is there to
* avoid Tcl_Preserve. */
int flags;
int creationEpoch; /* Unique value to make comparisons of objects
* easier. */
int epoch; /* Per-object epoch, incremented when the way
* an object should resolve call chains is
* changed. */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
* the ClientData values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
Tcl_HashTable *chainCache; /* Place to keep unused contexts. This table
* is indexed by method name as Tcl_Obj. */
Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
/* Function to allow remapping of method
* names. For itcl-ng. */
LIST_STATIC(Tcl_Obj *) variables;
} Object;
#define OBJECT_DELETED 1 /* Flag to say that an object has been
* destroyed. */
#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been
* called. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
* filter; when set, filters are *not*
* processed on the object, preventing nasty
* recursive filtering problems. */
#define USE_CLASS_CACHE 0x4000 /* Flag set to say that the object is a pure
* instance of the class, and has had nothing
* added that changes the dispatch chain (i.e.
* no methods, mixins, or filters. */
#define ROOT_CLASS 0x8000 /* Flag to say that this object is the root
* class of classes, and should be treated
* specially during teardown (and in a few
* other spots). */
#define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the
* unknown method handler at that point. */
/*
* And the definition of a class. Note that every class also has an associated
* object, through which it is manipulated.
*/
typedef struct Class {
Object *thisPtr; /* Reference to the object associated with
* this class. */
int refCount; /* Number of strong references to this class.
* Weak references are not counted; the
* purpose of this is to avoid Tcl_Preserve as
* that is quite slow. */
int flags; /* Assorted flags. */
LIST_STATIC(struct Class *) superclasses;
/* List of superclasses, used for generation
* of method call chains. */
LIST_DYNAMIC(struct Class *) subclasses;
/* List of subclasses, used to ensure deletion
* of dependent entities happens properly when
* the class itself is deleted. */
LIST_DYNAMIC(Object *) instances;
/* List of instances, used to ensure deletion
* of dependent entities happens properly when
* the class itself is deleted. */
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names, used for generation
* of method call chains. */
LIST_STATIC(struct Class *) mixins;
/* List of mixin classes, used for generation
* of method call chains. */
LIST_DYNAMIC(struct Class *) mixinSubs;
/* List of classes that this class is mixed
* into, used to ensure deletion of dependent
* entities happens properly when the class
* itself is deleted. */
Tcl_HashTable classMethods; /* Hash table of all methods. Hash maps from
* the (Tcl_Obj*) method name to the (Method*)
* method record. */
Method *constructorPtr; /* Method record of the class constructor (if
* any). */
Method *destructorPtr; /* Method record of the class destructor (if
* any). */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
* the ClientData values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
struct CallChain *constructorChainPtr;
struct CallChain *destructorChainPtr;
Tcl_HashTable *classChainCache;
/* Places where call chains are stored. For
* constructors, the class chain is always
* used. For destructors and ordinary methods,
* the class chain is only used when the
* object doesn't override with its own mixins
* (and filters and method implementations for
* when getting method chains). */
LIST_STATIC(Tcl_Obj *) variables;
} Class;
/*
* The foundation of the object system within an interpreter contains
* references to the key classes and namespaces, together with a few other
* useful bits and pieces. Probably ought to eventually go in the Interp
* structure itself.
*/
typedef struct ThreadLocalData {
int nsCount; /* Master epoch counter is used for keeping
* the values used in Tcl_Obj internal
* representations sane. Must be thread-local
* because Tcl_Objs can cross interpreter
* boundaries within a thread (objects don't
* generally cross threads). */
} ThreadLocalData;
typedef struct Foundation {
Tcl_Interp *interp;
Class *objectCls; /* The root of the object system. */
Class *classCls; /* The class of all classes. */
Tcl_Namespace *ooNs; /* Master ::oo namespace. */
Tcl_Namespace *defineNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::define" command acts as a special kind
* of ensemble for this namespace. */
Tcl_Namespace *objdefNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::objdefine" command acts as a special
* kind of ensemble for this namespace. */
Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
* only valid when executing inside a
* procedural method. */
int epoch; /* Used to invalidate method chains when the
* class structure changes. */
ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique
* namespace to each object. */
Tcl_Obj *unknownMethodNameObj;
/* Shared object containing the name of the
* unknown method handler method. */
Tcl_Obj *constructorName; /* Shared object containing the "name" of a
* constructor. */
Tcl_Obj *destructorName; /* Shared object containing the "name" of a
* destructor. */
Tcl_Obj *clonedName; /* Shared object containing the name of a
* "<cloned>" pseudo-constructor. */
Tcl_Obj *defineName; /* Fully qualified name of oo::define. */
} Foundation;
/*
* A call context structure is built when a method is called. They contain the
* chain of method implementations that are to be invoked by a particular
* call, and the process of calling walks the chain, with the [next] command
* proceeding to the next entry in the chain.
*/
#define CALL_CHAIN_STATIC_SIZE 4
struct MInvoke {
Method *mPtr; /* Reference to the method implementation
* record. */
int isFilter; /* Whether this is a filter invokation. */
Class *filterDeclarer; /* What class decided to add the filter; if
* NULL, it was added by the object. */
};
typedef struct CallChain {
int objectCreationEpoch; /* The object's creation epoch. Note that the
* object reference is not stored in the call
* chain; it is in the call context. */
int objectEpoch; /* Local (object structure) epoch counter
* snapshot. */
int epoch; /* Global (class structure) epoch counter
* snapshot. */
int flags; /* Assorted flags, see below. */
int refCount; /* Reference count. */
int numChain; /* Size of the call chain. */
struct MInvoke *chain; /* Array of call chain entries. May point to
* staticChain if the number of entries is
* small. */
struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
} CallChain;
typedef struct CallContext {
Object *oPtr; /* The object associated with this call. */
int index; /* Index into the call chain of the currently
* executing method implementation. */
int skip; /* Current number of arguments to skip; can
* vary depending on whether it is a direct
* method call or a continuation via the
* [next] command. */
CallChain *callPtr; /* The actual call chain. */
} CallContext;
/*
* Bits for the 'flags' field of the call chain.
*/
#define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */
#define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances
* only) method. */
#define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */
#define CONSTRUCTOR 0x08 /* This is a constructor. */
#define DESTRUCTOR 0x10 /* This is a destructor. */
/*
* Structure containing definition information about basic class methods.
*/
typedef struct {
const char *name; /* Name of the method in question. */
int isPublic; /* Whether the method is public by default. */
Tcl_MethodType definition; /* How to call the method. */
} DeclaredClassMethod;
/*
*----------------------------------------------------------------
* Commands relating to OO support.
*----------------------------------------------------------------
*/
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOONextObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
/*
* Method implementations (in tclOOBasic.c).
*/
MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Class_Create(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Class_New(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
/*
* Private definitions, some of which perhaps ought to be exposed properly or
* maybe just put in the internal stubs table.
*/
MODULE_SCOPE void TclOOAddToInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr);
MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr);
MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp,
Tcl_Class cls, const char *nameStr,
const char *nsNameStr, int objc,
Tcl_Obj *const *objv, int skip,
Tcl_Object *objectPtr);
MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void TclOODelMethodRef(Method *method);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
Tcl_Obj *methodNameObj, int flags,
Tcl_Obj *cacheInThisObj);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
Tcl_Obj *methodNameObj, int flags);
MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr);
MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr);
MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr);
MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr,
int flags, const char ***stringsPtr);
MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags,
const char ***stringsPtr);
MODULE_SCOPE int TclOOInit(Tcl_Interp *interp);
MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp);
MODULE_SCOPE int TclOOInvokeContext(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_ObjectContext context, int objc,
Tcl_Obj *const *objv, int skip);
MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
Class *mixinPtr);
MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
Class *superPtr);
MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
CallChain *callPtr);
MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr,
CallContext *contextPtr);
MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
/*
* Include all the private API, generated from tclOO.decls.
*/
#include "tclOOIntDecls.h"
/*
* A convenience macro for iterating through the lists used in the internal
* memory management of objects. This is a bit gnarly because we want to do
* the assignment of the picked-out value only when the body test succeeds,
* but we cannot rely on the assigned value being useful, forcing us to do
* some nasty stuff with the comma operator. The compiler's optimizer should
* be able to sort it all out!
*
* REQUIRES DECLARATION: int i;
*/
#define FOREACH(var,ary) \
for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
* sets up the declarations needed for the main macro, FOREACH_HASH, which
* does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
* only iterates over values.
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key,val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\
(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
((val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
/*
* Convenience macro for duplicating a list. Needs no external declaration,
* but all arguments are used multiple times and so must have no side effects.
*/
#undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */
#define DUPLICATE(target,source,type) \
do { \
register unsigned len = sizeof(type) * ((target).num=(source).num);\
if (len != 0) { \
memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
} else { \
(target).list = NULL; \
} \
} while(0)
/*
* Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
*/
#define AddRef(ptr) ((ptr)->refCount++)
#define DelRef(ptr) do { \
if (--(ptr)->refCount < 1) { \
ckfree((char *) (ptr)); \
} \
} while(0)
#endif /* TCL_OO_INTERNAL_H */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|