summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-10-24 22:25:11 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-10-24 22:25:11 (GMT)
commitc004a438e6863bc246919f6b40881f03e239c002 (patch)
tree21213c2618cd45d0eddb66c89f849d0f99dbb346 /generic
parent69969158b567bccb48c4a08baee34e4eb2004153 (diff)
downloadtcl-c004a438e6863bc246919f6b40881f03e239c002.zip
tcl-c004a438e6863bc246919f6b40881f03e239c002.tar.gz
tcl-c004a438e6863bc246919f6b40881f03e239c002.tar.bz2
* generic/tclBasic.c (Tcl_LogCommandInfo,Tcl_AddObjErrorInfo):
Shift the initialization of errorCode to NONE to more central location. * generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors): Rewrite to build on the new TclGet/SetReturnOptions routines. * generic/tclResult.c (TclGetReturnOptions): Add call to Tcl_AddObjErrorInfo to be sure error fields are initialized. * generic/tclResult.c (TclTransferResult): Rewrite to build on the new TclGet/SetReturnOptions routines.
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c8
-rw-r--r--generic/tclEvent.c65
-rw-r--r--generic/tclResult.c43
3 files changed, 38 insertions, 78 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b37e20d..0102390 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.132 2004/10/21 17:07:31 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.133 2004/10/24 22:25:12 dgp Exp $
*/
#include "tclInt.h"
@@ -3251,9 +3251,6 @@ Tcl_LogCommandInfo(interp, script, command, length)
Tcl_AppendToObj(message, "\"", -1);
TclAppendObjToErrorInfo(interp, message);
Tcl_DecrRefCount(message);
- if (!iPtr->errorCode) {
- Tcl_SetErrorCode(interp, "NONE", NULL);
- }
}
/*
@@ -4425,6 +4422,9 @@ Tcl_AddObjErrorInfo(interp, message, length)
iPtr->errorInfo = iPtr->objResultPtr;
}
Tcl_IncrRefCount(iPtr->errorInfo);
+ if (!iPtr->errorCode) {
+ Tcl_SetErrorCode(interp, "NONE", NULL);
+ }
}
/*
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 9eb195f..108ecf3 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -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: tclEvent.c,v 1.49 2004/10/19 21:54:06 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.50 2004/10/24 22:25:12 dgp Exp $
*/
#include "tclInt.h"
@@ -27,8 +27,8 @@
typedef struct BgError {
Tcl_Obj *errorMsg; /* Copy of the error message (the interp's
* result when the error occurred). */
- Tcl_Obj *errorInfo; /* Value of the errorInfo variable */
- Tcl_Obj *errorCode; /* Value of the errorCode variable */
+ Tcl_Obj *returnOpts; /* Active return options when the
+ * error occurred */
struct BgError *nextPtr; /* Next in list of all pending error
* reports for this interpreter, or NULL
* for end of list. */
@@ -156,32 +156,12 @@ Tcl_BackgroundError(interp)
{
BgError *errPtr;
ErrAssocData *assocPtr;
- Interp *iPtr = (Interp *) interp;
errPtr = (BgError *) ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
-
- /*
- * The Tcl_AddErrorInfo call below (with an empty string) ensures that
- * errorInfo gets properly set. It's needed in cases where the error
- * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
- * in these cases errorInfo still won't have been set when this
- * procedure is called.
- */
-
- Tcl_AddErrorInfo(interp, "");
- errPtr->errorInfo = iPtr->errorInfo;
- Tcl_IncrRefCount(errPtr->errorInfo);
-
- if (iPtr->errorCode) {
- errPtr->errorCode = iPtr->errorCode;
- } else {
- /* Does this ever happen ? */
- errPtr->errorCode = Tcl_NewObj();
- }
- Tcl_IncrRefCount(errPtr->errorCode);
-
+ errPtr->returnOpts = TclGetReturnOptions(interp, TCL_ERROR);
+ Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
@@ -251,7 +231,7 @@ HandleBgErrors(clientData)
Tcl_Preserve((ClientData) interp);
while (assocPtr->firstBgPtr != NULL) {
int code;
- Interp *iPtr = (Interp *)interp;
+ Tcl_Obj *keyPtr, *valuePtr;
errPtr = assocPtr->firstBgPtr;
/*
@@ -263,10 +243,22 @@ HandleBgErrors(clientData)
* anything we write to the interp fields.
*/
- Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
- errPtr->errorInfo, TCL_GLOBAL_ONLY);
- Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
- errPtr->errorCode, TCL_GLOBAL_ONLY);
+ keyPtr = Tcl_NewStringObj("-errorcode", -1);
+ Tcl_IncrRefCount(keyPtr);
+ Tcl_DictObjGet(NULL, errPtr->returnOpts, keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (valuePtr) {
+ Tcl_SetVar2Ex(interp, "errorCode", NULL,
+ valuePtr, TCL_GLOBAL_ONLY);
+ }
+ keyPtr = Tcl_NewStringObj("-errorinfo", -1);
+ Tcl_IncrRefCount(keyPtr);
+ Tcl_DictObjGet(NULL, errPtr->returnOpts, keyPtr, &valuePtr);
+ Tcl_DecrRefCount(keyPtr);
+ if (valuePtr) {
+ Tcl_SetVar2Ex(interp, "errorInfo", NULL,
+ valuePtr, TCL_GLOBAL_ONLY);
+ }
/*
* Create and invoke the bgerror command.
@@ -308,7 +300,9 @@ HandleBgErrors(clientData)
Tcl_IncrRefCount(resultPtr);
if (Tcl_FindCommand(interp, "bgerror",
NULL, TCL_GLOBAL_ONLY) == NULL) {
- Tcl_WriteObj(errChannel, errPtr->errorInfo);
+ if (valuePtr) {
+ Tcl_WriteObj(errChannel, valuePtr);
+ }
Tcl_WriteChars(errChannel, "\n", -1);
} else {
Tcl_WriteChars(errChannel,
@@ -334,8 +328,7 @@ HandleBgErrors(clientData)
Tcl_DecrRefCount(objv[1]);
Tcl_DecrRefCount(errPtr->errorMsg);
- Tcl_DecrRefCount(errPtr->errorInfo);
- Tcl_DecrRefCount(errPtr->errorCode);
+ Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
ckfree((char *) errPtr);
@@ -354,8 +347,7 @@ HandleBgErrors(clientData)
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
- Tcl_DecrRefCount(errPtr->errorInfo);
- Tcl_DecrRefCount(errPtr->errorCode);
+ Tcl_DecrRefCount(errPtr->returnOpts);
ckfree((char *) errPtr);
}
@@ -398,8 +390,7 @@ BgErrorDeleteProc(clientData, interp)
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
- Tcl_DecrRefCount(errPtr->errorInfo);
- Tcl_DecrRefCount(errPtr->errorCode);
+ Tcl_DecrRefCount(errPtr->returnOpts);
ckfree((char *) errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 460ccaa..226af65 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.19 2004/10/21 17:07:32 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.20 2004/10/24 22:25:13 dgp Exp $
*/
#include "tclInt.h"
@@ -1410,6 +1410,7 @@ TclGetReturnOptions(interp, result)
* When result was an error, fill in any missing values
* for -errorinfo, -errorcode, and -errorline
*/
+ Tcl_AddObjErrorInfo(interp, "", -1);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORCODE], iPtr->errorCode);
Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
@@ -1505,47 +1506,15 @@ TclTransferResult(sourceInterp, result, targetInterp)
* should be stored. If source and target
* are the same, nothing is done. */
{
- Interp *siPtr = (Interp *) sourceInterp;
- Interp *tiPtr = (Interp *) targetInterp;
+ Interp *iPtr = (Interp *) targetInterp;
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.
- */
-
- if ((siPtr->flags & ERR_ALREADY_LOGGED) == 0) {
- Tcl_AddErrorInfo(sourceInterp, "");
- }
- siPtr->flags &= ~(ERR_ALREADY_LOGGED);
-
- Tcl_ResetResult(targetInterp);
-
- if (siPtr->errorInfo) {
- tiPtr->errorInfo = siPtr->errorInfo;
- Tcl_IncrRefCount(tiPtr->errorInfo);
- }
-
- if (siPtr->errorCode) {
- Tcl_SetObjErrorCode(targetInterp, siPtr->errorCode);
- }
- }
-
- /* This may need examination for safety */
- if (tiPtr->returnOpts ) {
- Tcl_DecrRefCount(tiPtr->returnOpts );
- }
- tiPtr->returnOpts = siPtr->returnOpts;
- if (tiPtr->returnOpts ) {
- Tcl_IncrRefCount(tiPtr->returnOpts );
- }
-
+ TclSetReturnOptions(targetInterp,
+ TclGetReturnOptions(sourceInterp, result));
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}