diff options
Diffstat (limited to 'generic/tclResult.c')
| -rw-r--r-- | generic/tclResult.c | 83 |
1 files changed, 81 insertions, 2 deletions
diff --git a/generic/tclResult.c b/generic/tclResult.c index 1fcdfba..07b50db 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.60 2010/03/30 13:17:18 nijtmans Exp $ + * RCS: @(#) $Id: tclResult.c,v 1.61 2010/04/05 19:44:45 ferrieux Exp $ */ #include "tclInt.h" @@ -19,7 +19,7 @@ enum returnKeys { KEY_CODE, KEY_ERRORCODE, KEY_ERRORINFO, KEY_ERRORLINE, - KEY_LEVEL, KEY_OPTIONS, KEY_LAST + KEY_LEVEL, KEY_OPTIONS, KEY_ERRORSTACK, KEY_LAST }; /* @@ -46,6 +46,8 @@ typedef struct InterpState { Tcl_Obj *errorCode; Tcl_Obj *returnOpts; Tcl_Obj *objResult; + Tcl_Obj *errorStack; + int resetErrorStack; } InterpState; /* @@ -82,6 +84,8 @@ Tcl_SaveInterpState( statePtr->returnLevel = iPtr->returnLevel; statePtr->returnCode = iPtr->returnCode; statePtr->errorInfo = iPtr->errorInfo; + statePtr->errorStack = iPtr->errorStack; + statePtr->resetErrorStack = iPtr->resetErrorStack; if (statePtr->errorInfo) { Tcl_IncrRefCount(statePtr->errorInfo); } @@ -93,6 +97,9 @@ Tcl_SaveInterpState( if (statePtr->returnOpts) { Tcl_IncrRefCount(statePtr->returnOpts); } + if (statePtr->errorStack) { + Tcl_IncrRefCount(statePtr->errorStack); + } statePtr->objResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(statePtr->objResult); return (Tcl_InterpState) statePtr; @@ -130,6 +137,7 @@ Tcl_RestoreInterpState( iPtr->returnLevel = statePtr->returnLevel; iPtr->returnCode = statePtr->returnCode; + iPtr->resetErrorStack = statePtr->resetErrorStack; if (iPtr->errorInfo) { Tcl_DecrRefCount(iPtr->errorInfo); } @@ -144,6 +152,13 @@ Tcl_RestoreInterpState( if (iPtr->errorCode) { Tcl_IncrRefCount(iPtr->errorCode); } + if (iPtr->errorStack) { + Tcl_DecrRefCount(iPtr->errorStack); + } + iPtr->errorStack = statePtr->errorStack; + if (iPtr->errorStack) { + Tcl_IncrRefCount(iPtr->errorStack); + } if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } @@ -188,6 +203,9 @@ Tcl_DiscardInterpState( if (statePtr->returnOpts) { Tcl_DecrRefCount(statePtr->returnOpts); } + if (statePtr->errorStack) { + Tcl_DecrRefCount(statePtr->errorStack); + } Tcl_DecrRefCount(statePtr->objResult); ckfree((char *) statePtr); } @@ -924,6 +942,7 @@ Tcl_ResetResult( Tcl_DecrRefCount(iPtr->errorInfo); iPtr->errorInfo = NULL; } + iPtr->resetErrorStack = 1; iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; if (iPtr->returnOpts) { @@ -1161,6 +1180,7 @@ GetKeys(void) TclNewLiteralStringObj(keys[KEY_ERRORCODE], "-errorcode"); TclNewLiteralStringObj(keys[KEY_ERRORINFO], "-errorinfo"); TclNewLiteralStringObj(keys[KEY_ERRORLINE], "-errorline"); + TclNewLiteralStringObj(keys[KEY_ERRORSTACK],"-errorstack"); TclNewLiteralStringObj(keys[KEY_LEVEL], "-level"); TclNewLiteralStringObj(keys[KEY_OPTIONS], "-options"); @@ -1266,6 +1286,31 @@ TclProcessReturn( iPtr->flags |= ERR_ALREADY_LOGGED; } } + Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); + if (valuePtr != NULL) { + int len, valueObjc; + Tcl_Obj **valueObjv; + + if (Tcl_IsShared(iPtr->errorStack)) { + Tcl_Obj *newObj; + + newObj = Tcl_DuplicateObj(iPtr->errorStack); + Tcl_DecrRefCount(iPtr->errorStack); + Tcl_IncrRefCount(newObj); + iPtr->errorStack = newObj; + } + /* + * List extraction done after duplication to avoid moving the rug + * if someone does [return -errorstack [info errorstack]] + */ + if (Tcl_ListObjGetElements(interp, valuePtr, &valueObjc, &valueObjv) == TCL_ERROR) { + return TCL_ERROR; + } + iPtr->resetErrorStack = 0; + Tcl_ListObjLength(interp, iPtr->errorStack, &len); + /* reset while keeping the list intrep as much as possible */ + Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, valueObjc, valueObjv); + } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); @@ -1429,6 +1474,37 @@ TclMergeReturnOptions( } /* + * Check for bogus -errorstack value. + */ + + Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr); + if (valuePtr != NULL) { + int length; + + if (TCL_ERROR == Tcl_ListObjLength(NULL, valuePtr, &length )) { + /* + * Value is not a list, which is illegal for -errorstack. + */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad -errorstack value: " + "expected a list but got \"", + TclGetString(valuePtr), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL); + goto error; + } + if (length % 2) { + /* + * Errorstack must always be an even-sized list + */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "forbidden odd-sized list for -errorstack: \"", + TclGetString(valuePtr), "\"", NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL); + goto error; + } + } + + /* * Convert [return -code return -level X] to [return -code ok -level X+1] */ @@ -1505,6 +1581,7 @@ Tcl_GetReturnOptions( if (result == TCL_ERROR) { Tcl_AddObjErrorInfo(interp, "", -1); + Tcl_DictObjPut(NULL, options, keys[KEY_ERRORSTACK], iPtr->errorStack); } if (iPtr->errorCode) { Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode); @@ -1636,5 +1713,7 @@ Tcl_TransferResult( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ |