sl@0: /* sl@0: * tclResult.c -- sl@0: * sl@0: * This file contains code to manage the interpreter result. sl@0: * sl@0: * Copyright (c) 1997 by Sun Microsystems, Inc. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclResult.c,v 1.5.2.2 2004/09/30 22:45:15 dgp Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: sl@0: /* sl@0: * Function prototypes for local procedures in this file: sl@0: */ sl@0: sl@0: static void ResetObjResult _ANSI_ARGS_((Interp *iPtr)); sl@0: static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, sl@0: int newSpace)); sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SaveResult -- sl@0: * sl@0: * Takes a snapshot of the current result state of the interpreter. sl@0: * The snapshot can be restored at any point by sl@0: * Tcl_RestoreResult. Note that this routine does not sl@0: * preserve the errorCode, errorInfo, or flags fields so it sl@0: * should not be used if an error is in progress. sl@0: * sl@0: * Once a snapshot is saved, it must be restored by calling sl@0: * Tcl_RestoreResult, or discarded by calling sl@0: * Tcl_DiscardResult. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Resets the interpreter result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SaveResult(interp, statePtr) sl@0: Tcl_Interp *interp; /* Interpreter to save. */ sl@0: Tcl_SavedResult *statePtr; /* Pointer to state structure. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: /* sl@0: * Move the result object into the save state. Note that we don't need sl@0: * to change its refcount because we're moving it, not adding a new sl@0: * reference. Put an empty object into the interpreter. sl@0: */ sl@0: sl@0: statePtr->objResultPtr = iPtr->objResultPtr; sl@0: iPtr->objResultPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(iPtr->objResultPtr); sl@0: sl@0: /* sl@0: * Save the string result. sl@0: */ sl@0: sl@0: statePtr->freeProc = iPtr->freeProc; sl@0: if (iPtr->result == iPtr->resultSpace) { sl@0: /* sl@0: * Copy the static string data out of the interp buffer. sl@0: */ sl@0: sl@0: statePtr->result = statePtr->resultSpace; sl@0: strcpy(statePtr->result, iPtr->result); sl@0: statePtr->appendResult = NULL; sl@0: } else if (iPtr->result == iPtr->appendResult) { sl@0: /* sl@0: * Move the append buffer out of the interp. sl@0: */ sl@0: sl@0: statePtr->appendResult = iPtr->appendResult; sl@0: statePtr->appendAvl = iPtr->appendAvl; sl@0: statePtr->appendUsed = iPtr->appendUsed; sl@0: statePtr->result = statePtr->appendResult; sl@0: iPtr->appendResult = NULL; sl@0: iPtr->appendAvl = 0; sl@0: iPtr->appendUsed = 0; sl@0: } else { sl@0: /* sl@0: * Move the dynamic or static string out of the interpreter. sl@0: */ sl@0: sl@0: statePtr->result = iPtr->result; sl@0: statePtr->appendResult = NULL; sl@0: } sl@0: sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->resultSpace[0] = 0; sl@0: iPtr->freeProc = 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_RestoreResult -- sl@0: * sl@0: * Restores the state of the interpreter to a snapshot taken sl@0: * by Tcl_SaveResult. After this call, the token for sl@0: * the interpreter state is no longer valid. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Restores the interpreter result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_RestoreResult(interp, statePtr) sl@0: Tcl_Interp* interp; /* Interpreter being restored. */ sl@0: Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: Tcl_ResetResult(interp); sl@0: sl@0: /* sl@0: * Restore the string result. sl@0: */ sl@0: sl@0: iPtr->freeProc = statePtr->freeProc; sl@0: if (statePtr->result == statePtr->resultSpace) { sl@0: /* sl@0: * Copy the static string data into the interp buffer. sl@0: */ sl@0: sl@0: iPtr->result = iPtr->resultSpace; sl@0: strcpy(iPtr->result, statePtr->result); sl@0: } else if (statePtr->result == statePtr->appendResult) { sl@0: /* sl@0: * Move the append buffer back into the interp. sl@0: */ sl@0: sl@0: if (iPtr->appendResult != NULL) { sl@0: ckfree((char *)iPtr->appendResult); sl@0: } sl@0: sl@0: iPtr->appendResult = statePtr->appendResult; sl@0: iPtr->appendAvl = statePtr->appendAvl; sl@0: iPtr->appendUsed = statePtr->appendUsed; sl@0: iPtr->result = iPtr->appendResult; sl@0: } else { sl@0: /* sl@0: * Move the dynamic or static string back into the interpreter. sl@0: */ sl@0: sl@0: iPtr->result = statePtr->result; sl@0: } sl@0: sl@0: /* sl@0: * Restore the object result. sl@0: */ sl@0: sl@0: Tcl_DecrRefCount(iPtr->objResultPtr); sl@0: iPtr->objResultPtr = statePtr->objResultPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DiscardResult -- sl@0: * sl@0: * Frees the memory associated with an interpreter snapshot sl@0: * taken by Tcl_SaveResult. If the snapshot is not sl@0: * restored, this procedure must be called to discard it, sl@0: * or the memory will be lost. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DiscardResult(statePtr) sl@0: Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */ sl@0: { sl@0: TclDecrRefCount(statePtr->objResultPtr); sl@0: sl@0: if (statePtr->result == statePtr->appendResult) { sl@0: ckfree(statePtr->appendResult); sl@0: } else if (statePtr->freeProc) { sl@0: if (statePtr->freeProc == TCL_DYNAMIC) { sl@0: ckfree(statePtr->result); sl@0: } else { sl@0: (*statePtr->freeProc)(statePtr->result); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetResult -- sl@0: * sl@0: * Arrange for "string" to be the Tcl return value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * interp->result is left pointing either to "string" (if "copy" is 0) sl@0: * or to a copy of string. Also, the object result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetResult(interp, string, freeProc) sl@0: Tcl_Interp *interp; /* Interpreter with which to associate the sl@0: * return value. */ sl@0: register char *string; /* Value to be returned. If NULL, the sl@0: * result is set to an empty string. */ sl@0: Tcl_FreeProc *freeProc; /* Gives information about the string: sl@0: * TCL_STATIC, TCL_VOLATILE, or the address sl@0: * of a Tcl_FreeProc such as free. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: int length; sl@0: register Tcl_FreeProc *oldFreeProc = iPtr->freeProc; sl@0: char *oldResult = iPtr->result; sl@0: sl@0: if (string == NULL) { sl@0: iPtr->resultSpace[0] = 0; sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->freeProc = 0; sl@0: } else if (freeProc == TCL_VOLATILE) { sl@0: length = strlen(string); sl@0: if (length > TCL_RESULT_SIZE) { sl@0: iPtr->result = (char *) ckalloc((unsigned) length+1); sl@0: iPtr->freeProc = TCL_DYNAMIC; sl@0: } else { sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->freeProc = 0; sl@0: } sl@0: strcpy(iPtr->result, string); sl@0: } else { sl@0: iPtr->result = string; sl@0: iPtr->freeProc = freeProc; sl@0: } sl@0: sl@0: /* sl@0: * If the old result was dynamically-allocated, free it up. Do it sl@0: * here, rather than at the beginning, in case the new result value sl@0: * was part of the old result value. sl@0: */ sl@0: sl@0: if (oldFreeProc != 0) { sl@0: if (oldFreeProc == TCL_DYNAMIC) { sl@0: ckfree(oldResult); sl@0: } else { sl@0: (*oldFreeProc)(oldResult); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Reset the object result since we just set the string result. sl@0: */ sl@0: sl@0: ResetObjResult(iPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetStringResult -- sl@0: * sl@0: * Returns an interpreter's result value as a string. sl@0: * sl@0: * Results: sl@0: * The interpreter's result as a string. sl@0: * sl@0: * Side effects: sl@0: * If the string result is empty, the object result is moved to the sl@0: * string result, then the object result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_GetStringResult(interp) sl@0: register Tcl_Interp *interp; /* Interpreter whose result to return. */ sl@0: { sl@0: /* sl@0: * If the string result is empty, move the object result to the sl@0: * string result, then reset the object result. sl@0: */ sl@0: sl@0: if (*(interp->result) == 0) { sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: return interp->result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetObjResult -- sl@0: * sl@0: * Arrange for objPtr to be an interpreter's result value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * interp->objResultPtr is left pointing to the object referenced sl@0: * by objPtr. The object's reference count is incremented since sl@0: * there is now a new reference to it. The reference count for any sl@0: * old objResultPtr value is decremented. Also, the string result sl@0: * is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetObjResult(interp, objPtr) sl@0: Tcl_Interp *interp; /* Interpreter with which to associate the sl@0: * return object value. */ sl@0: register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the sl@0: * obj result is made an empty string sl@0: * object. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: register Tcl_Obj *oldObjResult = iPtr->objResultPtr; sl@0: sl@0: iPtr->objResultPtr = objPtr; sl@0: Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ sl@0: sl@0: /* sl@0: * We wait until the end to release the old object result, in case sl@0: * we are setting the result to itself. sl@0: */ sl@0: sl@0: TclDecrRefCount(oldObjResult); sl@0: sl@0: /* sl@0: * Reset the string result since we just set the result object. sl@0: */ sl@0: sl@0: if (iPtr->freeProc != NULL) { sl@0: if (iPtr->freeProc == TCL_DYNAMIC) { sl@0: ckfree(iPtr->result); sl@0: } else { sl@0: (*iPtr->freeProc)(iPtr->result); sl@0: } sl@0: iPtr->freeProc = 0; sl@0: } sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->resultSpace[0] = 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetObjResult -- sl@0: * sl@0: * Returns an interpreter's result value as a Tcl object. The object's sl@0: * reference count is not modified; the caller must do that if it sl@0: * needs to hold on to a long-term reference to it. sl@0: * sl@0: * Results: sl@0: * The interpreter's result as an object. sl@0: * sl@0: * Side effects: sl@0: * If the interpreter has a non-empty string result, the result object sl@0: * is either empty or stale because some procedure set interp->result sl@0: * directly. If so, the string result is moved to the result object sl@0: * then the string result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_GetObjResult(interp) sl@0: Tcl_Interp *interp; /* Interpreter whose result to return. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj *objResultPtr; sl@0: int length; sl@0: sl@0: /* sl@0: * If the string result is non-empty, move the string result to the sl@0: * object result, then reset the string result. sl@0: */ sl@0: sl@0: if (*(iPtr->result) != 0) { sl@0: ResetObjResult(iPtr); sl@0: sl@0: objResultPtr = iPtr->objResultPtr; sl@0: length = strlen(iPtr->result); sl@0: TclInitStringRep(objResultPtr, iPtr->result, length); sl@0: sl@0: if (iPtr->freeProc != NULL) { sl@0: if (iPtr->freeProc == TCL_DYNAMIC) { sl@0: ckfree(iPtr->result); sl@0: } else { sl@0: (*iPtr->freeProc)(iPtr->result); sl@0: } sl@0: iPtr->freeProc = 0; sl@0: } sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->resultSpace[0] = 0; sl@0: } sl@0: return iPtr->objResultPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AppendResultVA -- sl@0: * sl@0: * Append a variable number of strings onto the interpreter's string sl@0: * result. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The result of the interpreter given by the first argument is sl@0: * extended by the strings in the va_list (up to a terminating NULL sl@0: * argument). sl@0: * sl@0: * If the string result is empty, the object result is moved to the sl@0: * string result, then the object result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_AppendResultVA (interp, argList) sl@0: Tcl_Interp *interp; /* Interpreter with which to associate the sl@0: * return value. */ sl@0: va_list argList; /* Variable argument list. */ sl@0: { sl@0: #define STATIC_LIST_SIZE 16 sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *string, *static_list[STATIC_LIST_SIZE]; sl@0: char **args = static_list; sl@0: int nargs_space = STATIC_LIST_SIZE; sl@0: int nargs, newSpace, i; sl@0: sl@0: /* sl@0: * If the string result is empty, move the object result to the sl@0: * string result, then reset the object result. sl@0: */ sl@0: sl@0: if (*(iPtr->result) == 0) { sl@0: Tcl_SetResult((Tcl_Interp *) iPtr, sl@0: TclGetString(Tcl_GetObjResult((Tcl_Interp *) iPtr)), sl@0: TCL_VOLATILE); sl@0: } sl@0: sl@0: /* sl@0: * Scan through all the arguments to see how much space is needed sl@0: * and save pointers to the arguments in the args array, sl@0: * reallocating as necessary. sl@0: */ sl@0: sl@0: nargs = 0; sl@0: newSpace = 0; sl@0: while (1) { sl@0: string = va_arg(argList, char *); sl@0: if (string == NULL) { sl@0: break; sl@0: } sl@0: if (nargs >= nargs_space) { sl@0: /* sl@0: * Expand the args buffer sl@0: */ sl@0: nargs_space += STATIC_LIST_SIZE; sl@0: if (args == static_list) { sl@0: args = (void *)ckalloc(nargs_space * sizeof(char *)); sl@0: for (i = 0; i < nargs; ++i) { sl@0: args[i] = static_list[i]; sl@0: } sl@0: } else { sl@0: args = (void *)ckrealloc((void *)args, sl@0: nargs_space * sizeof(char *)); sl@0: } sl@0: } sl@0: newSpace += strlen(string); sl@0: args[nargs++] = string; sl@0: } sl@0: sl@0: /* sl@0: * If the append buffer isn't already setup and large enough to hold sl@0: * the new data, set it up. sl@0: */ sl@0: sl@0: if ((iPtr->result != iPtr->appendResult) sl@0: || (iPtr->appendResult[iPtr->appendUsed] != 0) sl@0: || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { sl@0: SetupAppendBuffer(iPtr, newSpace); sl@0: } sl@0: sl@0: /* sl@0: * Now go through all the argument strings again, copying them into the sl@0: * buffer. sl@0: */ sl@0: sl@0: for (i = 0; i < nargs; ++i) { sl@0: string = args[i]; sl@0: strcpy(iPtr->appendResult + iPtr->appendUsed, string); sl@0: iPtr->appendUsed += strlen(string); sl@0: } sl@0: sl@0: /* sl@0: * If we had to allocate a buffer from the heap, sl@0: * free it now. sl@0: */ sl@0: sl@0: if (args != static_list) { sl@0: ckfree((void *)args); sl@0: } sl@0: #undef STATIC_LIST_SIZE sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AppendResult -- sl@0: * sl@0: * Append a variable number of strings onto the interpreter's string sl@0: * result. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The result of the interpreter given by the first argument is sl@0: * extended by the strings given by the second and following arguments sl@0: * (up to a terminating NULL argument). sl@0: * sl@0: * If the string result is empty, the object result is moved to the sl@0: * string result, then the object result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) sl@0: { sl@0: Tcl_Interp *interp; sl@0: va_list argList; sl@0: sl@0: interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); sl@0: Tcl_AppendResultVA(interp, argList); sl@0: va_end(argList); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AppendElement -- sl@0: * sl@0: * Convert a string to a valid Tcl list element and append it to the sl@0: * result (which is ostensibly a list). sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The result in the interpreter given by the first argument is sl@0: * extended with a list element converted from string. A separator sl@0: * space is added before the converted list element unless the current sl@0: * result is empty, contains the single character "{", or ends in " {". sl@0: * sl@0: * If the string result is empty, the object result is moved to the sl@0: * string result, then the object result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_AppendElement(interp, string) sl@0: Tcl_Interp *interp; /* Interpreter whose result is to be sl@0: * extended. */ sl@0: CONST char *string; /* String to convert to list element and sl@0: * add to result. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *dst; sl@0: int size; sl@0: int flags; sl@0: sl@0: /* sl@0: * If the string result is empty, move the object result to the sl@0: * string result, then reset the object result. sl@0: */ sl@0: sl@0: if (*(iPtr->result) == 0) { sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: sl@0: /* sl@0: * See how much space is needed, and grow the append buffer if sl@0: * needed to accommodate the list element. sl@0: */ sl@0: sl@0: size = Tcl_ScanElement(string, &flags) + 1; sl@0: if ((iPtr->result != iPtr->appendResult) sl@0: || (iPtr->appendResult[iPtr->appendUsed] != 0) sl@0: || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { sl@0: SetupAppendBuffer(iPtr, size+iPtr->appendUsed); sl@0: } sl@0: sl@0: /* sl@0: * Convert the string into a list element and copy it to the sl@0: * buffer that's forming, with a space separator if needed. sl@0: */ sl@0: sl@0: dst = iPtr->appendResult + iPtr->appendUsed; sl@0: if (TclNeedSpace(iPtr->appendResult, dst)) { sl@0: iPtr->appendUsed++; sl@0: *dst = ' '; sl@0: dst++; sl@0: } sl@0: iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetupAppendBuffer -- sl@0: * sl@0: * This procedure makes sure that there is an append buffer properly sl@0: * initialized, if necessary, from the interpreter's result, and sl@0: * that it has at least enough room to accommodate newSpace new sl@0: * bytes of information. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: SetupAppendBuffer(iPtr, newSpace) sl@0: Interp *iPtr; /* Interpreter whose result is being set up. */ sl@0: int newSpace; /* Make sure that at least this many bytes sl@0: * of new information may be added. */ sl@0: { sl@0: int totalSpace; sl@0: sl@0: /* sl@0: * Make the append buffer larger, if that's necessary, then copy the sl@0: * result into the append buffer and make the append buffer the official sl@0: * Tcl result. sl@0: */ sl@0: sl@0: if (iPtr->result != iPtr->appendResult) { sl@0: /* sl@0: * If an oversized buffer was used recently, then free it up sl@0: * so we go back to a smaller buffer. This avoids tying up sl@0: * memory forever after a large operation. sl@0: */ sl@0: sl@0: if (iPtr->appendAvl > 500) { sl@0: ckfree(iPtr->appendResult); sl@0: iPtr->appendResult = NULL; sl@0: iPtr->appendAvl = 0; sl@0: } sl@0: iPtr->appendUsed = strlen(iPtr->result); sl@0: } else if (iPtr->result[iPtr->appendUsed] != 0) { sl@0: /* sl@0: * Most likely someone has modified a result created by sl@0: * Tcl_AppendResult et al. so that it has a different size. sl@0: * Just recompute the size. sl@0: */ sl@0: sl@0: iPtr->appendUsed = strlen(iPtr->result); sl@0: } sl@0: sl@0: totalSpace = newSpace + iPtr->appendUsed; sl@0: if (totalSpace >= iPtr->appendAvl) { sl@0: char *new; sl@0: sl@0: if (totalSpace < 100) { sl@0: totalSpace = 200; sl@0: } else { sl@0: totalSpace *= 2; sl@0: } sl@0: new = (char *) ckalloc((unsigned) totalSpace); sl@0: strcpy(new, iPtr->result); sl@0: if (iPtr->appendResult != NULL) { sl@0: ckfree(iPtr->appendResult); sl@0: } sl@0: iPtr->appendResult = new; sl@0: iPtr->appendAvl = totalSpace; sl@0: } else if (iPtr->result != iPtr->appendResult) { sl@0: strcpy(iPtr->appendResult, iPtr->result); sl@0: } sl@0: sl@0: Tcl_FreeResult((Tcl_Interp *) iPtr); sl@0: iPtr->result = iPtr->appendResult; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_FreeResult -- sl@0: * sl@0: * This procedure frees up the memory associated with an interpreter's sl@0: * string result. It also resets the interpreter's result object. sl@0: * Tcl_FreeResult is most commonly used when a procedure is about to sl@0: * replace one result value with another. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Frees the memory associated with interp's string result and sets sl@0: * interp->freeProc to zero, but does not change interp->result or sl@0: * clear error state. Resets interp's result object to an unshared sl@0: * empty object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_FreeResult(interp) sl@0: register Tcl_Interp *interp; /* Interpreter for which to free result. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: sl@0: if (iPtr->freeProc != NULL) { sl@0: if (iPtr->freeProc == TCL_DYNAMIC) { sl@0: ckfree(iPtr->result); sl@0: } else { sl@0: (*iPtr->freeProc)(iPtr->result); sl@0: } sl@0: iPtr->freeProc = 0; sl@0: } sl@0: sl@0: ResetObjResult(iPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ResetResult -- sl@0: * sl@0: * This procedure resets both the interpreter's string and object sl@0: * results. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * It resets the result object to an unshared empty object. It sl@0: * then restores the interpreter's string result area to its default sl@0: * initialized state, freeing up any memory that may have been sl@0: * allocated. It also clears any error information for the interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_ResetResult(interp) sl@0: register Tcl_Interp *interp; /* Interpreter for which to clear result. */ sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: sl@0: ResetObjResult(iPtr); sl@0: if (iPtr->freeProc != NULL) { sl@0: if (iPtr->freeProc == TCL_DYNAMIC) { sl@0: ckfree(iPtr->result); sl@0: } else { sl@0: (*iPtr->freeProc)(iPtr->result); sl@0: } sl@0: iPtr->freeProc = 0; sl@0: } sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->resultSpace[0] = 0; sl@0: iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ResetObjResult -- sl@0: * sl@0: * Procedure used to reset an interpreter's Tcl result object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Resets the interpreter's result object to an unshared empty string sl@0: * object with ref count one. It does not clear any error information sl@0: * in the interpreter. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: ResetObjResult(iPtr) sl@0: register Interp *iPtr; /* Points to the interpreter whose result sl@0: * object should be reset. */ sl@0: { sl@0: register Tcl_Obj *objResultPtr = iPtr->objResultPtr; sl@0: sl@0: if (Tcl_IsShared(objResultPtr)) { sl@0: TclDecrRefCount(objResultPtr); sl@0: TclNewObj(objResultPtr); sl@0: Tcl_IncrRefCount(objResultPtr); sl@0: iPtr->objResultPtr = objResultPtr; sl@0: } else { sl@0: if ((objResultPtr->bytes != NULL) sl@0: && (objResultPtr->bytes != tclEmptyStringRep)) { sl@0: ckfree((char *) objResultPtr->bytes); sl@0: } sl@0: objResultPtr->bytes = tclEmptyStringRep; sl@0: objResultPtr->length = 0; sl@0: if ((objResultPtr->typePtr != NULL) sl@0: && (objResultPtr->typePtr->freeIntRepProc != NULL)) { sl@0: objResultPtr->typePtr->freeIntRepProc(objResultPtr); sl@0: } sl@0: objResultPtr->typePtr = (Tcl_ObjType *) NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetErrorCodeVA -- sl@0: * sl@0: * This procedure is called to record machine-readable information sl@0: * about an error that is about to be returned. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The errorCode global variable is modified to hold all of the sl@0: * arguments to this procedure, in a list form with each argument sl@0: * becoming one element of the list. A flag is set internally sl@0: * to remember that errorCode has been set, so the variable doesn't sl@0: * get set automatically when the error is returned. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetErrorCodeVA (interp, argList) sl@0: Tcl_Interp *interp; /* Interpreter in which to access the errorCode sl@0: * variable. */ sl@0: va_list argList; /* Variable argument list. */ sl@0: { sl@0: char *string; sl@0: int flags; sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: /* sl@0: * Scan through the arguments one at a time, appending them to sl@0: * $errorCode as list elements. sl@0: */ sl@0: sl@0: flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; sl@0: while (1) { sl@0: string = va_arg(argList, char *); sl@0: if (string == NULL) { sl@0: break; sl@0: } sl@0: (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", sl@0: (char *) NULL, string, flags); sl@0: flags |= TCL_APPEND_VALUE; sl@0: } sl@0: iPtr->flags |= ERROR_CODE_SET; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetErrorCode -- sl@0: * sl@0: * This procedure is called to record machine-readable information sl@0: * about an error that is about to be returned. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The errorCode global variable is modified to hold all of the sl@0: * arguments to this procedure, in a list form with each argument sl@0: * becoming one element of the list. A flag is set internally sl@0: * to remember that errorCode has been set, so the variable doesn't sl@0: * get set automatically when the error is returned. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: /* VARARGS2 */ sl@0: EXPORT_C void sl@0: Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) sl@0: { sl@0: Tcl_Interp *interp; sl@0: va_list argList; sl@0: sl@0: /* sl@0: * Scan through the arguments one at a time, appending them to sl@0: * $errorCode as list elements. sl@0: */ sl@0: sl@0: interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList); sl@0: Tcl_SetErrorCodeVA(interp, argList); sl@0: va_end(argList); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetObjErrorCode -- sl@0: * sl@0: * This procedure is called to record machine-readable information sl@0: * about an error that is about to be returned. The caller should sl@0: * build a list object up and pass it to this routine. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The errorCode global variable is modified to be the new value. sl@0: * A flag is set internally to remember that errorCode has been sl@0: * set, so the variable doesn't get set automatically when the sl@0: * error is returned. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetObjErrorCode(interp, errorObjPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj *errorObjPtr; sl@0: { sl@0: Interp *iPtr; sl@0: sl@0: iPtr = (Interp *) interp; sl@0: Tcl_SetVar2Ex(interp, "errorCode", NULL, errorObjPtr, TCL_GLOBAL_ONLY); sl@0: iPtr->flags |= ERROR_CODE_SET; sl@0: } sl@0: sl@0: /* sl@0: *------------------------------------------------------------------------- sl@0: * sl@0: * TclTransferResult -- sl@0: * sl@0: * Copy the result (and error information) from one interp to sl@0: * another. Used when one interp has caused another interp to sl@0: * evaluate a script and then wants to transfer the results back sl@0: * to itself. sl@0: * sl@0: * This routine copies the string reps of the result and error sl@0: * information. It does not simply increment the refcounts of the sl@0: * result and error information objects themselves. sl@0: * It is not legal to exchange objects between interps, because an sl@0: * object may be kept alive by one interp, but have an internal rep sl@0: * that is only valid while some other interp is alive. sl@0: * sl@0: * Results: sl@0: * The target interp's result is set to a copy of the source interp's sl@0: * result. The source's error information "$errorInfo" may be sl@0: * appended to the target's error information and the source's error sl@0: * code "$errorCode" may be stored in the target's error code. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclTransferResult(sourceInterp, result, targetInterp) sl@0: Tcl_Interp *sourceInterp; /* Interp whose result and error information sl@0: * should be moved to the target interp. sl@0: * After moving result, this interp's result sl@0: * is reset. */ sl@0: int result; /* TCL_OK if just the result should be copied, sl@0: * TCL_ERROR if both the result and error sl@0: * information should be copied. */ sl@0: Tcl_Interp *targetInterp; /* Interp where result and error information sl@0: * should be stored. If source and target sl@0: * are the same, nothing is done. */ sl@0: { sl@0: Interp *iPtr; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: if (sourceInterp == targetInterp) { sl@0: return; sl@0: } sl@0: sl@0: if (result == TCL_ERROR) { sl@0: /* sl@0: * An error occurred, so transfer error information from the source sl@0: * interpreter to the target interpreter. Setting the flags tells sl@0: * the target interp that it has inherited a partial traceback sl@0: * chain, not just a simple error message. sl@0: */ sl@0: sl@0: iPtr = (Interp *) sourceInterp; sl@0: if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) { sl@0: Tcl_AddErrorInfo(sourceInterp, ""); sl@0: } sl@0: iPtr->flags &= ~(ERR_ALREADY_LOGGED); sl@0: sl@0: Tcl_ResetResult(targetInterp); sl@0: sl@0: objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL, sl@0: TCL_GLOBAL_ONLY); sl@0: if (objPtr) { sl@0: Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr, sl@0: TCL_GLOBAL_ONLY); sl@0: ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS; sl@0: } sl@0: sl@0: objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL, sl@0: TCL_GLOBAL_ONLY); sl@0: if (objPtr) { sl@0: Tcl_SetObjErrorCode(targetInterp, objPtr); sl@0: } sl@0: sl@0: } sl@0: sl@0: ((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode; sl@0: Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); sl@0: Tcl_ResetResult(sourceInterp); sl@0: }