diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rw-r--r-- | generic/tclBasic.c | 8 | ||||
| -rw-r--r-- | generic/tclEvent.c | 65 | ||||
| -rw-r--r-- | generic/tclResult.c | 43 |
4 files changed, 53 insertions, 78 deletions
@@ -1,3 +1,18 @@ +2004-10-24 Don Porter <dgp@users.sourceforge.net> + + * 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. + 2004-10-22 Donal K. Fellows <donal.k.fellows@man.ac.uk> * doc/tm.n: Tightened up the documentation. 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); } |