summaryrefslogtreecommitdiffstats
path: root/generic/tclResult.c
diff options
context:
space:
mode:
authorferrieux <ferrieux@users.sourceforge.net>2010-04-05 19:44:44 (GMT)
committerferrieux <ferrieux@users.sourceforge.net>2010-04-05 19:44:44 (GMT)
commit068f40511f242f8ead57c0dca5f00b0eba4b6309 (patch)
tree135ba162a555a418d3cc3bc02fcec17df7d203e2 /generic/tclResult.c
parentb40d694d271c049135dd1a9c6dc276b5de177de2 (diff)
downloadtcl-068f40511f242f8ead57c0dca5f00b0eba4b6309.zip
tcl-068f40511f242f8ead57c0dca5f00b0eba4b6309.tar.gz
tcl-068f40511f242f8ead57c0dca5f00b0eba4b6309.tar.bz2
TIP #348 IMPLEMENTATION - Substituted error stack
Diffstat (limited to 'generic/tclResult.c')
-rw-r--r--generic/tclResult.c83
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:
*/