|
/* $Header$ */ |
|
|
|
|
|
/* |
|
|
* 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.1.1.1 2001/06/13 04:45:53 dtashley 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) |
|
|
|| (statePtr->freeProc == (Tcl_FreeProc *) free)) { |
|
|
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) |
|
|
|| (oldFreeProc == (Tcl_FreeProc *) free)) { |
|
|
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. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
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) |
|
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
|
|
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) |
|
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
|
|
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) |
|
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
|
|
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) |
|
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
|
|
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); |
|
|
} |
|
|
|
|
|
|
|
|
/* $History: tclresult.c $ |
|
|
* |
|
|
* ***************** Version 1 ***************** |
|
|
* User: Dtashley Date: 1/02/01 Time: 1:04a |
|
|
* Created in $/IjuScripter, IjuConsole/Source/Tcl Base |
|
|
* Initial check-in. |
|
|
*/ |
|
|
|
|
|
/* End of TCLRESULT.C */ |
|
1 |
|
/* $Header$ */ |
2 |
|
/* |
3 |
|
* tclResult.c -- |
4 |
|
* |
5 |
|
* This file contains code to manage the interpreter result. |
6 |
|
* |
7 |
|
* Copyright (c) 1997 by Sun Microsystems, Inc. |
8 |
|
* |
9 |
|
* See the file "license.terms" for information on usage and redistribution |
10 |
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
11 |
|
* |
12 |
|
* RCS: @(#) $Id: tclresult.c,v 1.1.1.1 2001/06/13 04:45:53 dtashley Exp $ |
13 |
|
*/ |
14 |
|
|
15 |
|
#include "tclInt.h" |
16 |
|
|
17 |
|
/* |
18 |
|
* Function prototypes for local procedures in this file: |
19 |
|
*/ |
20 |
|
|
21 |
|
static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); |
22 |
|
static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, |
23 |
|
int newSpace)); |
24 |
|
|
25 |
|
|
26 |
|
/* |
27 |
|
*---------------------------------------------------------------------- |
28 |
|
* |
29 |
|
* Tcl_SaveResult -- |
30 |
|
* |
31 |
|
* Takes a snapshot of the current result state of the interpreter. |
32 |
|
* The snapshot can be restored at any point by |
33 |
|
* Tcl_RestoreResult. Note that this routine does not |
34 |
|
* preserve the errorCode, errorInfo, or flags fields so it |
35 |
|
* should not be used if an error is in progress. |
36 |
|
* |
37 |
|
* Once a snapshot is saved, it must be restored by calling |
38 |
|
* Tcl_RestoreResult, or discarded by calling |
39 |
|
* Tcl_DiscardResult. |
40 |
|
* |
41 |
|
* Results: |
42 |
|
* None. |
43 |
|
* |
44 |
|
* Side effects: |
45 |
|
* Resets the interpreter result. |
46 |
|
* |
47 |
|
*---------------------------------------------------------------------- |
48 |
|
*/ |
49 |
|
|
50 |
|
void |
51 |
|
Tcl_SaveResult(interp, statePtr) |
52 |
|
Tcl_Interp *interp; /* Interpreter to save. */ |
53 |
|
Tcl_SavedResult *statePtr; /* Pointer to state structure. */ |
54 |
|
{ |
55 |
|
Interp *iPtr = (Interp *) interp; |
56 |
|
|
57 |
|
/* |
58 |
|
* Move the result object into the save state. Note that we don't need |
59 |
|
* to change its refcount because we're moving it, not adding a new |
60 |
|
* reference. Put an empty object into the interpreter. |
61 |
|
*/ |
62 |
|
|
63 |
|
statePtr->objResultPtr = iPtr->objResultPtr; |
64 |
|
iPtr->objResultPtr = Tcl_NewObj(); |
65 |
|
Tcl_IncrRefCount(iPtr->objResultPtr); |
66 |
|
|
67 |
|
/* |
68 |
|
* Save the string result. |
69 |
|
*/ |
70 |
|
|
71 |
|
statePtr->freeProc = iPtr->freeProc; |
72 |
|
if (iPtr->result == iPtr->resultSpace) { |
73 |
|
/* |
74 |
|
* Copy the static string data out of the interp buffer. |
75 |
|
*/ |
76 |
|
|
77 |
|
statePtr->result = statePtr->resultSpace; |
78 |
|
strcpy(statePtr->result, iPtr->result); |
79 |
|
statePtr->appendResult = NULL; |
80 |
|
} else if (iPtr->result == iPtr->appendResult) { |
81 |
|
/* |
82 |
|
* Move the append buffer out of the interp. |
83 |
|
*/ |
84 |
|
|
85 |
|
statePtr->appendResult = iPtr->appendResult; |
86 |
|
statePtr->appendAvl = iPtr->appendAvl; |
87 |
|
statePtr->appendUsed = iPtr->appendUsed; |
88 |
|
statePtr->result = statePtr->appendResult; |
89 |
|
iPtr->appendResult = NULL; |
90 |
|
iPtr->appendAvl = 0; |
91 |
|
iPtr->appendUsed = 0; |
92 |
|
} else { |
93 |
|
/* |
94 |
|
* Move the dynamic or static string out of the interpreter. |
95 |
|
*/ |
96 |
|
|
97 |
|
statePtr->result = iPtr->result; |
98 |
|
statePtr->appendResult = NULL; |
99 |
|
} |
100 |
|
|
101 |
|
iPtr->result = iPtr->resultSpace; |
102 |
|
iPtr->resultSpace[0] = 0; |
103 |
|
iPtr->freeProc = 0; |
104 |
|
} |
105 |
|
|
106 |
|
/* |
107 |
|
*---------------------------------------------------------------------- |
108 |
|
* |
109 |
|
* Tcl_RestoreResult -- |
110 |
|
* |
111 |
|
* Restores the state of the interpreter to a snapshot taken |
112 |
|
* by Tcl_SaveResult. After this call, the token for |
113 |
|
* the interpreter state is no longer valid. |
114 |
|
* |
115 |
|
* Results: |
116 |
|
* None. |
117 |
|
* |
118 |
|
* Side effects: |
119 |
|
* Restores the interpreter result. |
120 |
|
* |
121 |
|
*---------------------------------------------------------------------- |
122 |
|
*/ |
123 |
|
|
124 |
|
void |
125 |
|
Tcl_RestoreResult(interp, statePtr) |
126 |
|
Tcl_Interp* interp; /* Interpreter being restored. */ |
127 |
|
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ |
128 |
|
{ |
129 |
|
Interp *iPtr = (Interp *) interp; |
130 |
|
|
131 |
|
Tcl_ResetResult(interp); |
132 |
|
|
133 |
|
/* |
134 |
|
* Restore the string result. |
135 |
|
*/ |
136 |
|
|
137 |
|
iPtr->freeProc = statePtr->freeProc; |
138 |
|
if (statePtr->result == statePtr->resultSpace) { |
139 |
|
/* |
140 |
|
* Copy the static string data into the interp buffer. |
141 |
|
*/ |
142 |
|
|
143 |
|
iPtr->result = iPtr->resultSpace; |
144 |
|
strcpy(iPtr->result, statePtr->result); |
145 |
|
} else if (statePtr->result == statePtr->appendResult) { |
146 |
|
/* |
147 |
|
* Move the append buffer back into the interp. |
148 |
|
*/ |
149 |
|
|
150 |
|
if (iPtr->appendResult != NULL) { |
151 |
|
ckfree((char *)iPtr->appendResult); |
152 |
|
} |
153 |
|
|
154 |
|
iPtr->appendResult = statePtr->appendResult; |
155 |
|
iPtr->appendAvl = statePtr->appendAvl; |
156 |
|
iPtr->appendUsed = statePtr->appendUsed; |
157 |
|
iPtr->result = iPtr->appendResult; |
158 |
|
} else { |
159 |
|
/* |
160 |
|
* Move the dynamic or static string back into the interpreter. |
161 |
|
*/ |
162 |
|
|
163 |
|
iPtr->result = statePtr->result; |
164 |
|
} |
165 |
|
|
166 |
|
/* |
167 |
|
* Restore the object result. |
168 |
|
*/ |
169 |
|
|
170 |
|
Tcl_DecrRefCount(iPtr->objResultPtr); |
171 |
|
iPtr->objResultPtr = statePtr->objResultPtr; |
172 |
|
} |
173 |
|
|
174 |
|
/* |
175 |
|
*---------------------------------------------------------------------- |
176 |
|
* |
177 |
|
* Tcl_DiscardResult -- |
178 |
|
* |
179 |
|
* Frees the memory associated with an interpreter snapshot |
180 |
|
* taken by Tcl_SaveResult. If the snapshot is not |
181 |
|
* restored, this procedure must be called to discard it, |
182 |
|
* or the memory will be lost. |
183 |
|
* |
184 |
|
* Results: |
185 |
|
* None. |
186 |
|
* |
187 |
|
* Side effects: |
188 |
|
* None. |
189 |
|
* |
190 |
|
*---------------------------------------------------------------------- |
191 |
|
*/ |
192 |
|
|
193 |
|
void |
194 |
|
Tcl_DiscardResult(statePtr) |
195 |
|
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ |
196 |
|
{ |
197 |
|
TclDecrRefCount(statePtr->objResultPtr); |
198 |
|
|
199 |
|
if (statePtr->result == statePtr->appendResult) { |
200 |
|
ckfree(statePtr->appendResult); |
201 |
|
} else if (statePtr->freeProc) { |
202 |
|
if ((statePtr->freeProc == TCL_DYNAMIC) |
203 |
|
|| (statePtr->freeProc == (Tcl_FreeProc *) free)) { |
204 |
|
ckfree(statePtr->result); |
205 |
|
} else { |
206 |
|
(*statePtr->freeProc)(statePtr->result); |
207 |
|
} |
208 |
|
} |
209 |
|
} |
210 |
|
|
211 |
|
/* |
212 |
|
*---------------------------------------------------------------------- |
213 |
|
* |
214 |
|
* Tcl_SetResult -- |
215 |
|
* |
216 |
|
* Arrange for "string" to be the Tcl return value. |
217 |
|
* |
218 |
|
* Results: |
219 |
|
* None. |
220 |
|
* |
221 |
|
* Side effects: |
222 |
|
* interp->result is left pointing either to "string" (if "copy" is 0) |
223 |
|
* or to a copy of string. Also, the object result is reset. |
224 |
|
* |
225 |
|
*---------------------------------------------------------------------- |
226 |
|
*/ |
227 |
|
|
228 |
|
void |
229 |
|
Tcl_SetResult(interp, string, freeProc) |
230 |
|
Tcl_Interp *interp; /* Interpreter with which to associate the |
231 |
|
* return value. */ |
232 |
|
register char *string; /* Value to be returned. If NULL, the |
233 |
|
* result is set to an empty string. */ |
234 |
|
Tcl_FreeProc *freeProc; /* Gives information about the string: |
235 |
|
* TCL_STATIC, TCL_VOLATILE, or the address |
236 |
|
* of a Tcl_FreeProc such as free. */ |
237 |
|
{ |
238 |
|
Interp *iPtr = (Interp *) interp; |
239 |
|
int length; |
240 |
|
register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; |
241 |
|
char *oldResult = iPtr->result; |
242 |
|
|
243 |
|
if (string == NULL) { |
244 |
|
iPtr->resultSpace[0] = 0; |
245 |
|
iPtr->result = iPtr->resultSpace; |
246 |
|
iPtr->freeProc = 0; |
247 |
|
} else if (freeProc == TCL_VOLATILE) { |
248 |
|
length = strlen(string); |
249 |
|
if (length > TCL_RESULT_SIZE) { |
250 |
|
iPtr->result = (char *) ckalloc((unsigned) length+1); |
251 |
|
iPtr->freeProc = TCL_DYNAMIC; |
252 |
|
} else { |
253 |
|
iPtr->result = iPtr->resultSpace; |
254 |
|
iPtr->freeProc = 0; |
255 |
|
} |
256 |
|
strcpy(iPtr->result, string); |
257 |
|
} else { |
258 |
|
iPtr->result = string; |
259 |
|
iPtr->freeProc = freeProc; |
260 |
|
} |
261 |
|
|
262 |
|
/* |
263 |
|
* If the old result was dynamically-allocated, free it up. Do it |
264 |
|
* here, rather than at the beginning, in case the new result value |
265 |
|
* was part of the old result value. |
266 |
|
*/ |
267 |
|
|
268 |
|
if (oldFreeProc != 0) { |
269 |
|
if ((oldFreeProc == TCL_DYNAMIC) |
270 |
|
|| (oldFreeProc == (Tcl_FreeProc *) free)) { |
271 |
|
ckfree(oldResult); |
272 |
|
} else { |
273 |
|
(*oldFreeProc)(oldResult); |
274 |
|
} |
275 |
|
} |
276 |
|
|
277 |
|
/* |
278 |
|
* Reset the object result since we just set the string result. |
279 |
|
*/ |
280 |
|
|
281 |
|
ResetObjResult(iPtr); |
282 |
|
} |
283 |
|
|
284 |
|
/* |
285 |
|
*---------------------------------------------------------------------- |
286 |
|
* |
287 |
|
* Tcl_GetStringResult -- |
288 |
|
* |
289 |
|
* Returns an interpreter's result value as a string. |
290 |
|
* |
291 |
|
* Results: |
292 |
|
* The interpreter's result as a string. |
293 |
|
* |
294 |
|
* Side effects: |
295 |
|
* If the string result is empty, the object result is moved to the |
296 |
|
* string result, then the object result is reset. |
297 |
|
* |
298 |
|
*---------------------------------------------------------------------- |
299 |
|
*/ |
300 |
|
|
301 |
|
char * |
302 |
|
Tcl_GetStringResult(interp) |
303 |
|
register Tcl_Interp *interp; /* Interpreter whose result to return. */ |
304 |
|
{ |
305 |
|
/* |
306 |
|
* If the string result is empty, move the object result to the |
307 |
|
* string result, then reset the object result. |
308 |
|
*/ |
309 |
|
|
310 |
|
if (*(interp->result) == 0) { |
311 |
|
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), |
312 |
|
TCL_VOLATILE); |
313 |
|
} |
314 |
|
return interp->result; |
315 |
|
} |
316 |
|
|
317 |
|
/* |
318 |
|
*---------------------------------------------------------------------- |
319 |
|
* |
320 |
|
* Tcl_SetObjResult -- |
321 |
|
* |
322 |
|
* Arrange for objPtr to be an interpreter's result value. |
323 |
|
* |
324 |
|
* Results: |
325 |
|
* None. |
326 |
|
* |
327 |
|
* Side effects: |
328 |
|
* interp->objResultPtr is left pointing to the object referenced |
329 |
|
* by objPtr. The object's reference count is incremented since |
330 |
|
* there is now a new reference to it. The reference count for any |
331 |
|
* old objResultPtr value is decremented. Also, the string result |
332 |
|
* is reset. |
333 |
|
* |
334 |
|
*---------------------------------------------------------------------- |
335 |
|
*/ |
336 |
|
|
337 |
|
void |
338 |
|
Tcl_SetObjResult(interp, objPtr) |
339 |
|
Tcl_Interp *interp; /* Interpreter with which to associate the |
340 |
|
* return object value. */ |
341 |
|
register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the |
342 |
|
* obj result is made an empty string |
343 |
|
* object. */ |
344 |
|
{ |
345 |
|
register Interp *iPtr = (Interp *) interp; |
346 |
|
register Tcl_Obj *oldObjResult = iPtr->objResultPtr; |
347 |
|
|
348 |
|
iPtr->objResultPtr = objPtr; |
349 |
|
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ |
350 |
|
|
351 |
|
/* |
352 |
|
* We wait until the end to release the old object result, in case |
353 |
|
* we are setting the result to itself. |
354 |
|
*/ |
355 |
|
|
356 |
|
TclDecrRefCount(oldObjResult); |
357 |
|
|
358 |
|
/* |
359 |
|
* Reset the string result since we just set the result object. |
360 |
|
*/ |
361 |
|
|
362 |
|
if (iPtr->freeProc != NULL) { |
363 |
|
if ((iPtr->freeProc == TCL_DYNAMIC) |
364 |
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
365 |
|
ckfree(iPtr->result); |
366 |
|
} else { |
367 |
|
(*iPtr->freeProc)(iPtr->result); |
368 |
|
} |
369 |
|
iPtr->freeProc = 0; |
370 |
|
} |
371 |
|
iPtr->result = iPtr->resultSpace; |
372 |
|
iPtr->resultSpace[0] = 0; |
373 |
|
} |
374 |
|
|
375 |
|
/* |
376 |
|
*---------------------------------------------------------------------- |
377 |
|
* |
378 |
|
* Tcl_GetObjResult -- |
379 |
|
* |
380 |
|
* Returns an interpreter's result value as a Tcl object. The object's |
381 |
|
* reference count is not modified; the caller must do that if it |
382 |
|
* needs to hold on to a long-term reference to it. |
383 |
|
* |
384 |
|
* Results: |
385 |
|
* The interpreter's result as an object. |
386 |
|
* |
387 |
|
* Side effects: |
388 |
|
* If the interpreter has a non-empty string result, the result object |
389 |
|
* is either empty or stale because some procedure set interp->result |
390 |
|
* directly. If so, the string result is moved to the result object |
391 |
|
* then the string result is reset. |
392 |
|
* |
393 |
|
*---------------------------------------------------------------------- |
394 |
|
*/ |
395 |
|
|
396 |
|
Tcl_Obj * |
397 |
|
Tcl_GetObjResult(interp) |
398 |
|
Tcl_Interp *interp; /* Interpreter whose result to return. */ |
399 |
|
{ |
400 |
|
register Interp *iPtr = (Interp *) interp; |
401 |
|
Tcl_Obj *objResultPtr; |
402 |
|
int length; |
403 |
|
|
404 |
|
/* |
405 |
|
* If the string result is non-empty, move the string result to the |
406 |
|
* object result, then reset the string result. |
407 |
|
*/ |
408 |
|
|
409 |
|
if (*(iPtr->result) != 0) { |
410 |
|
ResetObjResult(iPtr); |
411 |
|
|
412 |
|
objResultPtr = iPtr->objResultPtr; |
413 |
|
length = strlen(iPtr->result); |
414 |
|
TclInitStringRep(objResultPtr, iPtr->result, length); |
415 |
|
|
416 |
|
if (iPtr->freeProc != NULL) { |
417 |
|
if ((iPtr->freeProc == TCL_DYNAMIC) |
418 |
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
419 |
|
ckfree(iPtr->result); |
420 |
|
} else { |
421 |
|
(*iPtr->freeProc)(iPtr->result); |
422 |
|
} |
423 |
|
iPtr->freeProc = 0; |
424 |
|
} |
425 |
|
iPtr->result = iPtr->resultSpace; |
426 |
|
iPtr->resultSpace[0] = 0; |
427 |
|
} |
428 |
|
return iPtr->objResultPtr; |
429 |
|
} |
430 |
|
|
431 |
|
/* |
432 |
|
*---------------------------------------------------------------------- |
433 |
|
* |
434 |
|
* Tcl_AppendResultVA -- |
435 |
|
* |
436 |
|
* Append a variable number of strings onto the interpreter's string |
437 |
|
* result. |
438 |
|
* |
439 |
|
* Results: |
440 |
|
* None. |
441 |
|
* |
442 |
|
* Side effects: |
443 |
|
* The result of the interpreter given by the first argument is |
444 |
|
* extended by the strings in the va_list (up to a terminating NULL |
445 |
|
* argument). |
446 |
|
* |
447 |
|
* If the string result is empty, the object result is moved to the |
448 |
|
* string result, then the object result is reset. |
449 |
|
* |
450 |
|
*---------------------------------------------------------------------- |
451 |
|
*/ |
452 |
|
|
453 |
|
void |
454 |
|
Tcl_AppendResultVA (interp, argList) |
455 |
|
Tcl_Interp *interp; /* Interpreter with which to associate the |
456 |
|
* return value. */ |
457 |
|
va_list argList; /* Variable argument list. */ |
458 |
|
{ |
459 |
|
#define STATIC_LIST_SIZE 16 |
460 |
|
Interp *iPtr = (Interp *) interp; |
461 |
|
char *string, *static_list[STATIC_LIST_SIZE]; |
462 |
|
char **args = static_list; |
463 |
|
int nargs_space = STATIC_LIST_SIZE; |
464 |
|
int nargs, newSpace, i; |
465 |
|
|
466 |
|
/* |
467 |
|
* If the string result is empty, move the object result to the |
468 |
|
* string result, then reset the object result. |
469 |
|
*/ |
470 |
|
|
471 |
|
if (*(iPtr->result) == 0) { |
472 |
|
Tcl_SetResult((Tcl_Interp *) iPtr, |
473 |
|
TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)), |
474 |
|
TCL_VOLATILE); |
475 |
|
} |
476 |
|
|
477 |
|
/* |
478 |
|
* Scan through all the arguments to see how much space is needed |
479 |
|
* and save pointers to the arguments in the args array, |
480 |
|
* reallocating as necessary. |
481 |
|
*/ |
482 |
|
|
483 |
|
nargs = 0; |
484 |
|
newSpace = 0; |
485 |
|
while (1) { |
486 |
|
string = va_arg(argList, char *); |
487 |
|
if (string == NULL) { |
488 |
|
break; |
489 |
|
} |
490 |
|
if (nargs >= nargs_space) { |
491 |
|
/* |
492 |
|
* Expand the args buffer |
493 |
|
*/ |
494 |
|
nargs_space += STATIC_LIST_SIZE; |
495 |
|
if (args == static_list) { |
496 |
|
args = (void *)ckalloc(nargs_space * sizeof(char *)); |
497 |
|
for (i = 0; i < nargs; ++i) { |
498 |
|
args[i] = static_list[i]; |
499 |
|
} |
500 |
|
} else { |
501 |
|
args = (void *)ckrealloc((void *)args, |
502 |
|
nargs_space * sizeof(char *)); |
503 |
|
} |
504 |
|
} |
505 |
|
newSpace += strlen(string); |
506 |
|
args[nargs++] = string; |
507 |
|
} |
508 |
|
|
509 |
|
/* |
510 |
|
* If the append buffer isn't already setup and large enough to hold |
511 |
|
* the new data, set it up. |
512 |
|
*/ |
513 |
|
|
514 |
|
if ((iPtr->result != iPtr->appendResult) |
515 |
|
|| (iPtr->appendResult[iPtr->appendUsed] != 0) |
516 |
|
|| ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { |
517 |
|
SetupAppendBuffer(iPtr, newSpace); |
518 |
|
} |
519 |
|
|
520 |
|
/* |
521 |
|
* Now go through all the argument strings again, copying them into the |
522 |
|
* buffer. |
523 |
|
*/ |
524 |
|
|
525 |
|
for (i = 0; i < nargs; ++i) { |
526 |
|
string = args[i]; |
527 |
|
strcpy(iPtr->appendResult + iPtr->appendUsed, string); |
528 |
|
iPtr->appendUsed += strlen(string); |
529 |
|
} |
530 |
|
|
531 |
|
/* |
532 |
|
* If we had to allocate a buffer from the heap, |
533 |
|
* free it now. |
534 |
|
*/ |
535 |
|
|
536 |
|
if (args != static_list) { |
537 |
|
ckfree((void *)args); |
538 |
|
} |
539 |
|
#undef STATIC_LIST_SIZE |
540 |
|
} |
541 |
|
|
542 |
|
/* |
543 |
|
*---------------------------------------------------------------------- |
544 |
|
* |
545 |
|
* Tcl_AppendResult -- |
546 |
|
* |
547 |
|
* Append a variable number of strings onto the interpreter's string |
548 |
|
* result. |
549 |
|
* |
550 |
|
* Results: |
551 |
|
* None. |
552 |
|
* |
553 |
|
* Side effects: |
554 |
|
* The result of the interpreter given by the first argument is |
555 |
|
* extended by the strings given by the second and following arguments |
556 |
|
* (up to a terminating NULL argument). |
557 |
|
* |
558 |
|
* If the string result is empty, the object result is moved to the |
559 |
|
* string result, then the object result is reset. |
560 |
|
* |
561 |
|
*---------------------------------------------------------------------- |
562 |
|
*/ |
563 |
|
|
564 |
|
void |
565 |
|
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) |
566 |
|
{ |
567 |
|
Tcl_Interp *interp; |
568 |
|
va_list argList; |
569 |
|
|
570 |
|
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); |
571 |
|
Tcl_AppendResultVA(interp, argList); |
572 |
|
va_end(argList); |
573 |
|
} |
574 |
|
|
575 |
|
/* |
576 |
|
*---------------------------------------------------------------------- |
577 |
|
* |
578 |
|
* Tcl_AppendElement -- |
579 |
|
* |
580 |
|
* Convert a string to a valid Tcl list element and append it to the |
581 |
|
* result (which is ostensibly a list). |
582 |
|
* |
583 |
|
* Results: |
584 |
|
* None. |
585 |
|
* |
586 |
|
* Side effects: |
587 |
|
* The result in the interpreter given by the first argument is |
588 |
|
* extended with a list element converted from string. A separator |
589 |
|
* space is added before the converted list element unless the current |
590 |
|
* result is empty, contains the single character "{", or ends in " {". |
591 |
|
* |
592 |
|
* If the string result is empty, the object result is moved to the |
593 |
|
* string result, then the object result is reset. |
594 |
|
* |
595 |
|
*---------------------------------------------------------------------- |
596 |
|
*/ |
597 |
|
|
598 |
|
void |
599 |
|
Tcl_AppendElement(interp, string) |
600 |
|
Tcl_Interp *interp; /* Interpreter whose result is to be |
601 |
|
* extended. */ |
602 |
|
CONST char *string; /* String to convert to list element and |
603 |
|
* add to result. */ |
604 |
|
{ |
605 |
|
Interp *iPtr = (Interp *) interp; |
606 |
|
char *dst; |
607 |
|
int size; |
608 |
|
int flags; |
609 |
|
|
610 |
|
/* |
611 |
|
* If the string result is empty, move the object result to the |
612 |
|
* string result, then reset the object result. |
613 |
|
*/ |
614 |
|
|
615 |
|
if (*(iPtr->result) == 0) { |
616 |
|
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), |
617 |
|
TCL_VOLATILE); |
618 |
|
} |
619 |
|
|
620 |
|
/* |
621 |
|
* See how much space is needed, and grow the append buffer if |
622 |
|
* needed to accommodate the list element. |
623 |
|
*/ |
624 |
|
|
625 |
|
size = Tcl_ScanElement(string, &flags) + 1; |
626 |
|
if ((iPtr->result != iPtr->appendResult) |
627 |
|
|| (iPtr->appendResult[iPtr->appendUsed] != 0) |
628 |
|
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { |
629 |
|
SetupAppendBuffer(iPtr, size+iPtr->appendUsed); |
630 |
|
} |
631 |
|
|
632 |
|
/* |
633 |
|
* Convert the string into a list element and copy it to the |
634 |
|
* buffer that's forming, with a space separator if needed. |
635 |
|
*/ |
636 |
|
|
637 |
|
dst = iPtr->appendResult + iPtr->appendUsed; |
638 |
|
if (TclNeedSpace(iPtr->appendResult, dst)) { |
639 |
|
iPtr->appendUsed++; |
640 |
|
*dst = ' '; |
641 |
|
dst++; |
642 |
|
} |
643 |
|
iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); |
644 |
|
} |
645 |
|
|
646 |
|
/* |
647 |
|
*---------------------------------------------------------------------- |
648 |
|
* |
649 |
|
* SetupAppendBuffer -- |
650 |
|
* |
651 |
|
* This procedure makes sure that there is an append buffer properly |
652 |
|
* initialized, if necessary, from the interpreter's result, and |
653 |
|
* that it has at least enough room to accommodate newSpace new |
654 |
|
* bytes of information. |
655 |
|
* |
656 |
|
* Results: |
657 |
|
* None. |
658 |
|
* |
659 |
|
* Side effects: |
660 |
|
* None. |
661 |
|
* |
662 |
|
*---------------------------------------------------------------------- |
663 |
|
*/ |
664 |
|
|
665 |
|
static void |
666 |
|
SetupAppendBuffer(iPtr, newSpace) |
667 |
|
Interp *iPtr; /* Interpreter whose result is being set up. */ |
668 |
|
int newSpace; /* Make sure that at least this many bytes |
669 |
|
* of new information may be added. */ |
670 |
|
{ |
671 |
|
int totalSpace; |
672 |
|
|
673 |
|
/* |
674 |
|
* Make the append buffer larger, if that's necessary, then copy the |
675 |
|
* result into the append buffer and make the append buffer the official |
676 |
|
* Tcl result. |
677 |
|
*/ |
678 |
|
|
679 |
|
if (iPtr->result != iPtr->appendResult) { |
680 |
|
/* |
681 |
|
* If an oversized buffer was used recently, then free it up |
682 |
|
* so we go back to a smaller buffer. This avoids tying up |
683 |
|
* memory forever after a large operation. |
684 |
|
*/ |
685 |
|
|
686 |
|
if (iPtr->appendAvl > 500) { |
687 |
|
ckfree(iPtr->appendResult); |
688 |
|
iPtr->appendResult = NULL; |
689 |
|
iPtr->appendAvl = 0; |
690 |
|
} |
691 |
|
iPtr->appendUsed = strlen(iPtr->result); |
692 |
|
} else if (iPtr->result[iPtr->appendUsed] != 0) { |
693 |
|
/* |
694 |
|
* Most likely someone has modified a result created by |
695 |
|
* Tcl_AppendResult et al. so that it has a different size. |
696 |
|
* Just recompute the size. |
697 |
|
*/ |
698 |
|
|
699 |
|
iPtr->appendUsed = strlen(iPtr->result); |
700 |
|
} |
701 |
|
|
702 |
|
totalSpace = newSpace + iPtr->appendUsed; |
703 |
|
if (totalSpace >= iPtr->appendAvl) { |
704 |
|
char *new; |
705 |
|
|
706 |
|
if (totalSpace < 100) { |
707 |
|
totalSpace = 200; |
708 |
|
} else { |
709 |
|
totalSpace *= 2; |
710 |
|
} |
711 |
|
new = (char *) ckalloc((unsigned) totalSpace); |
712 |
|
strcpy(new, iPtr->result); |
713 |
|
if (iPtr->appendResult != NULL) { |
714 |
|
ckfree(iPtr->appendResult); |
715 |
|
} |
716 |
|
iPtr->appendResult = new; |
717 |
|
iPtr->appendAvl = totalSpace; |
718 |
|
} else if (iPtr->result != iPtr->appendResult) { |
719 |
|
strcpy(iPtr->appendResult, iPtr->result); |
720 |
|
} |
721 |
|
|
722 |
|
Tcl_FreeResult((Tcl_Interp *) iPtr); |
723 |
|
iPtr->result = iPtr->appendResult; |
724 |
|
} |
725 |
|
|
726 |
|
/* |
727 |
|
*---------------------------------------------------------------------- |
728 |
|
* |
729 |
|
* Tcl_FreeResult -- |
730 |
|
* |
731 |
|
* This procedure frees up the memory associated with an interpreter's |
732 |
|
* string result. It also resets the interpreter's result object. |
733 |
|
* Tcl_FreeResult is most commonly used when a procedure is about to |
734 |
|
* replace one result value with another. |
735 |
|
* |
736 |
|
* Results: |
737 |
|
* None. |
738 |
|
* |
739 |
|
* Side effects: |
740 |
|
* Frees the memory associated with interp's string result and sets |
741 |
|
* interp->freeProc to zero, but does not change interp->result or |
742 |
|
* clear error state. Resets interp's result object to an unshared |
743 |
|
* empty object. |
744 |
|
* |
745 |
|
*---------------------------------------------------------------------- |
746 |
|
*/ |
747 |
|
|
748 |
|
void |
749 |
|
Tcl_FreeResult(interp) |
750 |
|
register Tcl_Interp *interp; /* Interpreter for which to free result. */ |
751 |
|
{ |
752 |
|
register Interp *iPtr = (Interp *) interp; |
753 |
|
|
754 |
|
if (iPtr->freeProc != NULL) { |
755 |
|
if ((iPtr->freeProc == TCL_DYNAMIC) |
756 |
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
757 |
|
ckfree(iPtr->result); |
758 |
|
} else { |
759 |
|
(*iPtr->freeProc)(iPtr->result); |
760 |
|
} |
761 |
|
iPtr->freeProc = 0; |
762 |
|
} |
763 |
|
|
764 |
|
ResetObjResult(iPtr); |
765 |
|
} |
766 |
|
|
767 |
|
/* |
768 |
|
*---------------------------------------------------------------------- |
769 |
|
* |
770 |
|
* Tcl_ResetResult -- |
771 |
|
* |
772 |
|
* This procedure resets both the interpreter's string and object |
773 |
|
* results. |
774 |
|
* |
775 |
|
* Results: |
776 |
|
* None. |
777 |
|
* |
778 |
|
* Side effects: |
779 |
|
* It resets the result object to an unshared empty object. It |
780 |
|
* then restores the interpreter's string result area to its default |
781 |
|
* initialized state, freeing up any memory that may have been |
782 |
|
* allocated. It also clears any error information for the interpreter. |
783 |
|
* |
784 |
|
*---------------------------------------------------------------------- |
785 |
|
*/ |
786 |
|
|
787 |
|
void |
788 |
|
Tcl_ResetResult(interp) |
789 |
|
register Tcl_Interp *interp; /* Interpreter for which to clear result. */ |
790 |
|
{ |
791 |
|
register Interp *iPtr = (Interp *) interp; |
792 |
|
|
793 |
|
ResetObjResult(iPtr); |
794 |
|
if (iPtr->freeProc != NULL) { |
795 |
|
if ((iPtr->freeProc == TCL_DYNAMIC) |
796 |
|
|| (iPtr->freeProc == (Tcl_FreeProc *) free)) { |
797 |
|
ckfree(iPtr->result); |
798 |
|
} else { |
799 |
|
(*iPtr->freeProc)(iPtr->result); |
800 |
|
} |
801 |
|
iPtr->freeProc = 0; |
802 |
|
} |
803 |
|
iPtr->result = iPtr->resultSpace; |
804 |
|
iPtr->resultSpace[0] = 0; |
805 |
|
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); |
806 |
|
} |
807 |
|
|
808 |
|
/* |
809 |
|
*---------------------------------------------------------------------- |
810 |
|
* |
811 |
|
* ResetObjResult -- |
812 |
|
* |
813 |
|
* Procedure used to reset an interpreter's Tcl result object. |
814 |
|
* |
815 |
|
* Results: |
816 |
|
* None. |
817 |
|
* |
818 |
|
* Side effects: |
819 |
|
* Resets the interpreter's result object to an unshared empty string |
820 |
|
* object with ref count one. It does not clear any error information |
821 |
|
* in the interpreter. |
822 |
|
* |
823 |
|
*---------------------------------------------------------------------- |
824 |
|
*/ |
825 |
|
|
826 |
|
static void |
827 |
|
ResetObjResult(iPtr) |
828 |
|
register Interp *iPtr; /* Points to the interpreter whose result |
829 |
|
* object should be reset. */ |
830 |
|
{ |
831 |
|
register Tcl_Obj *objResultPtr = iPtr->objResultPtr; |
832 |
|
|
833 |
|
if (Tcl_IsShared(objResultPtr)) { |
834 |
|
TclDecrRefCount(objResultPtr); |
835 |
|
TclNewObj(objResultPtr); |
836 |
|
Tcl_IncrRefCount(objResultPtr); |
837 |
|
iPtr->objResultPtr = objResultPtr; |
838 |
|
} else { |
839 |
|
if ((objResultPtr->bytes != NULL) |
840 |
|
&& (objResultPtr->bytes != tclEmptyStringRep)) { |
841 |
|
ckfree((char *) objResultPtr->bytes); |
842 |
|
} |
843 |
|
objResultPtr->bytes = tclEmptyStringRep; |
844 |
|
objResultPtr->length = 0; |
845 |
|
if ((objResultPtr->typePtr != NULL) |
846 |
|
&& (objResultPtr->typePtr->freeIntRepProc != NULL)) { |
847 |
|
objResultPtr->typePtr->freeIntRepProc(objResultPtr); |
848 |
|
} |
849 |
|
objResultPtr->typePtr = (Tcl_ObjType *) NULL; |
850 |
|
} |
851 |
|
} |
852 |
|
|
853 |
|
/* |
854 |
|
*---------------------------------------------------------------------- |
855 |
|
* |
856 |
|
* Tcl_SetErrorCodeVA -- |
857 |
|
* |
858 |
|
* This procedure is called to record machine-readable information |
859 |
|
* about an error that is about to be returned. |
860 |
|
* |
861 |
|
* Results: |
862 |
|
* None. |
863 |
|
* |
864 |
|
* Side effects: |
865 |
|
* The errorCode global variable is modified to hold all of the |
866 |
|
* arguments to this procedure, in a list form with each argument |
867 |
|
* becoming one element of the list. A flag is set internally |
868 |
|
* to remember that errorCode has been set, so the variable doesn't |
869 |
|
* get set automatically when the error is returned. |
870 |
|
* |
871 |
|
*---------------------------------------------------------------------- |
872 |
|
*/ |
873 |
|
|
874 |
|
void |
875 |
|
Tcl_SetErrorCodeVA (interp, argList) |
876 |
|
Tcl_Interp *interp; /* Interpreter in which to access the errorCode |
877 |
|
* variable. */ |
878 |
|
va_list argList; /* Variable argument list. */ |
879 |
|
{ |
880 |
|
char *string; |
881 |
|
int flags; |
882 |
|
Interp *iPtr = (Interp *) interp; |
883 |
|
|
884 |
|
/* |
885 |
|
* Scan through the arguments one at a time, appending them to |
886 |
|
* $errorCode as list elements. |
887 |
|
*/ |
888 |
|
|
889 |
|
flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; |
890 |
|
while (1) { |
891 |
|
string = va_arg(argList, char *); |
892 |
|
if (string == NULL) { |
893 |
|
break; |
894 |
|
} |
895 |
|
(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", |
896 |
|
(char *) NULL, string, flags); |
897 |
|
flags |= TCL_APPEND_VALUE; |
898 |
|
} |
899 |
|
iPtr->flags |= ERROR_CODE_SET; |
900 |
|
} |
901 |
|
|
902 |
|
/* |
903 |
|
*---------------------------------------------------------------------- |
904 |
|
* |
905 |
|
* Tcl_SetErrorCode -- |
906 |
|
* |
907 |
|
* This procedure is called to record machine-readable information |
908 |
|
* about an error that is about to be returned. |
909 |
|
* |
910 |
|
* Results: |
911 |
|
* None. |
912 |
|
* |
913 |
|
* Side effects: |
914 |
|
* The errorCode global variable is modified to hold all of the |
915 |
|
* arguments to this procedure, in a list form with each argument |
916 |
|
* becoming one element of the list. A flag is set internally |
917 |
|
* to remember that errorCode has been set, so the variable doesn't |
918 |
|
* get set automatically when the error is returned. |
919 |
|
* |
920 |
|
*---------------------------------------------------------------------- |
921 |
|
*/ |
922 |
|
/* VARARGS2 */ |
923 |
|
void |
924 |
|
Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) |
925 |
|
{ |
926 |
|
Tcl_Interp *interp; |
927 |
|
va_list argList; |
928 |
|
|
929 |
|
/* |
930 |
|
* Scan through the arguments one at a time, appending them to |
931 |
|
* $errorCode as list elements. |
932 |
|
*/ |
933 |
|
|
934 |
|
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); |
935 |
|
Tcl_SetErrorCodeVA(interp, argList); |
936 |
|
va_end(argList); |
937 |
|
} |
938 |
|
|
939 |
|
/* |
940 |
|
*---------------------------------------------------------------------- |
941 |
|
* |
942 |
|
* Tcl_SetObjErrorCode -- |
943 |
|
* |
944 |
|
* This procedure is called to record machine-readable information |
945 |
|
* about an error that is about to be returned. The caller should |
946 |
|
* build a list object up and pass it to this routine. |
947 |
|
* |
948 |
|
* Results: |
949 |
|
* None. |
950 |
|
* |
951 |
|
* Side effects: |
952 |
|
* The errorCode global variable is modified to be the new value. |
953 |
|
* A flag is set internally to remember that errorCode has been |
954 |
|
* set, so the variable doesn't get set automatically when the |
955 |
|
* error is returned. |
956 |
|
* |
957 |
|
*---------------------------------------------------------------------- |
958 |
|
*/ |
959 |
|
|
960 |
|
void |
961 |
|
Tcl_SetObjErrorCode(interp, errorObjPtr) |
962 |
|
Tcl_Interp *interp; |
963 |
|
Tcl_Obj *errorObjPtr; |
964 |
|
{ |
965 |
|
Interp *iPtr; |
966 |
|
|
967 |
|
iPtr = (Interp *) interp; |
968 |
|
Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); |
969 |
|
iPtr->flags |= ERROR_CODE_SET; |
970 |
|
} |
971 |
|
|
972 |
|
/* |
973 |
|
*------------------------------------------------------------------------- |
974 |
|
* |
975 |
|
* TclTransferResult -- |
976 |
|
* |
977 |
|
* Copy the result (and error information) from one interp to |
978 |
|
* another. Used when one interp has caused another interp to |
979 |
|
* evaluate a script and then wants to transfer the results back |
980 |
|
* to itself. |
981 |
|
* |
982 |
|
* This routine copies the string reps of the result and error |
983 |
|
* information. It does not simply increment the refcounts of the |
984 |
|
* result and error information objects themselves. |
985 |
|
* It is not legal to exchange objects between interps, because an |
986 |
|
* object may be kept alive by one interp, but have an internal rep |
987 |
|
* that is only valid while some other interp is alive. |
988 |
|
* |
989 |
|
* Results: |
990 |
|
* The target interp's result is set to a copy of the source interp's |
991 |
|
* result. The source's error information "$errorInfo" may be |
992 |
|
* appended to the target's error information and the source's error |
993 |
|
* code "$errorCode" may be stored in the target's error code. |
994 |
|
* |
995 |
|
* Side effects: |
996 |
|
* None. |
997 |
|
* |
998 |
|
*------------------------------------------------------------------------- |
999 |
|
*/ |
1000 |
|
|
1001 |
|
void |
1002 |
|
TclTransferResult(sourceInterp, result, targetInterp) |
1003 |
|
Tcl_Interp *sourceInterp; /* Interp whose result and error information |
1004 |
|
* should be moved to the target interp. |
1005 |
|
* After moving result, this interp's result |
1006 |
|
* is reset. */ |
1007 |
|
int result; /* TCL_OK if just the result should be copied, |
1008 |
|
* TCL_ERROR if both the result and error |
1009 |
|
* information should be copied. */ |
1010 |
|
Tcl_Interp *targetInterp; /* Interp where result and error information |
1011 |
|
* should be stored. If source and target |
1012 |
|
* are the same, nothing is done. */ |
1013 |
|
{ |
1014 |
|
Interp *iPtr; |
1015 |
|
Tcl_Obj *objPtr; |
1016 |
|
|
1017 |
|
if (sourceInterp == targetInterp) { |
1018 |
|
return; |
1019 |
|
} |
1020 |
|
|
1021 |
|
if (result == TCL_ERROR) { |
1022 |
|
/* |
1023 |
|
* An error occurred, so transfer error information from the source |
1024 |
|
* interpreter to the target interpreter. Setting the flags tells |
1025 |
|
* the target interp that it has inherited a partial traceback |
1026 |
|
* chain, not just a simple error message. |
1027 |
|
*/ |
1028 |
|
|
1029 |
|
iPtr = (Interp *) sourceInterp; |
1030 |
|
if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) { |
1031 |
|
Tcl_AddErrorInfo(sourceInterp, ""); |
1032 |
|
} |
1033 |
|
iPtr->flags &= ~(ERR_ALREADY_LOGGED); |
1034 |
|
|
1035 |
|
Tcl_ResetResult(targetInterp); |
1036 |
|
|
1037 |
|
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL, |
1038 |
|
TCL_GLOBAL_ONLY); |
1039 |
|
Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, |
1040 |
|
TCL_GLOBAL_ONLY); |
1041 |
|
|
1042 |
|
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL, |
1043 |
|
TCL_GLOBAL_ONLY); |
1044 |
|
Tcl_SetVar2Ex(targetInterp, "errorCode", NULL, objPtr, |
1045 |
|
TCL_GLOBAL_ONLY); |
1046 |
|
|
1047 |
|
((Interp *) targetInterp)->flags |= (ERR_IN_PROGRESS | ERROR_CODE_SET); |
1048 |
|
} |
1049 |
|
|
1050 |
|
((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode; |
1051 |
|
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); |
1052 |
|
Tcl_ResetResult(sourceInterp); |
1053 |
|
} |
1054 |
|
|
1055 |
|
/* End of tclresult.c */ |