summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c16
-rw-r--r--generic/tclCmdAH.c6
-rw-r--r--generic/tclCmdMZ.c4
-rw-r--r--generic/tclNamesp.c66
-rw-r--r--generic/tclResult.c14
-rw-r--r--generic/tclTrace.c6
6 files changed, 51 insertions, 61 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6401e73..ea3e03c 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.119 2004/09/27 22:39:20 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.120 2004/09/30 23:06:47 dgp Exp $
*/
#include "tclInt.h"
@@ -4529,20 +4529,6 @@ Tcl_AddObjErrorInfo(interp, message, length)
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
}
-
- /*
- * If the errorCode variable wasn't set by the code that generated
- * the error, set it to "NONE".
- *
- * NOTE: The main check for setting the default value of
- * errorCode to NONE is in Tcl_LogCommandInfo. This one
- * should go away, but currently it's taking care of setting
- * up errorCode after compile errors.
- */
-
- if (!(iPtr->flags & ERROR_CODE_SET)) {
- Tcl_SetErrorCode(interp, "NONE", NULL);
- }
}
/*
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index b1c1177..1af7958 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.49 2004/09/27 19:59:36 kennykb Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.50 2004/09/30 23:06:47 dgp Exp $
*/
#include "tclInt.h"
@@ -623,8 +623,10 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv)
if (objc == 4) {
Tcl_SetObjErrorCode(interp, objv[3]);
+ } else {
+ Tcl_SetErrorCode(interp, "NONE", NULL);
}
-
+
Tcl_SetObjResult(interp, objv[1]);
return TCL_ERROR;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 93eda56..2a41a1b 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.107 2004/09/22 22:23:39 dgp Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.108 2004/09/30 23:06:48 dgp Exp $
*/
#include "tclInt.h"
@@ -920,6 +920,8 @@ TclProcessReturn(interp, code, level, returnOpts)
iPtr->returnErrorcodeKey, &valuePtr);
if (valuePtr != NULL) {
Tcl_SetObjErrorCode(interp, valuePtr);
+ } else {
+ Tcl_SetErrorCode(interp, "NONE", NULL);
}
valuePtr = NULL;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 9238001..9c7e7c2 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -21,7 +21,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.56 2004/09/29 22:17:30 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.57 2004/09/30 23:06:48 dgp Exp $
*/
#include "tclInt.h"
@@ -860,45 +860,37 @@ TclTeardownNamespace(nsPtr)
if (nsPtr == globalNsPtr) {
/*
- * This is the global namespace, so be careful to preserve the
- * "errorInfo" and "errorCode" variables. These might be needed
- * later on if errors occur while deleting commands. We are careful
- * to destroy and recreate the "errorInfo" and "errorCode"
- * variables, in case they had any traces on them.
+ * This is the global namespace. Tearing it down will destroy the
+ * ::errorInfo and ::errorCode variables. We save and restore them
+ * in case there are any errors in progress, so the error details
+ * they contain will not be lost. See test namespace-8.5
*/
- CONST char *str;
- char *errorInfoStr, *errorCodeStr;
-
- str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorInfo", TCL_GLOBAL_ONLY);
- if (str != NULL) {
- errorInfoStr = ckalloc((unsigned) (strlen(str)+1));
- strcpy(errorInfoStr, str);
- } else {
- errorInfoStr = NULL;
- }
-
- str = Tcl_GetVar((Tcl_Interp *) iPtr, "errorCode", TCL_GLOBAL_ONLY);
- if (str != NULL) {
- errorCodeStr = ckalloc((unsigned) (strlen(str)+1));
- strcpy(errorCodeStr, str);
- } else {
- errorCodeStr = NULL;
- }
-
- TclDeleteVars(iPtr, &nsPtr->varTable);
- Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
+ Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
+ NULL, TCL_GLOBAL_ONLY);
+ Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
+ NULL, TCL_GLOBAL_ONLY);
+
+ if (errorInfo) {
+ Tcl_IncrRefCount(errorInfo);
+ }
+ if (errorCode) {
+ Tcl_IncrRefCount(errorCode);
+ }
- if (errorInfoStr != NULL) {
- Tcl_SetVar((Tcl_Interp *) iPtr, "errorInfo", errorInfoStr,
- TCL_GLOBAL_ONLY);
- ckfree(errorInfoStr);
- }
- if (errorCodeStr != NULL) {
- Tcl_SetVar((Tcl_Interp *) iPtr, "errorCode", errorCodeStr,
- TCL_GLOBAL_ONLY);
- ckfree(errorCodeStr);
- }
+ TclDeleteVars(iPtr, &nsPtr->varTable);
+ Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
+
+ if (errorInfo) {
+ Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL,
+ errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_DecrRefCount(errorInfo);
+ }
+ if (errorCode) {
+ Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
+ errorCode, TCL_GLOBAL_ONLY);
+ Tcl_DecrRefCount(errorCode);
+ }
} else {
/*
* Variable table should be cleared but not freed! TclDeleteVars
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 7c15182..9e83796 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.10 2004/09/29 22:17:30 dkf Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.11 2004/09/30 23:06:48 dgp Exp $
*/
#include "tclInt.h"
@@ -1027,13 +1027,17 @@ TclTransferResult(sourceInterp, result, targetInterp)
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
- Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
- TCL_GLOBAL_ONLY);
- ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
+ if (objPtr) {
+ Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
+ TCL_GLOBAL_ONLY);
+ ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
+ }
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
- Tcl_SetObjErrorCode(targetInterp, objPtr);
+ if (objPtr) {
+ Tcl_SetObjErrorCode(targetInterp, objPtr);
+ }
}
/* This may need examination for safety */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index dd0ee44..25dad45 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.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: tclTrace.c,v 1.11 2004/08/02 20:55:38 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.12 2004/09/30 23:06:49 dgp Exp $
*/
#include "tclInt.h"
@@ -2450,6 +2450,7 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
int copiedName;
int code = TCL_OK;
int disposeFlags = 0;
+ int saveErrFlags = iPtr->flags;
/*
* If there are already similar trace procedures active for the
@@ -2572,6 +2573,9 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
*/
done:
+ if (code == TCL_OK) {
+ iPtr->flags = saveErrFlags;
+ }
if (code == TCL_ERROR) {
if (leaveErrMsg) {
CONST char *type = "";
generated by cgit v0.12 at 2024-07-21 06:10:03 (GMT)