/*
* tclResult.c --
*
* This file contains code to manage the interpreter result.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclResult.c,v 1.28 2005/06/02 03:11:38 dgp Exp $
*/
#include "tclInt.h"
/* Indices of the standard return options dictionary keys */
enum returnKeys {
KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE,
KEY_LEVEL, KEY_OPTIONS, KEY_LAST
};
/*
* Function prototypes for local procedures in this file:
*/
static Tcl_Obj ** GetKeys();
static void ReleaseKeys _ANSI_ARGS_((ClientData clientData));
static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
int newSpace));
/*
* This structure is used to take a snapshot of the interpreter
* state in Tcl_SaveInterpState. You can snapshot the state,
* execute a command, and then back up to the result or the
* error that was previously in progress.
*/
typedef struct InterpState {
int status; /* return code status */
int flags; /* Each remaining field saves */
int returnLevel; /* the corresponding field of */
int returnCode; /* the Interp struct. These */
Tcl_Obj *errorInfo; /* fields take together are the */
Tcl_Obj *errorCode; /* "state" of the interp. */
Tcl_Obj *returnOpts;
Tcl_Obj *objResult;
} InterpState;
/*
*----------------------------------------------------------------------
*
* Tcl_SaveInterpState --
*
* Fills a token with a snapshot of the current state of the
* interpreter. The snapshot can be restored at any point by
* TclRestoreInterpState.
*
* The token returned must be eventally passed to one of the
* routines TclRestoreInterpState or TclDiscardInterpState,
* or there will be a memory leak.
*
* Results:
* Returns a token representing the interp state.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_InterpState
Tcl_SaveInterpState(interp, status)
Tcl_Interp* interp; /* Interpreter's state to be saved */
int status; /* status code for current operation */
{
Interp *iPtr = (Interp *)interp;
InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
statePtr->returnLevel = iPtr->returnLevel;
statePtr->returnCode = iPtr->returnCode;
statePtr->errorInfo = iPtr->errorInfo;
if (statePtr->errorInfo) {
Tcl_IncrRefCount(statePtr->errorInfo);
}
statePtr->errorCode = iPtr->errorCode;
if (statePtr->errorCode) {
Tcl_IncrRefCount(statePtr->errorCode);
}
statePtr->returnOpts = iPtr->returnOpts;
if (statePtr->returnOpts) {
Tcl_IncrRefCount(statePtr->returnOpts);
}
statePtr->objResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(statePtr->objResult);
return (Tcl_InterpState) statePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RestoreInterpState --
*
* Accepts an interp and a token previously returned by
* Tcl_SaveInterpState. Restore the state of the interp
* to what it was at the time of the Tcl_SaveInterpState call.
*
* Results:
* Returns the status value originally passed in to Tcl_SaveInterpState.
*
* Side effects:
* Restores the interp state and frees memory held by token.
*
*----------------------------------------------------------------------
*/
int
Tcl_RestoreInterpState(interp, state)
Tcl_Interp* interp; /* Interpreter's state to be restored*/
Tcl_InterpState state; /* saved interpreter state */
{
Interp *iPtr = (Interp *)interp;
InterpState *statePtr = (InterpState *)state;
int status = statePtr->status;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
iPtr->flags |= (statePtr->flags & ERR_ALREADY_LOGGED);
iPtr->returnLevel = statePtr->returnLevel;
iPtr->returnCode = statePtr->returnCode;
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
}
iPtr->errorInfo = statePtr->errorInfo;
if (iPtr->errorInfo) {
Tcl_IncrRefCount(iPtr->errorInfo);
}
if (iPtr->errorCode) {
Tcl_DecrRefCount(iPtr->errorCode);
}
iPtr->errorCode = statePtr->errorCode;
if (iPtr->errorCode) {
Tcl_IncrRefCount(iPtr->errorCode);
}
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
iPtr->returnOpts = statePtr->returnOpts;
if (iPtr->returnOpts) {
Tcl_IncrRefCount(iPtr->returnOpts);
}
Tcl_SetObjResult(interp, statePtr->objResult);
Tcl_DiscardInterpState(state);
return status;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DiscardInterpState --
*
* Accepts a token previously returned by Tcl_SaveInterpState.
* Frees the memory it uses.
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
void
Tcl_DiscardInterpState(state)
Tcl_InterpState state; /* saved interpreter state */
{
InterpState *statePtr = (InterpState *)state;
if (statePtr->errorInfo) {
Tcl_DecrRefCount(statePtr->errorInfo);
}
if (statePtr->errorCode) {
Tcl_DecrRefCount(statePtr->errorCode);
}
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
Tcl_DecrRefCount(statePtr->objResult);
ckfree((char*) statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SaveResult --
*
* Takes a snapshot of the current result state of the interpreter.
* The snapshot can be restored at any point by
* Tcl_RestoreResult. Note that this routine does not
* preserve the errorCode, errorInfo, or flags fields so it
* should not be used if an error is in progress.
*
* Once a snapshot is saved, it must be restored by calling
* Tcl_RestoreResult, or discarded by calling
* Tcl_DiscardResult.
*
* Results:
* None.
*
* Side effects:
* Resets the interpreter result.
*
*----------------------------------------------------------------------
*/
void
Tcl_SaveResult(interp, statePtr)
Tcl_Interp *interp; /* Interpreter to save. */
Tcl_SavedResult *statePtr; /* Pointer to state structure. */
{
Interp *iPtr = (Interp *) interp;
/*
* Move the result object into the save state. Note that we don't need
* to change its refcount because we're moving it, not adding a new
* reference. Put an empty object into the interpreter.
*/
statePtr->objResultPtr = iPtr->objResultPtr;
iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
/*
* Save the string result.
*/
statePtr->freeProc = iPtr->freeProc;
if (iPtr->result == iPtr->resultSpace) {
/*
* Copy the static string data out of the interp buffer.
*/
statePtr->result = statePtr->resultSpace;
strcpy(statePtr->result, iPtr->result);
statePtr->appendResult = NULL;
} else if (iPtr->result == iPtr->appendResult) {
/*
* Move the append buffer out of the interp.
*/
statePtr->appendResult = iPtr->appendResult;
statePtr->appendAvl = iPtr->appendAvl;
statePtr->appendUsed = iPtr->appendUsed;
statePtr->result = statePtr->appendResult;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
} else {
/*
* Move the dynamic or static string out of the interpreter.
*/
statePtr->result = iPtr->result;
statePtr->appendResult = NULL;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
iPtr->freeProc = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RestoreResult --
*
* Restores the state of the interpreter to a snapshot taken
* by Tcl_SaveResult. After this call, the token for
* the interpreter state is no longer valid.
*
* Results:
* None.
*
* Side effects:
* Restores the interpreter result.
*
*----------------------------------------------------------------------
*/
void
Tcl_RestoreResult(interp, statePtr)
Tcl_Interp* interp; /* Interpreter being restored. */
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
{
Interp *iPtr = (Interp *) interp;
Tcl_ResetResult(interp);
/*
* Restore the string result.
*/
iPtr->freeProc = statePtr->freeProc;
if (statePtr->result == statePtr->resultSpace) {
/*
* Copy the static string data into the interp buffer.
*/
iPtr->result = iPtr->resultSpace;
strcpy(iPtr->result, statePtr->result);
} else if (statePtr->result == statePtr->appendResult) {
/*
* Move the append buffer back into the interp.
*/
if (iPtr->appendResult != NULL) {
ckfree((char *)iPtr->appendResult);
}
iPtr->appendResult = statePtr->appendResult;
iPtr->appendAvl = statePtr->appendAvl;
iPtr->appendUsed = statePtr->appendUsed;
iPtr->result = iPtr->appendResult;
} else {
/*
* Move the dynamic or static string back into the interpreter.
*/
iPtr->result = statePtr->result;
}
/*
* Restore the object result.
*/
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = statePtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DiscardResult --
*
* Frees the memory associated with an interpreter snapshot
* taken by Tcl_SaveResult. If the snapshot is not
* restored, this procedure must be called to discard it,
* or the memory will be lost.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_DiscardResult(statePtr)
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
} else if (statePtr->freeProc) {
if (statePtr->freeProc == TCL_DYNAMIC) {
ckfree(statePtr->result);
} else {
(*statePtr->freeProc)(statePtr->result);
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetResult --
*
* Arrange for "result" to be the Tcl return value.
*
* Results:
* None.
*
* Side effects:
* interp->result is left pointing either to "result"
* or to a copy of it. Also, the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetResult(interp, result, freeProc)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
register char *result; /* Value to be returned. If NULL, the
* result is set to an empty string. */
Tcl_FreeProc *freeProc; /* Gives information about the string:
* TCL_STATIC, TCL_VOLATILE, or the address
* of a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
int length;
register Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
if (result == NULL) {
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
length = strlen(result);
if (length > TCL_RESULT_SIZE) {
iPtr->result = (char *) ckalloc((unsigned) length+1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
}
strcpy(iPtr->result, result);
} else {
iPtr->result = result;
iPtr->freeProc = freeProc;
}
/*
* If the old result was dynamically-allocated, free it up. Do it
* here, rather than at the beginning, in case the new result value
* was part of the old result value.
*/
if (oldFreeProc != 0) {
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
(*oldFreeProc)(oldResult);
}
}
/*
* Reset the object result since we just set the string result.
*/
ResetObjResult(iPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStringResult --
*
* Returns an interpreter's result value as a string.
*
* Results:
* The interpreter's result as a string.
*
* Side effects:
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetStringResult(interp)
register Tcl_Interp *interp; /* Interpreter whose result to return. */
{
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
if (*(interp->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
return interp->result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
*
* Arrange for objPtr to be an interpreter's result value.
*
* Results:
* None.
*
* Side effects:
* interp->objResultPtr is left pointing to the object referenced
* by objPtr. The object's reference count is incremented since
* there is now a new reference to it. The reference count for any
* old objResultPtr value is decremented. Also, the string result
* is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjResult(interp, objPtr)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return object value. */
register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
* obj result is made an empty string
* object. */
{
register Interp *iPtr = (Interp *) interp;
register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
/*
* We wait until the end to release the old object result, in case
* we are setting the result to itself.
*/
TclDecrRefCount(oldObjResult);
/*
* Reset the string result since we just set the result object.
*/
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetObjResult --
*
* Returns an interpreter's result value as a Tcl object. The object's
* reference count is not modified; the caller must do that if it
* needs to hold on to a long-term reference to it.
*
* Results:
* The interpreter's result as an object.
*
* Side effects:
* If the interpreter has a non-empty string result, the result object
* is either empty or stale because some procedure set interp->result
* directly. If so, the string result is moved to the result object
* then the string result is reset.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetObjResult(interp)
Tcl_Interp *interp; /* Interpreter whose result to return. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objResultPtr;
int length;
/*
* If the string result is non-empty, move the string result to the
* object result, then reset the string result.
*/
if (*(iPtr->result) != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
}
return iPtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResultVA --
*
* Append a variable number of strings onto the interpreter's
* result.
*
* Results:
* None.
*
* Side effects:
* The result of the interpreter given by the first argument is
* extended by the strings in the va_list (up to a terminating
* NULL argument).
*
* If the string result is non-empty, the object result forced to
* be a duplicate of it first. There will be a string result
* afterwards.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendResultVA(interp, argList)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
va_list argList; /* Variable argument list. */
{
Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(objPtr)) {
objPtr = Tcl_DuplicateObj(objPtr);
}
Tcl_AppendStringsToObjVA(objPtr, argList);
Tcl_SetObjResult(interp, objPtr);
/*
* Strictly we should call Tcl_GetStringResult(interp) here to
* make sure that interp->result is correct according to the old
* contract, but that makes the performance of much code (e.g. in
* Tk) absolutely awful. So we leave it out; code that really
* wants interp->result can just insert the calls to
* Tcl_GetStringResult() itself. [Patch 1041072 discussion]
*/
#ifdef USE_DIRECT_INTERP_RESULT_ACCESS
/*
* Ensure that the interp->result is legal so old Tcl 7.* code
* still works. There's still embarrasingly much of it about...
*/
(void) Tcl_GetStringResult(interp);
#endif /* USE_DIRECT_INTERP_RESULT_ACCESS */
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResult --
*
* Append a variable number of strings onto the interpreter's
* result.
*
* Results:
* None.
*
* Side effects:
* The result of the interpreter given by the first argument is
* extended by the strings given by the second and following
* arguments (up to a terminating NULL argument).
*
* If the string result is non-empty, the object result forced to
* be a duplicate of it first. There will be a string result
* afterwards.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
Tcl_Interp *interp;
va_list argList;
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
Tcl_AppendResultVA(interp, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendElement --
*
* Convert a string to a valid Tcl list element and append it to the
* result (which is ostensibly a list).
*
* Results:
* None.
*
* Side effects:
* The result in the interpreter given by the first argument is
* extended with a list element converted from string. A separator
* space is added before the converted list element unless the current
* result is empty, contains the single character "{", or ends in " {".
*
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendElement(interp, element)
Tcl_Interp *interp; /* Interpreter whose result is to be
* extended. */
CONST char *element; /* String to convert to list element and
* add to result. */
{
Interp *iPtr = (Interp *) interp;
char *dst;
int size;
int flags;
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
/*
* See how much space is needed, and grow the append buffer if
* needed to accommodate the list element.
*/
size = Tcl_ScanElement(element, &flags) + 1;
if ((iPtr->result != iPtr->appendResult)
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
}
/*
* Convert the string into a list element and copy it to the
* buffer that's forming, with a space separator if needed.
*/
dst = iPtr->appendResult + iPtr->appendUsed;
if (TclNeedSpace(iPtr->appendResult, dst)) {
iPtr->appendUsed++;
*dst = ' ';
dst++;
/*
* If we need a space to separate this element from preceding
* stuff, then this element will not lead a list, and need not
* have it's leading '#' quoted.
*/
flags |= TCL_DONT_QUOTE_HASH;
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
}
/*
*----------------------------------------------------------------------
*
* SetupAppendBuffer --
*
* This procedure makes sure that there is an append buffer properly
* initialized, if necessary, from the interpreter's result, and
* that it has at least enough room to accommodate newSpace new
* bytes of information.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
SetupAppendBuffer(iPtr, newSpace)
Interp *iPtr; /* Interpreter whose result is being set up. */
int newSpace; /* Make sure that at least this many bytes
* of new information may be added. */
{
int totalSpace;
/*
* Make the append buffer larger, if that's necessary, then copy the
* result into the append buffer and make the append buffer the official
* Tcl result.
*/
if (iPtr->result != iPtr->appendResult) {
/*
* If an oversized buffer was used recently, then free it up
* so we go back to a smaller buffer. This avoids tying up
* memory forever after a large operation.
*/
if (iPtr->appendAvl > 500) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
}
iPtr->appendUsed = strlen(iPtr->result);
} else if (iPtr->result[iPtr->appendUsed] != 0) {
/*
* Most likely someone has modified a result created by
* Tcl_AppendResult et al. so that it has a different size.
* Just recompute the size.
*/
iPtr->appendUsed = strlen(iPtr->result);
}
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
char *new;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
new = (char *) ckalloc((unsigned) totalSpace);
strcpy(new, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
iPtr->appendResult = new;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
}
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FreeResult --
*
* This procedure frees up the memory associated with an interpreter's
* string result. It also resets the interpreter's result object.
* Tcl_FreeResult is most commonly used when a procedure is about to
* replace one result value with another.
*
* Results:
* None.
*
* Side effects:
* Frees the memory associated with interp's string result and sets
* interp->freeProc to zero, but does not change interp->result or
* clear error state. Resets interp's result object to an unshared
* empty object.
*
*----------------------------------------------------------------------
*/
void
Tcl_FreeResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
register Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
ResetObjResult(iPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ResetResult --
*
* This procedure resets both the interpreter's string and object
* results.
*
* Results:
* None.
*
* Side effects:
* It resets the result object to an unshared empty object. It
* then restores the interpreter's string result area to its default
* initialized state, freeing up any memory that may have been
* allocated. It also clears any error information for the interpreter.
*
*----------------------------------------------------------------------
*/
void
Tcl_ResetResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to clear result. */
{
register Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
if (iPtr->errorCode) {
/* Legacy support */
Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
iPtr->errorCode, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(iPtr->errorCode);
iPtr->errorCode = NULL;
}
if (iPtr->errorInfo) {
/* Legacy support */
Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
iPtr->errorInfo, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
iPtr->returnLevel = 1;
iPtr->returnCode = TCL_OK;
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
iPtr->returnOpts = NULL;
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
*----------------------------------------------------------------------
*
* ResetObjResult --
*
* Procedure used to reset an interpreter's Tcl result object.
*
* Results:
* None.
*
* Side effects:
* Resets the interpreter's result object to an unshared empty string
* object with ref count one. It does not clear any error information
* in the interpreter.
*
*----------------------------------------------------------------------
*/
static void
ResetObjResult(iPtr)
register Interp *iPtr; /* Points to the interpreter whose result
* object should be reset. */
{
register Tcl_Obj *objResultPtr = iPtr->objResultPtr;
if (Tcl_IsShared(objResultPtr)) {
TclDecrRefCount(objResultPtr);
TclNewObj(objResultPtr);
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
if ((objResultPtr->bytes != NULL)
&& (objResultPtr->bytes != tclEmptyStringRep)) {
ckfree((char *) objResultPtr->bytes);
}
objResultPtr->bytes = tclEmptyStringRep;
objResultPtr->length = 0;
TclFreeIntRep(objResultPtr);
objResultPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorCodeVA --
*
* This procedure is called to record machine-readable information
* about an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode field of the interp is modified to hold all of the
* arguments to this procedure, in a list form with each argument
* becoming one element of the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorCodeVA (interp, argList)
Tcl_Interp *interp; /* Interpreter in which to set errorCode */
va_list argList; /* Variable argument list. */
{
Tcl_Obj *errorObj = Tcl_NewObj();
/*
* Scan through the arguments one at a time, appending them to
* the errorCode field as list elements.
*/
while (1) {
char *elem = va_arg(argList, char *);
if (elem == NULL) {
break;
}
Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
}
Tcl_SetObjErrorCode(interp, errorObj);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorCode --
*
* This procedure is called to record machine-readable information
* about an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode field of the interp is modified to hold all of the
* arguments to this procedure, in a list form with each argument
* becoming one element of the list.
*
*----------------------------------------------------------------------
*/
/* VARARGS2 */
void
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
Tcl_Interp *interp;
va_list argList;
/*
* Scan through the arguments one at a time, appending them to
* the errorCode field as list elements.
*/
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
Tcl_SetErrorCodeVA(interp, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjErrorCode --
*
* This procedure is called to record machine-readable information
* about an error that is about to be returned. The caller should
* build a list object up and pass it to this routine.
*
* Results:
* None.
*
* Side effects:
* The errorCode field of the interp is set to the new value.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjErrorCode(interp, errorObjPtr)
Tcl_Interp *interp;
Tcl_Obj *errorObjPtr;
{
Interp *iPtr = (Interp *) interp;
if (iPtr->errorCode) {
Tcl_DecrRefCount(iPtr->errorCode);
}
iPtr->errorCode = errorObjPtr;
Tcl_IncrRefCount(iPtr->errorCode);
}
/*
*----------------------------------------------------------------------
*
* GetKeys --
*
* Returns a Tcl_Obj * array of the standard keys used in the
* return options dictionary.
*
* Broadly sharing one copy of these key values helps with both
* memory efficiency and dictionary lookup times.
*
* Results:
* A Tcl_Obj * array.
*
* Side effects:
* First time called in a thread, creates the keys (allocating
* memory) and arranges for their cleanup at thread exit.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GetKeys()
{
static Tcl_ThreadDataKey returnKeysKey;
Tcl_Obj **keys = Tcl_GetThreadData(&returnKeysKey,
(int) (KEY_LAST * sizeof(Tcl_Obj *)));
if (keys[0] == NULL) {
/* First call in this thread, create the keys... */
int i;
keys[KEY_CODE] = Tcl_NewStringObj("-code", -1);
keys[KEY_ERRORCODE] = Tcl_NewStringObj("-errorcode", -1);
keys[KEY_ERRORINFO] = Tcl_NewStringObj("-errorinfo", -1);
keys[KEY_ERRORLINE] = Tcl_NewStringObj("-errorline", -1);
keys[KEY_LEVEL] = Tcl_NewStringObj("-level", -1);
keys[KEY_OPTIONS] = Tcl_NewStringObj("-options", -1);
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_IncrRefCount(keys[i]);
}
/* ... and arrange for their clenaup. */
Tcl_CreateThreadExitHandler(ReleaseKeys, (ClientData) keys);
}
return keys;
}
/*
*----------------------------------------------------------------------
*
* ReleaseKeys --
*
* Called as a thread exit handler to cleanup return options
* dictionary keys.
*
* Results:
* None.
*
* Side effects:
* Frees memory.
*
*----------------------------------------------------------------------
*/
void
ReleaseKeys(clientData)
ClientData clientData;
{
Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_DecrRefCount(keys[i]);
}
}
/*
*----------------------------------------------------------------------
*
* TclProcessReturn --
*
* Does the work of the [return] command based on the code,
* level, and returnOpts arguments. Note that the code argument
* must agree with the -code entry in returnOpts and the level
* argument must agree with the -level entry in returnOpts, as
* is the case for values returned from TclMergeReturnOptions.
*
* Results:
* Returns the return code the [return] command should return.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclProcessReturn(interp, code, level, returnOpts)
Tcl_Interp *interp;
int code;
int level;
Tcl_Obj *returnOpts;
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *valuePtr;
Tcl_Obj **keys = GetKeys();
/* Store the merged return options */
if (iPtr->returnOpts != returnOpts) {
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
iPtr->returnOpts = returnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
}
if (code == TCL_ERROR) {
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr);
if (valuePtr != NULL) {
int infoLen;
(void) Tcl_GetStringFromObj(valuePtr, &infoLen);
if (infoLen) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
} else {
Tcl_SetErrorCode(interp, "NONE", NULL);
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], &valuePtr);
if (valuePtr != NULL) {
Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine);
}
}
if (level != 0) {
iPtr->returnLevel = level;
iPtr->returnCode = code;
return TCL_RETURN;
}
return code;
}
/*
*----------------------------------------------------------------------
*
* TclMergeReturnOptions --
*
* Parses, checks, and stores the options to the [return] command.
*
* Results:
* Returns TCL_ERROR is any of the option values are invalid.
* Otherwise, returns TCL_OK, and writes the returnOpts, code,
* and level values to the pointers provided.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr)
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a
* (Tcl_Obj *) where the pointer to the
* merged return options dictionary should
* be written */
int *codePtr; /* If not NULL, points to space where the
* -code value should be written */
int *levelPtr; /* If not NULL, points to space where the
* -level value should be written */
{
int code=TCL_OK;
int level = 1;
Tcl_Obj *valuePtr;
Tcl_Obj *returnOpts = Tcl_NewObj();
Tcl_Obj **keys = GetKeys();
for (; objc > 1; objv += 2, objc -= 2) {
int optLen;
CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
int compareLen;
CONST char *compare =
Tcl_GetStringFromObj(keys[KEY_OPTIONS], &compareLen);
if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
Tcl_Obj *dict = objv[1];
nestedOptions:
if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
&search, &keyPtr, &valuePtr, &done)) {
/* Value is not a legal dictionary */
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad ",
compare, " value: expected dictionary but got \"",
TclGetString(objv[1]), "\"", (char *) NULL);
goto error;
}
while (!done) {
Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_OPTIONS], &valuePtr);
if (valuePtr != NULL) {
dict = valuePtr;
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_OPTIONS]);
goto nestedOptions;
}
} else {
Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]);
}
}
/* Check for bogus -code value */
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_CODE], &valuePtr);
if ((valuePtr != NULL)
&& (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) {
static CONST char *returnCodes[] = {
"ok", "error", "return", "break", "continue", NULL
};
if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
NULL, TCL_EXACT, &code)) {
/* Value is not a legal return code */
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad completion code \"",
TclGetString(valuePtr),
"\": must be ok, error, return, break, ",
"continue, or an integer", (char *) NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_CODE]);
}
/* Check for bogus -level value */
Tcl_DictObjGet(NULL, returnOpts, keys[KEY_LEVEL], &valuePtr);
if (valuePtr != NULL) {
if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level))
|| (level < 0)) {
/* Value is not a legal level */
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad -level value: ",
"expected non-negative integer but got \"",
TclGetString(valuePtr), "\"", (char *) NULL);
goto error;
}
Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]);
}
/*
* Convert [return -code return -level X] to
* [return -code ok -level X+1]
*/
if (code == TCL_RETURN) {
level++;
code = TCL_OK;
}
if (codePtr != NULL) {
*codePtr = code;
}
if (levelPtr != NULL) {
*levelPtr = level;
}
if (optionsPtrPtr == NULL) {
/* Not passing back the options (?!), so clean them up */
Tcl_DecrRefCount(returnOpts);
} else {
*optionsPtrPtr = returnOpts;
}
return TCL_OK;
error:
Tcl_DecrRefCount(returnOpts);
return TCL_ERROR;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetReturnOptions --
*
* Packs up the interp state into a dictionary of return options.
*
* Results:
* A dictionary of return options.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetReturnOptions(interp, result)
Tcl_Interp *interp;
int result;
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *options;
Tcl_Obj **keys = GetKeys();
if (iPtr->returnOpts) {
options = Tcl_DuplicateObj(iPtr->returnOpts);
} else {
options = Tcl_NewObj();
}
if (result == TCL_RETURN) {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
Tcl_NewIntObj(iPtr->returnCode));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
Tcl_NewIntObj(iPtr->returnLevel));
} else {
Tcl_DictObjPut(NULL, options, keys[KEY_CODE],
Tcl_NewIntObj(result));
Tcl_DictObjPut(NULL, options, keys[KEY_LEVEL],
Tcl_NewIntObj(0));
}
if (result == TCL_ERROR) {
/*
* When result was an error, fill in any missing values
* for -errorinfo, -errorcode, and -errorline
*/
Tcl_AddObjErrorInfo(interp, "", -1);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
Tcl_NewIntObj(iPtr->errorLine));
}
return options;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_SetReturnOptions --
*
* Accepts an interp and a dictionary of return options, and sets
* the return options of the interp to match the dictionary.
*
* Results:
* A standard status code. Usually TCL_OK, but TCL_ERROR if an
* invalid option value was found in the dictionary. If a -level
* value of 0 is in the dictionary, then the -code value in the
* dictionary will be returned (TCL_OK default).
*
* Side effects:
* Sets the state of the interp.
*
*-------------------------------------------------------------------------
*/
int
Tcl_SetReturnOptions(interp, options)
Tcl_Interp *interp;
Tcl_Obj *options;
{
int objc, level, code;
Tcl_Obj **objv, *mergedOpts;
if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv)
|| (objc % 2)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected dict but got \"",
Tcl_GetString(options), "\"", NULL);
code = TCL_ERROR;
} else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv,
&mergedOpts, &code, &level)) {
code = TCL_ERROR;
} else {
code = TclProcessReturn(interp, code, level, mergedOpts);
}
Tcl_DecrRefCount(options);
return code;
}
/*
*-------------------------------------------------------------------------
*
* TclTransferResult --
*
* Copy the result (and error information) from one interp to
* another. Used when one interp has caused another interp to
* evaluate a script and then wants to transfer the results back
* to itself.
*
* This routine copies the string reps of the result and error
* information. It does not simply increment the refcounts of the
* result and error information objects themselves.
* It is not legal to exchange objects between interps, because an
* object may be kept alive by one interp, but have an internal rep
* that is only valid while some other interp is alive.
*
* Results:
* The target interp's result is set to a copy of the source interp's
* result. The source's errorInfo field may be transferred to the
* target's errorInfo field, and the source's errorCode field may be
* transferred to the target's errorCode field.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
void
TclTransferResult(sourceInterp, result, targetInterp)
Tcl_Interp *sourceInterp; /* Interp whose result and error information
* should be moved to the target interp.
* After moving result, this interp's result
* is reset. */
int result; /* TCL_OK if just the result should be copied,
* TCL_ERROR if both the result and error
* information should be copied. */
Tcl_Interp *targetInterp; /* Interp where result and error information
* should be stored. If source and target
* are the same, nothing is done. */
{
Interp *iPtr = (Interp *) targetInterp;
if (sourceInterp == targetInterp) {
return;
}
Tcl_SetReturnOptions(targetInterp,
Tcl_GetReturnOptions(sourceInterp, result));
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}