/*
* 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.5.2.1 2003/07/16 21:25:07 hobbs Exp $
*/
#include "tclInt.h"
/*
* Function prototypes for local procedures in this file:
*/
static void ResetObjResult _ANSI_ARGS_((Interp *iPtr));
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
int newSpace));
/*
*----------------------------------------------------------------------
*
* 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 "string" to be the Tcl return value.
*
* Results:
* None.
*
* Side effects:
* interp->result is left pointing either to "string" (if "copy" is 0)
* or to a copy of string. Also, the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetResult(interp, string, freeProc)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
register char *string; /* 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 (string == NULL) {
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
length = strlen(string);
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, string);
} else {
iPtr->result = string;
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 string
* 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 empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendResultVA (interp, argList)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
va_list argList; /* Variable argument list. */
{
#define STATIC_LIST_SIZE 16
Interp *iPtr = (Interp *) interp;
char *string, *static_list[STATIC_LIST_SIZE];
char **args = static_list;
int nargs_space = STATIC_LIST_SIZE;
int nargs, newSpace, i;
/*
* If the string result is empty, move the object result to the
* string result, then reset the object result.
*/
if (*(iPtr->result) == 0) {
Tcl_SetResult((Tcl_Interp *) iPtr,
TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)),
TCL_VOLATILE);
}
/*
* Scan through all the arguments to see how much space is needed
* and save pointers to the arguments in the args array,
* reallocating as necessary.
*/
nargs = 0;
newSpace = 0;
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
if (nargs >= nargs_space) {
/*
* Expand the args buffer
*/
nargs_space += STATIC_LIST_SIZE;
if (args == static_list) {
args = (void *)ckalloc(nargs_space * sizeof(char *));
for (i = 0; i < nargs; ++i) {
args[i] = static_list[i];
}
} else {
args = (void *)ckrealloc((void *)args,
nargs_space * sizeof(char *));
}
}
newSpace += strlen(string);
args[nargs++] = string;
}
/*
* If the append buffer isn't already setup and large enough to hold
* the new data, set it up.
*/
if ((iPtr->result != iPtr->appendResult)
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|| ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
SetupAppendBuffer(iPtr, newSpace);
}
/*
* Now go through all the argument strings again, copying them into the
* buffer.
*/
for (i = 0; i < nargs; ++i) {
string = args[i];
strcpy(iPtr->appendResult + iPtr->appendUsed, string);
iPtr->appendUsed += strlen(string);
}
/*
* If we had to allocate a buffer from the heap,
* free it now.
*/
if (args != static_list) {
ckfree((void *)args);
}
#undef STATIC_LIST_SIZE
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResult --
*
* Append a variable number of strings onto the interpreter's string
* 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 empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
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, string)
Tcl_Interp *interp; /* Interpreter whose result is to be
* extended. */
CONST char *string; /* 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.
*/
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
/*
* See how much space is needed, and grow the append buffer if
* needed to accommodate the list element.
*/
size = Tcl_ScanElement(string, &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++;
}
iPtr->appendUsed += Tcl_ConvertElement(string, 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;
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
}
/*
*----------------------------------------------------------------------
*
* 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;
if ((objResultPtr->typePtr != NULL)
&& (objResultPtr->typePtr->freeIntRepProc != NULL)) {
objResultPtr->typePtr->freeIntRepProc(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 global variable is modified to hold all of the
* arguments to this procedure, in a list form with each argument
* becoming one element of the list. A flag is set internally
* to remember that errorCode has been set, so the variable doesn't
* get set automatically when the error is returned.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorCodeVA (interp, argList)
Tcl_Interp *interp; /* Interpreter in which to access the errorCode
* variable. */
va_list argList; /* Variable argument list. */
{
char *string;
int flags;
Interp *iPtr = (Interp *) interp;
/*
* Scan through the arguments one at a time, appending them to
* $errorCode as list elements.
*/
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
(char *) NULL, string, flags);
flags |= TCL_APPEND_VALUE;
}
iPtr->flags |= ERROR_CODE_SET;
}
/*
*----------------------------------------------------------------------
*
* 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 global variable is modified to hold all of the
* arguments to this procedure, in a list form with each argument
* becoming one element of the list. A flag is set internally
* to remember that errorCode has been set, so the variable doesn't
* get set automatically when the error is returned.
*
*----------------------------------------------------------------------
*/
/* 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
* $errorCode 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 global variable is modified to be the new value.
* A flag is set internally to remember that errorCode has been
* set, so the variable doesn't get set automatically when the
* error is returned.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetObjErrorCode(interp, errorObjPtr)
Tcl_Interp *interp;
Tcl_Obj *errorObjPtr;
{
Interp *iPtr;
iPtr = (Interp *) interp;
Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
}
/*
*-------------------------------------------------------------------------
*
* 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 error information "$errorInfo" may be
* appended to the target's error information and the source's error
* code "$errorCode" may be stored in the target's error code.
*
* 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;
Tcl_Obj *objPtr;
if (sourceInterp == targetInterp) {
return;
}
if (result == TCL_ERROR) {
/*
* An error occurred, so transfer error information from the source
* interpreter to the target interpreter. Setting the flags tells
* the target interp that it has inherited a partial traceback
* chain, not just a simple error message.
*/
iPtr = (Interp *) sourceInterp;
if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) {
Tcl_AddErrorInfo(sourceInterp, "");
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_ResetResult(targetInterp);
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
TCL_GLOBAL_ONLY);
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr,
TCL_GLOBAL_ONLY);
((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET);
}
((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}