diff options
| -rw-r--r-- | ChangeLog | 23 | ||||
| -rw-r--r-- | generic/tclBasic.c | 9 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 59 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 218 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclResult.c | 360 |
6 files changed, 395 insertions, 280 deletions
@@ -1,3 +1,26 @@ +2004-10-21 Don Porter <dgp@users.sourceforge.net> + + * generic/tclCmdAH.c (Tcl_CatchObjCmd, Tcl_ErrorObjCmd): + Updated to call the new TclGet/SetReturnOptions routines to do + much of their work. + + * generic/tclInt.h (TclGetReturnOptions,TclSetReturnOptions): + * generic/tclResult.c (TclGetReturnOptions,TclSetReturnOptions): + New utility routines to get/set the return options of an interp. + Intent is that these routines will be converted to public routines + after TIP approval. + + * generic/tclCmdMZ.c (TclProcessReturn,TclMergeReturnOptions): + * generic/tclResult.c (TclProcessReturn,TclMergeReturnOptions): + Move internal utility routines from tclCmdMZ.c to tclResult.c. + + * generic/tclBasic.c (Tcl_CreateInterp, Tcl_DeleteInterp): + * generic/tclResult.c (TclTransferResult): Rework so that + iPtr->returnOpts can be NULL when there are no special options. + + * generic/tclResult.c (TclRestoreInterpState): Plug potential + memory leak. + 2004-10-21 Kevin B. Kenny <kennykb@acm.org> * generic/tclBasic.c: Various changes to [clock format] that, diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1a370bc..7451b69 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.130 2004/10/21 03:53:04 kennykb Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.131 2004/10/21 15:19:46 dgp Exp $ */ #include "tclInt.h" @@ -233,8 +233,7 @@ Tcl_CreateInterp() Tcl_IncrRefCount(iPtr->returnLevelKey); iPtr->returnOptionsKey = Tcl_NewStringObj("-options",-1); Tcl_IncrRefCount(iPtr->returnOptionsKey); - iPtr->returnOpts = Tcl_NewObj(); - Tcl_IncrRefCount(iPtr->returnOpts); + iPtr->returnOpts = NULL; iPtr->errorInfo = NULL; iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1); Tcl_IncrRefCount(iPtr->eiVar); @@ -992,7 +991,9 @@ DeleteInterpProc(interp) Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } - Tcl_DecrRefCount(iPtr->returnOpts); + if (iPtr->returnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); + } Tcl_DecrRefCount(iPtr->returnCodeKey); Tcl_DecrRefCount(iPtr->returnErrorcodeKey); Tcl_DecrRefCount(iPtr->returnErrorinfoKey); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 8d44139..e3c95bd 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.55 2004/10/18 21:15:35 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.56 2004/10/21 15:19:46 dgp Exp $ */ #include "tclInt.h" @@ -269,36 +269,9 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) } } if (objc == 4) { - Interp *iPtr = (Interp *) interp; - Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts); - - if (result == TCL_RETURN) { - Tcl_DictObjPut(NULL, options, - iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode)); - Tcl_DictObjPut(NULL, options, - iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel)); - } else { - Tcl_DictObjPut(NULL, options, - iPtr->returnCodeKey, Tcl_NewIntObj(result)); - Tcl_DictObjPut(NULL, options, - iPtr->returnLevelKey, Tcl_NewIntObj(0)); - } - - if (result == TCL_ERROR) { - /* - * When result was an error, fill in any missing values - * for -errorinfo, -errorcode, and -errorline - */ - Tcl_DictObjPut(NULL, options, - iPtr->returnErrorinfoKey, iPtr->errorInfo); - Tcl_DictObjPut(NULL, options, - iPtr->returnErrorcodeKey, iPtr->errorCode); - Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey, - Tcl_NewIntObj(iPtr->errorLine)); - } - - if (NULL == - Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, options, 0)) { + Tcl_Obj *options = TclGetReturnOptions(interp, result); + if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL, + options, 0)) { Tcl_DecrRefCount(options); Tcl_ResetResult(interp); Tcl_AppendResult(interp, @@ -582,31 +555,29 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; - char *info; - int infoLen; + Tcl_Obj *options; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?"); return TCL_ERROR; } + options = Tcl_NewStringObj("-code error -level 0", -1); + if (objc >= 3) { /* process the optional info argument */ - info = Tcl_GetStringFromObj(objv[2], &infoLen); - if (infoLen > 0) { - Tcl_AddObjErrorInfo(interp, info, infoLen); - iPtr->flags |= ERR_ALREADY_LOGGED; - } + Tcl_ListObjAppendElement(NULL, options, + Tcl_NewStringObj("-errorinfo", -1)); + Tcl_ListObjAppendElement(NULL, options, objv[2]); } - if (objc == 4) { - Tcl_SetObjErrorCode(interp, objv[3]); - } else { - Tcl_SetErrorCode(interp, "NONE", NULL); + if (objc == 4) { /* process the optional code argument */ + Tcl_ListObjAppendElement(NULL, options, + Tcl_NewStringObj("-errorcode", -1)); + Tcl_ListObjAppendElement(NULL, options, objv[3]); } Tcl_SetObjResult(interp, objv[1]); - return TCL_ERROR; + return TclSetReturnOptions(interp, options); } /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 9a8b617..03a4ccb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.114 2004/10/18 21:15:35 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.115 2004/10/21 15:19:46 dgp Exp $ */ #include "tclInt.h" @@ -868,222 +868,6 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * TclProcessReturn -- - * - * Does the work of the [return] command based on the code, - * level, and returnOpts arguments. Note that the code argument - * must agree with the -code entry in returnOpts and the level - * argument must agree with the -level entry in returnOpts, as - * is the case for values returned from TclMergeReturnOptions. - * - * Results: - * Returns the return code the [return] command should return. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ -int -TclProcessReturn(interp, code, level, returnOpts) - Tcl_Interp *interp; - int code; - int level; - Tcl_Obj *returnOpts; -{ - Interp *iPtr = (Interp *) interp; - Tcl_Obj *valuePtr; - - /* Store the merged return options */ - if (iPtr->returnOpts != returnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = returnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } - - if (code == TCL_ERROR) { - valuePtr = NULL; - Tcl_DictObjGet(NULL, iPtr->returnOpts, - iPtr->returnErrorinfoKey, &valuePtr); - if (valuePtr != NULL) { - int infoLen; - CONST char *info = Tcl_GetStringFromObj(valuePtr, &infoLen); - if (infoLen) { - Tcl_AddObjErrorInfo(interp, info, infoLen); - iPtr->flags |= ERR_ALREADY_LOGGED; - } - } - valuePtr = NULL; - Tcl_DictObjGet(NULL, iPtr->returnOpts, - iPtr->returnErrorcodeKey, &valuePtr); - if (valuePtr != NULL) { - Tcl_SetObjErrorCode(interp, valuePtr); - } else { - Tcl_SetErrorCode(interp, "NONE", NULL); - } - - valuePtr = NULL; - Tcl_DictObjGet(NULL, iPtr->returnOpts, - iPtr->returnErrorlineKey, &valuePtr); - if (valuePtr != NULL) { - Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine); - } - } - if (level != 0) { - iPtr->returnLevel = level; - iPtr->returnCode = code; - return TCL_RETURN; - } - return code; -} - -/* - *---------------------------------------------------------------------- - * - * TclMergeReturnOptions -- - * - * Parses, checks, and stores the options to the [return] command. - * - * Results: - * Returns TCL_ERROR is any of the option values are invalid. - * Otherwise, returns TCL_OK, and writes the returnOpts, code, - * and level values to the pointers provided. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ - Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a - * (Tcl_Obj *) where the pointer to the - * merged return options dictionary should - * be written */ - int *codePtr; /* If not NULL, points to space where the - * -code value should be written */ - int *levelPtr; /* If not NULL, points to space where the - * -level value should be written */ -{ - Interp *iPtr = (Interp *) interp; - int code=TCL_OK; - int level = 1; - Tcl_Obj *valuePtr; - Tcl_Obj *returnOpts = Tcl_NewObj(); - - for (; objc > 1; objv += 2, objc -= 2) { - int optLen; - CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen); - int compareLen; - CONST char *compare = Tcl_GetStringFromObj( - iPtr->returnOptionsKey, &compareLen); - - if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { - Tcl_DictSearch search; - int done = 0; - Tcl_Obj *keyPtr; - Tcl_Obj *dict = objv[1]; - - nestedOptions: - if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, - &search, &keyPtr, &valuePtr, &done)) { - /* Value is not a legal dictionary */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad ", - compare, " value: expected dictionary but got \"", - TclGetString(objv[1]), "\"", (char *) NULL); - goto error; - } - - while (!done) { - Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); - Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); - } - - valuePtr = NULL; - Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr); - if (valuePtr != NULL) { - dict = valuePtr; - Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey); - goto nestedOptions; - } - - } else { - Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); - } - } - - /* Check for bogus -code value */ - Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr); - if ((valuePtr != NULL) - && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { - static CONST char *returnCodes[] = { - "ok", "error", "return", "break", "continue", NULL - }; - - if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes, - NULL, TCL_EXACT, &code)) { - /* Value is not a legal return code */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad completion code \"", - TclGetString(valuePtr), - "\": must be ok, error, return, break, ", - "continue, or an integer", (char *) NULL); - goto error; - } - Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey); - } - - /* Check for bogus -level value */ - Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr); - if (valuePtr != NULL) { - if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) - || (level < 0)) { - /* Value is not a legal level */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad -level value: ", - "expected non-negative integer but got \"", - TclGetString(valuePtr), "\"", (char *) NULL); - goto error; - } - Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey); - } - - /* - * Convert [return -code return -level X] to - * [return -code ok -level X+1] - */ - if (code == TCL_RETURN) { - level++; - code = TCL_OK; - } - - if (codePtr != NULL) { - *codePtr = code; - } - if (levelPtr != NULL) { - *levelPtr = level; - } - if (optionsPtrPtr == NULL) { - /* Not passing back the options (?!), so clean them up */ - Tcl_DecrRefCount(returnOpts); - } else { - *optionsPtrPtr = returnOpts; - } - return TCL_OK; - -error: - Tcl_DecrRefCount(returnOpts); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SourceObjCmd -- * * This procedure is invoked to process the "source" Tcl command. diff --git a/generic/tclInt.h b/generic/tclInt.h index f2dc36e..90f02ac 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.184 2004/10/21 03:53:04 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.185 2004/10/21 15:19:46 dgp Exp $ */ #ifndef _TCLINT @@ -1740,6 +1740,8 @@ EXTERN void TclFinalizeAsync _ANSI_ARGS_((void)); EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); EXTERN void TclFinalizeLock _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); +EXTERN Tcl_Obj * TclGetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp, + int result)); EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData* types)); @@ -1912,6 +1914,8 @@ EXTERN int TclRestoreInterpState _ANSI_ARGS_ (( Tcl_Interp *interp, TclInterpState state)); EXTERN TclInterpState TclSaveInterpState _ANSI_ARGS_ (( Tcl_Interp *interp, int status)); +EXTERN int TclSetReturnOptions _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *options)); EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, int result)); EXTERN int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclResult.c b/generic/tclResult.c index de474f7..f2841d9 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -8,7 +8,7 @@ * 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.17 2004/10/19 21:54:07 dgp Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.18 2004/10/21 15:19:47 dgp Exp $ */ #include "tclInt.h" @@ -122,14 +122,23 @@ TclRestoreInterpState(interp, state) iPtr->returnLevel = statePtr->returnLevel; iPtr->returnCode = statePtr->returnCode; + if (iPtr->errorInfo) { + Tcl_DecrRefCount(iPtr->errorInfo); + } iPtr->errorInfo = statePtr->errorInfo; if (iPtr->errorInfo) { Tcl_IncrRefCount(iPtr->errorInfo); } + if (iPtr->errorCode) { + Tcl_DecrRefCount(iPtr->errorCode); + } iPtr->errorCode = statePtr->errorCode; if (iPtr->errorCode) { Tcl_IncrRefCount(iPtr->errorCode); } + if (iPtr->returnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); + } iPtr->returnOpts = statePtr->returnOpts; if (iPtr->returnOpts) { Tcl_IncrRefCount(iPtr->returnOpts); @@ -1052,6 +1061,326 @@ Tcl_SetObjErrorCode(interp, errorObjPtr) } /* + *---------------------------------------------------------------------- + * + * TclProcessReturn -- + * + * Does the work of the [return] command based on the code, + * level, and returnOpts arguments. Note that the code argument + * must agree with the -code entry in returnOpts and the level + * argument must agree with the -level entry in returnOpts, as + * is the case for values returned from TclMergeReturnOptions. + * + * Results: + * Returns the return code the [return] command should return. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +int +TclProcessReturn(interp, code, level, returnOpts) + Tcl_Interp *interp; + int code; + int level; + Tcl_Obj *returnOpts; +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *valuePtr; + + /* Store the merged return options */ + if (iPtr->returnOpts != returnOpts) { + if (iPtr->returnOpts) { + Tcl_DecrRefCount(iPtr->returnOpts); + } + iPtr->returnOpts = returnOpts; + Tcl_IncrRefCount(iPtr->returnOpts); + } + + if (code == TCL_ERROR) { + Tcl_DictObjGet(NULL, iPtr->returnOpts, + iPtr->returnErrorinfoKey, &valuePtr); + if (valuePtr != NULL) { + int infoLen; + (void) Tcl_GetStringFromObj(valuePtr, &infoLen); + if (infoLen) { + if (iPtr->errorInfo) { + Tcl_DecrRefCount(iPtr->errorInfo); + } + iPtr->errorInfo = valuePtr; + Tcl_IncrRefCount(iPtr->errorInfo); + iPtr->flags |= ERR_ALREADY_LOGGED; + } + } + Tcl_DictObjGet(NULL, iPtr->returnOpts, + iPtr->returnErrorcodeKey, &valuePtr); + if (valuePtr != NULL) { + Tcl_SetObjErrorCode(interp, valuePtr); + } else { + Tcl_SetErrorCode(interp, "NONE", NULL); + } + + Tcl_DictObjGet(NULL, iPtr->returnOpts, + iPtr->returnErrorlineKey, &valuePtr); + if (valuePtr != NULL) { + Tcl_GetIntFromObj(NULL, valuePtr, &iPtr->errorLine); + } + } + if (level != 0) { + iPtr->returnLevel = level; + iPtr->returnCode = code; + return TCL_RETURN; + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclMergeReturnOptions -- + * + * Parses, checks, and stores the options to the [return] command. + * + * Results: + * Returns TCL_ERROR is any of the option values are invalid. + * Otherwise, returns TCL_OK, and writes the returnOpts, code, + * and level values to the pointers provided. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ + Tcl_Obj **optionsPtrPtr; /* If not NULL, points to space for a + * (Tcl_Obj *) where the pointer to the + * merged return options dictionary should + * be written */ + int *codePtr; /* If not NULL, points to space where the + * -code value should be written */ + int *levelPtr; /* If not NULL, points to space where the + * -level value should be written */ +{ + Interp *iPtr = (Interp *) interp; + int code=TCL_OK; + int level = 1; + Tcl_Obj *valuePtr; + Tcl_Obj *returnOpts = Tcl_NewObj(); + + for (; objc > 1; objv += 2, objc -= 2) { + int optLen; + CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen); + int compareLen; + CONST char *compare = Tcl_GetStringFromObj( + iPtr->returnOptionsKey, &compareLen); + + if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { + Tcl_DictSearch search; + int done = 0; + Tcl_Obj *keyPtr; + Tcl_Obj *dict = objv[1]; + + nestedOptions: + if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict, + &search, &keyPtr, &valuePtr, &done)) { + /* Value is not a legal dictionary */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad ", + compare, " value: expected dictionary but got \"", + TclGetString(objv[1]), "\"", (char *) NULL); + goto error; + } + + while (!done) { + Tcl_DictObjPut(NULL, returnOpts, keyPtr, valuePtr); + Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); + } + + Tcl_DictObjGet(NULL, returnOpts, iPtr->returnOptionsKey, &valuePtr); + if (valuePtr != NULL) { + dict = valuePtr; + Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnOptionsKey); + goto nestedOptions; + } + + } else { + Tcl_DictObjPut(NULL, returnOpts, objv[0], objv[1]); + } + } + + /* Check for bogus -code value */ + Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr); + if ((valuePtr != NULL) + && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { + static CONST char *returnCodes[] = { + "ok", "error", "return", "break", "continue", NULL + }; + + if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes, + NULL, TCL_EXACT, &code)) { + /* Value is not a legal return code */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad completion code \"", + TclGetString(valuePtr), + "\": must be ok, error, return, break, ", + "continue, or an integer", (char *) NULL); + goto error; + } + Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey); + } + + /* Check for bogus -level value */ + Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr); + if (valuePtr != NULL) { + if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) + || (level < 0)) { + /* Value is not a legal level */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad -level value: ", + "expected non-negative integer but got \"", + TclGetString(valuePtr), "\"", (char *) NULL); + goto error; + } + Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey); + } + + /* + * Convert [return -code return -level X] to + * [return -code ok -level X+1] + */ + if (code == TCL_RETURN) { + level++; + code = TCL_OK; + } + + if (codePtr != NULL) { + *codePtr = code; + } + if (levelPtr != NULL) { + *levelPtr = level; + } + if (optionsPtrPtr == NULL) { + /* Not passing back the options (?!), so clean them up */ + Tcl_DecrRefCount(returnOpts); + } else { + *optionsPtrPtr = returnOpts; + } + return TCL_OK; + +error: + Tcl_DecrRefCount(returnOpts); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * TclGetReturnOptions -- + * + * Packs up the interp state into a dictionary of return options. + * + * Results: + * A dictionary of return options. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetReturnOptions(interp, result) + Tcl_Interp *interp; + int result; +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *options; + + if (iPtr->returnOpts) { + options = Tcl_DuplicateObj(iPtr->returnOpts); + } else { + options = Tcl_NewObj(); + } + + if (result == TCL_RETURN) { + Tcl_DictObjPut(NULL, options, + iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode)); + Tcl_DictObjPut(NULL, options, + iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel)); + } else { + Tcl_DictObjPut(NULL, options, + iPtr->returnCodeKey, Tcl_NewIntObj(result)); + Tcl_DictObjPut(NULL, options, + iPtr->returnLevelKey, Tcl_NewIntObj(0)); + } + + if (result == TCL_ERROR) { + /* + * When result was an error, fill in any missing values + * for -errorinfo, -errorcode, and -errorline + */ + Tcl_DictObjPut(NULL, options, + iPtr->returnErrorinfoKey, iPtr->errorInfo); + Tcl_DictObjPut(NULL, options, + iPtr->returnErrorcodeKey, iPtr->errorCode); + Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey, + Tcl_NewIntObj(iPtr->errorLine)); + } + return options; +} + +/* + *------------------------------------------------------------------------- + * + * TclSetReturnOptions -- + * + * Accepts an interp and a dictionary of return options, and sets + * the return options of the interp to match the dictionary. + * + * Results: + * A standard status code. Usually TCL_OK, but TCL_ERROR if an + * invalid option value was found in the dictionary. If a -level + * value of 0 is in the dictionary, then the -code value in the + * dictionary will be returned (TCL_OK default). + * + * Side effects: + * Sets the state of the interp. + * + *------------------------------------------------------------------------- + */ + +int +TclSetReturnOptions(interp, options) + Tcl_Interp *interp; + Tcl_Obj *options; +{ + int objc, level, code; + Tcl_Obj **objv, *mergedOpts; + + if (TCL_ERROR == Tcl_ListObjGetElements(interp, options, &objc, &objv) + || (objc % 2)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected dict but got \"", + Tcl_GetString(options), "\"", NULL); + code = TCL_ERROR; + } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, + &mergedOpts, &code, &level)) { + code = TCL_ERROR; + } else { + code = TclProcessReturn(interp, code, level, mergedOpts); + } + + Tcl_DecrRefCount(options); + return code; +} + +/* *------------------------------------------------------------------------- * * TclTransferResult -- @@ -1093,7 +1422,8 @@ TclTransferResult(sourceInterp, result, targetInterp) * should be stored. If source and target * are the same, nothing is done. */ { - Interp *iPtr; + Interp *siPtr = (Interp *) sourceInterp; + Interp *tiPtr = (Interp *) targetInterp; if (sourceInterp == targetInterp) { return; @@ -1107,29 +1437,31 @@ TclTransferResult(sourceInterp, result, targetInterp) * chain, not just a simple error message. */ - iPtr = (Interp *) sourceInterp; - if ((iPtr->flags & ERR_ALREADY_LOGGED) == 0) { + if ((siPtr->flags & ERR_ALREADY_LOGGED) == 0) { Tcl_AddErrorInfo(sourceInterp, ""); } - iPtr->flags &= ~(ERR_ALREADY_LOGGED); + siPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_ResetResult(targetInterp); - if (iPtr->errorInfo) { - ((Interp *) targetInterp)->errorInfo = iPtr->errorInfo; - Tcl_IncrRefCount(((Interp *) targetInterp)->errorInfo); + if (siPtr->errorInfo) { + tiPtr->errorInfo = siPtr->errorInfo; + Tcl_IncrRefCount(tiPtr->errorInfo); } - if (iPtr->errorCode) { - Tcl_SetObjErrorCode(targetInterp, iPtr->errorCode); + if (siPtr->errorCode) { + Tcl_SetObjErrorCode(targetInterp, siPtr->errorCode); } } /* This may need examination for safety */ - Tcl_DecrRefCount( ((Interp *) targetInterp)->returnOpts ); - ((Interp *) targetInterp)->returnOpts = - ((Interp *) sourceInterp)->returnOpts; - Tcl_IncrRefCount( ((Interp *) targetInterp)->returnOpts ); + if (tiPtr->returnOpts ) { + Tcl_DecrRefCount(tiPtr->returnOpts ); + } + tiPtr->returnOpts = siPtr->returnOpts; + if (tiPtr->returnOpts ) { + Tcl_IncrRefCount(tiPtr->returnOpts ); + } Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp)); Tcl_ResetResult(sourceInterp); |