/[dtapublic]/projs/emts/trunk/src/c_tcl_base_7_5_w_mods/tclresult.c
ViewVC logotype

Diff of /projs/emts/trunk/src/c_tcl_base_7_5_w_mods/tclresult.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclresult.c revision 29 by dashley, Sat Oct 8 07:08:47 2016 UTC projs/dtats/trunk/shared_source/c_tcl_base_7_5_w_mods/tclresult.c revision 98 by dashley, Sun Dec 18 00:57:31 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclresult.c,v 1.1.1.1 2001/06/13 04:45:53 dtashley Exp $ */  
   
 /*  
  * 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 */
Legend:
Removed from v.29  
changed lines
  Added in v.98
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25