summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog34
-rw-r--r--generic/tclBasic.c106
-rw-r--r--generic/tclCmdAH.c14
-rw-r--r--generic/tclCmdMZ.c5
-rw-r--r--generic/tclEvent.c189
-rw-r--r--generic/tclExecute.c19
-rw-r--r--generic/tclIOUtil.c12
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclInterp.c8
-rw-r--r--generic/tclMain.c5
-rw-r--r--generic/tclNamesp.c154
-rw-r--r--generic/tclProc.c11
-rw-r--r--generic/tclResult.c58
-rw-r--r--generic/tclTrace.c26
14 files changed, 372 insertions, 282 deletions
diff --git a/ChangeLog b/ChangeLog
index 0e5e72b..1d49934 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,35 @@
+2004-10-15 Don Porter <dgp@users.sourceforge.net>
+
+ * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp,
+ TclEvalObjvInternal,Tcl_LogCommandInfo,TclAddObjErrorInfo):
+ * generic/tclCmdAH.c (Tcl_CatchObjCmd):
+ * generic/tclEvent.c (BgError,ErrAssocData,Tcl_BackgroundError,
+ HandleBgErrors,BgErrorDeleteProc):
+ * generic/tclExecute.c (TclCreateExecEnv,TclDeleteExecEnv):
+ * generic/tclIOUtil.c (comments only):
+ * generic/tclInt.h (ExecEnv,Interp, ERR_IN_PROGRESS):
+ * generic/tclInterp.c ([tclInit]):
+ * generic/tclMain.c (comments only):
+ * generic/tclNamesp.c
+ (Tcl_CreateNamespace,Tcl_DeleteNamespace,TclTeardownNamespace):
+ * generic/tclProc.c (TclUpdateReturnInfo):
+ * generic/tclResult.c
+ (Tcl_ResetResult,TclTransferResult):
+ * generic/tclTrace.c (CallVarTraces):
+ Reworked management of the "errorInfo" data of an interp.
+ That information is now primarily stored in a new private
+ (Tcl_Obj *) field of the Interp struct, rather than using a
+ global variable ::errorInfo as the primary storage. The
+ ERR_IN_PROGRESS flag bit value is no longer required to manage
+ the value in its new location, and is removed. Variable traces
+ are established to support compatibility for any code expecting
+ the ::errorInfo variable to hold the information.
+
+ ***POTENTIAL INCOMPATIBILITY***
+ Code that sets traces on the ::errorInfo variable may notice a
+ difference in timing of the firing of those traces. Code that
+ uses the value ERR_IN_PROGRESS.
+
2004-10-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
TIP#217 IMPLEMENTATION
@@ -165,7 +197,7 @@
the ::errorCode variable to hold the information.
***POTENTIAL INCOMPATIBILITY***
- Code that sets traces on the ::errorCode value may notice a
+ Code that sets traces on the ::errorCode variable may notice a
difference in timing of the firing of those traces.
* generic/tclNamesp.c (Tcl_PopCallFrame): Removed Bug 1038021
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5e410d4..8891f52 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.125 2004/10/06 00:24:16 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.126 2004/10/15 04:01:27 dgp Exp $
*/
#include "tclInt.h"
@@ -241,7 +241,12 @@ Tcl_CreateInterp()
Tcl_IncrRefCount(iPtr->defaultReturnOpts);
iPtr->returnOpts = iPtr->defaultReturnOpts;
Tcl_IncrRefCount(iPtr->returnOpts);
+ iPtr->errorInfo = NULL;
+ iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1);
+ Tcl_IncrRefCount(iPtr->eiVar);
iPtr->errorCode = NULL;
+ iPtr->ecVar = Tcl_NewStringObj("errorCode", -1);
+ Tcl_IncrRefCount(iPtr->ecVar);
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
@@ -894,10 +899,6 @@ DeleteInterpProc(interp)
TclLimitRemoveAllHandlers(interp);
/*
- * Dismantle everything in the global namespace except for the
- * "errorInfo" and "errorCode" variables. These remain until the
- * namespace is actually destroyed, in case any errors occur.
- *
* Dismantle the namespace here, before we clear the assocData. If any
* background errors occur here, they will be deleted below.
*
@@ -982,10 +983,16 @@ DeleteInterpProc(interp)
interp->result = NULL;
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
+ Tcl_DecrRefCount(iPtr->ecVar);
if (iPtr->errorCode) {
Tcl_DecrRefCount(iPtr->errorCode);
iPtr->errorCode = NULL;
}
+ Tcl_DecrRefCount(iPtr->eiVar);
+ if (iPtr->errorInfo) {
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ iPtr->errorInfo = NULL;
+ }
Tcl_DecrRefCount(iPtr->returnOpts);
Tcl_DecrRefCount(iPtr->defaultReturnOpts);
Tcl_DecrRefCount(iPtr->returnCodeKey);
@@ -3057,10 +3064,13 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
* Call 'leave' command traces
*/
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
- int saveErrFlags = iPtr->flags
- & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED);
+ int saveErrFlags = iPtr->flags & ERR_ALREADY_LOGGED;
Tcl_Obj *saveOptions = iPtr->returnOpts;
+ Tcl_Obj *saveErrInfo = iPtr->errorInfo;
Tcl_Obj *saveErrCode = iPtr->errorCode;
+ if (saveErrInfo) {
+ Tcl_IncrRefCount(saveErrInfo);
+ }
if (saveErrCode) {
Tcl_IncrRefCount(saveErrCode);
}
@@ -3082,8 +3092,17 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
Tcl_DecrRefCount(iPtr->errorCode);
}
iPtr->errorCode = saveErrCode;
- } else if (saveErrCode) {
- Tcl_DecrRefCount(saveErrCode);
+ if (iPtr->errorInfo) {
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ }
+ iPtr->errorInfo = saveErrInfo;
+ } else {
+ if (saveErrCode) {
+ Tcl_DecrRefCount(saveErrCode);
+ }
+ if (saveErrInfo) {
+ Tcl_DecrRefCount(saveErrInfo);
+ }
}
Tcl_DecrRefCount(saveOptions);
}
@@ -3227,7 +3246,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
* Tcl_LogCommandInfo --
*
* This procedure is invoked after an error occurs in an interpreter.
- * It adds information to the "errorInfo" variable to describe the
+ * It adds information to iPtr->errorInfo field to describe the
* command that was being executed when the error occurred.
*
* Results:
@@ -3235,10 +3254,7 @@ Tcl_EvalObjv(interp, objc, objv, flags)
*
* Side effects:
* Information about the command is added to errorInfo and the
- * line number stored internally in the interpreter is set. If this
- * is the first call to this procedure or Tcl_AddObjErrorInfo since
- * an error occurred, then old information in errorInfo is
- * deleted.
+ * line number stored internally in the interpreter is set.
*
*----------------------------------------------------------------------
*/
@@ -3277,7 +3293,7 @@ Tcl_LogCommandInfo(interp, script, command, length)
}
}
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
+ if (iPtr->errorInfo == NULL) {
message = Tcl_NewStringObj("\n while executing\n\"", -1);
} else {
message = Tcl_NewStringObj("\n invoked from within\n\"", -1);
@@ -3602,12 +3618,7 @@ Tcl_EvalEx(interp, script, numBytes, flags)
return TCL_OK;
error:
- /*
- * Generate various pieces of error information, such as the line
- * number where the error occurred and information to add to the
- * errorInfo variable. Then free resources that had been allocated
- * to the command.
- */
+ /* Generate and log various pieces of error information. */
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
commandLength = parse.commandSize;
@@ -3625,6 +3636,8 @@ Tcl_EvalEx(interp, script, numBytes, flags)
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
+ /* Then free resources that had been allocated to the command. */
+
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
@@ -4359,16 +4372,14 @@ Tcl_ExprString(interp, string)
*
* TclAppendObjToErrorInfo --
*
- * Add a Tcl_Obj value to the "errorInfo" variable that describes the
+ * Add a Tcl_Obj value to the errorInfo field that describes the
* current error.
*
* Results:
* None.
*
* Side effects:
- * The value of the Tcl_obj is added to the "errorInfo" variable.
- * If Tcl_Eval has been called since the current value of errorInfo
- * was set, errorInfo is cleared before adding the new message.
+ * The value of the Tcl_obj is appended to the errorInfo field.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
@@ -4391,16 +4402,14 @@ TclAppendObjToErrorInfo(interp, objPtr)
*
* Tcl_AddErrorInfo --
*
- * Add information to the "errorInfo" variable that describes the
+ * Add information to the errorInfo field that describes the
* current error.
*
* Results:
* None.
*
* Side effects:
- * The contents of message are added to the "errorInfo" variable.
- * If Tcl_Eval has been called since the current value of errorInfo
- * was set, errorInfo is cleared before adding the new message.
+ * The contents of message are appended to the errorInfo field.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
@@ -4421,7 +4430,7 @@ Tcl_AddErrorInfo(interp, message)
*
* Tcl_AddObjErrorInfo --
*
- * Add information to the "errorInfo" variable that describes the
+ * Add information to the errorInfo field that describes the
* current error. This routine differs from Tcl_AddErrorInfo by
* taking a byte pointer and length.
*
@@ -4429,10 +4438,8 @@ Tcl_AddErrorInfo(interp, message)
* None.
*
* Side effects:
- * "length" bytes from "message" are added to the "errorInfo" variable.
+ * "length" bytes from "message" are appended to the errorInfo field.
* If "length" is negative, use bytes up to the first NULL byte.
- * If Tcl_EvalObj has been called since the current value of errorInfo
- * was set, errorInfo is cleared before adding the new message.
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*
@@ -4457,16 +4464,20 @@ Tcl_AddObjErrorInfo(interp, message, length)
* from the error message in the interpreter's result.
*/
- if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
- iPtr->flags |= ERR_IN_PROGRESS;
-
- if (iPtr->result[0] == 0) {
- Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
- iPtr->objResultPtr, TCL_GLOBAL_ONLY);
- } else { /* use the string result */
- Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
- Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
+ if (iPtr->errorInfo == NULL) { /* just starting to log error */
+ if (iPtr->result[0] != 0) {
+ /*
+ * The interp's string result is set, apparently by some
+ * extension making a deprecated direct write to it.
+ * That extension may expect interp->result to continue
+ * to be set, so we'll take special pains to avoid clearing
+ * it, until we drop support for interp->result completely.
+ */
+ iPtr->errorInfo = Tcl_NewStringObj(interp->result, -1);
+ } else {
+ iPtr->errorInfo = iPtr->objResultPtr;
}
+ Tcl_IncrRefCount(iPtr->errorInfo);
}
/*
@@ -4474,11 +4485,12 @@ Tcl_AddObjErrorInfo(interp, message, length)
*/
if (length != 0) {
- messagePtr = Tcl_NewStringObj(message, length);
- Tcl_IncrRefCount(messagePtr);
- Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
- messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
- Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
+ if (Tcl_IsShared(iPtr->errorInfo)) {
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo);
+ Tcl_IncrRefCount(iPtr->errorInfo);
+ }
+ Tcl_AppendToObj(iPtr->errorInfo, message, length);
}
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 05bf91a..960b039 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.53 2004/10/06 09:07:12 dkf Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.54 2004/10/15 04:01:28 dgp Exp $
*/
#include "tclInt.h"
@@ -280,17 +280,19 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
iPtr->returnLevelKey, Tcl_NewIntObj(0));
}
- if (iPtr->flags & ERR_IN_PROGRESS) {
+ if (result == TCL_ERROR) {
+ /*
+ * When result was an error, fill in any missing values
+ * for -errorinfo, -errorcode, and -errorline
+ */
+
value = NULL;
Tcl_DictObjGet(NULL, options, iPtr->returnErrorinfoKey, &value);
if (NULL == value) {
Tcl_DictObjPut(NULL, options, iPtr->returnErrorinfoKey,
- Tcl_ObjGetVar2(interp, iPtr->execEnvPtr->errorInfo,
- NULL, TCL_GLOBAL_ONLY));
+ iPtr->errorInfo);
}
- }
- if (result == TCL_ERROR) {
value = NULL;
Tcl_DictObjGet(NULL, options, iPtr->returnErrorcodeKey, &value);
if (NULL == value) {
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2c8b8a7..a408db6 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.111 2004/10/06 09:44:11 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.112 2004/10/15 04:01:28 dgp Exp $
*/
#include "tclInt.h"
@@ -880,8 +880,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv)
* Returns the return code the [return] command should return.
*
* Side effects:
- * When the return code is TCL_ERROR, the values of ::errorInfo
- * and ::errorCode may be updated.
+ * None.
*
*----------------------------------------------------------------------
*/
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 5a38ad7..5ef1533 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.47 2004/10/05 18:14:27 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.48 2004/10/15 04:01:29 dgp Exp $
*/
#include "tclInt.h"
@@ -25,16 +25,10 @@
*/
typedef struct BgError {
- Tcl_Interp *interp; /* Interpreter in which error occurred. NULL
- * means this error report has been cancelled
- * (a previous report generated a break). */
- char *errorMsg; /* Copy of the error message (the interp's
- * result when the error occurred).
- * Malloc-ed. */
- char *errorInfo; /* Value of the errorInfo variable
- * (malloc-ed). */
- Tcl_Obj *errorCode; /* Value of the errorCode variable
- * (malloc-ed). */
+ 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 */
struct BgError *nextPtr; /* Next in list of all pending error
* reports for this interpreter, or NULL
* for end of list. */
@@ -47,6 +41,7 @@ typedef struct BgError {
*/
typedef struct ErrAssocData {
+ Tcl_Interp *interp; /* Interpreter in which error occurred. */
BgError *firstBgPtr; /* First in list of all background errors
* waiting to be processed for this
* interpreter (NULL if none). */
@@ -160,11 +155,13 @@ Tcl_BackgroundError(interp)
* occurred. */
{
BgError *errPtr;
- CONST char *errResult, *varValue;
ErrAssocData *assocPtr;
- int length;
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
@@ -174,19 +171,8 @@ Tcl_BackgroundError(interp)
*/
Tcl_AddErrorInfo(interp, "");
-
- errResult = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
-
- errPtr = (BgError *) ckalloc(sizeof(BgError));
- errPtr->interp = interp;
- errPtr->errorMsg = (char *) ckalloc((unsigned) (length + 1));
- memcpy(errPtr->errorMsg, errResult, (size_t) (length + 1));
- varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
- if (varValue == NULL) {
- varValue = errPtr->errorMsg;
- }
- errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
- strcpy(errPtr->errorInfo, varValue);
+ errPtr->errorInfo = iPtr->errorInfo;
+ Tcl_IncrRefCount(errPtr->errorInfo);
if (iPtr->errorCode) {
errPtr->errorCode = iPtr->errorCode;
@@ -209,6 +195,7 @@ Tcl_BackgroundError(interp)
*/
assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+ assocPtr->interp = interp;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
@@ -245,43 +232,50 @@ static void
HandleBgErrors(clientData)
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
- Tcl_Interp *interp;
- int code;
- BgError *errPtr;
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
- Tcl_Channel errChannel;
+ Tcl_Interp *interp = assocPtr->interp;
+ BgError *errPtr;
Tcl_Obj *objv[2];
+ /*
+ * Not bothering to save/restore the interp state. Assume that
+ * any code that has interp state it needs to keep will make
+ * its own Tcl_SaveResult call before calling something like
+ * Tcl_DoOneEvent() that could lead us here.
+ */
+
objv[0] = Tcl_NewStringObj("bgerror", -1);
Tcl_IncrRefCount(objv[0]);
- objv[1] = NULL;
Tcl_Preserve((ClientData) assocPtr);
+ Tcl_Preserve((ClientData) interp);
while (assocPtr->firstBgPtr != NULL) {
- interp = assocPtr->firstBgPtr->interp;
- if (interp == NULL) {
- goto doneWithInterp;
- }
+ int code;
+ Interp *iPtr = (Interp *)interp;
+ errPtr = assocPtr->firstBgPtr;
/*
* Restore important state variables to what they were at
* the time the error occurred.
+ *
+ * Need to set the variables, not the interp fields, because
+ * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy
+ * anything we write to the interp fields.
*/
- Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
- TCL_GLOBAL_ONLY);
- Tcl_SetVar2Ex(interp, "errorCode", NULL,
- assocPtr->firstBgPtr->errorCode, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
+ errPtr->errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
+ errPtr->errorCode, TCL_GLOBAL_ONLY);
/*
* Create and invoke the bgerror command.
*/
- objv[1] = Tcl_NewStringObj(assocPtr->firstBgPtr->errorMsg, -1);
+ objv[1] = errPtr->errorMsg;
Tcl_IncrRefCount(objv[1]);
Tcl_AllowExceptions(interp);
- Tcl_Preserve((ClientData) interp);
code = Tcl_EvalObjv(interp, 2, objv, TCL_EVAL_GLOBAL);
if (code == TCL_ERROR) {
@@ -302,49 +296,37 @@ HandleBgErrors(clientData)
Tcl_SaveResult(interp, &save);
TclObjInvoke(interp, 2, objv, TCL_INVOKE_HIDDEN);
Tcl_RestoreResult(interp, &save);
+ } else {
- goto doneWithInterp;
- }
-
- /*
- * We have to get the error output channel at the latest possible
- * time, because the eval (above) might have changed the channel.
- */
+ /*
+ * We have to get the error output channel at the latest
+ * possible time, because the eval (above) might have
+ * changed the channel.
+ */
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel != (Tcl_Channel) NULL) {
- char *string;
- int len;
-
- string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
- if (Tcl_FindCommand(interp, "bgerror", NULL, TCL_GLOBAL_ONLY) == NULL) {
- Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
- Tcl_WriteChars(errChannel, "\n", -1);
- } else {
- Tcl_WriteChars(errChannel,
- "bgerror failed to handle background error.\n",
- -1);
- Tcl_WriteChars(errChannel, " Original error: ", -1);
- Tcl_WriteChars(errChannel, assocPtr->firstBgPtr->errorMsg,
- -1);
- Tcl_WriteChars(errChannel, "\n", -1);
- Tcl_WriteChars(errChannel, " Error in bgerror: ", -1);
- Tcl_WriteChars(errChannel, string, len);
- Tcl_WriteChars(errChannel, "\n", -1);
- }
- Tcl_Flush(errChannel);
- }
- } else if (code == TCL_BREAK) {
-
- /*
- * Break means cancel any remaining error reports for this
- * interpreter.
- */
-
- for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
- errPtr = errPtr->nextPtr) {
- if (errPtr->interp == interp) {
- errPtr->interp = NULL;
+ Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+ if (errChannel != (Tcl_Channel) NULL) {
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+
+ Tcl_IncrRefCount(resultPtr);
+ if (Tcl_FindCommand(interp, "bgerror",
+ NULL, TCL_GLOBAL_ONLY) == NULL) {
+ Tcl_WriteObj(errChannel, errPtr->errorInfo);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ } else {
+ Tcl_WriteChars(errChannel,
+ "bgerror failed to handle background error.\n",
+ -1);
+ Tcl_WriteChars(errChannel, " Original error: ", -1);
+ Tcl_WriteObj(errChannel, errPtr->errorMsg);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ Tcl_WriteChars(errChannel,
+ " Error in bgerror: ", -1);
+ Tcl_WriteObj(errChannel, resultPtr);
+ Tcl_WriteChars(errChannel, "\n", -1);
+ }
+ Tcl_DecrRefCount(resultPtr);
+ Tcl_Flush(errChannel);
}
}
}
@@ -353,28 +335,37 @@ HandleBgErrors(clientData)
* Discard the command and the information about the error report.
*/
-doneWithInterp:
- if (objv[1]) {
- Tcl_DecrRefCount(objv[1]);
- objv[1] = NULL;
- }
+ Tcl_DecrRefCount(objv[1]);
+ Tcl_DecrRefCount(errPtr->errorMsg);
+ Tcl_DecrRefCount(errPtr->errorInfo);
+ Tcl_DecrRefCount(errPtr->errorCode);
+ assocPtr->firstBgPtr = errPtr->nextPtr;
+ ckfree((char *) errPtr);
- if (assocPtr->firstBgPtr) {
- ckfree(assocPtr->firstBgPtr->errorMsg);
- ckfree(assocPtr->firstBgPtr->errorInfo);
- Tcl_DecrRefCount(assocPtr->firstBgPtr->errorCode);
- errPtr = assocPtr->firstBgPtr->nextPtr;
- ckfree((char *) assocPtr->firstBgPtr);
- assocPtr->firstBgPtr = errPtr;
+ if (code == TCL_BREAK) {
+ /*
+ * Break means cancel any remaining error reports for this
+ * interpreter.
+ */
+ break;
}
- if (interp != NULL) {
- Tcl_Release((ClientData) interp);
- }
}
+
+ /* Cleanup any error reports we didn't do (due to a TCL_BREAK) */
+ while (assocPtr->firstBgPtr != NULL) {
+ errPtr = assocPtr->firstBgPtr;
+ assocPtr->firstBgPtr = errPtr->nextPtr;
+ Tcl_DecrRefCount(errPtr->errorMsg);
+ Tcl_DecrRefCount(errPtr->errorInfo);
+ Tcl_DecrRefCount(errPtr->errorCode);
+ ckfree((char *) errPtr);
+ }
+
assocPtr->lastBgPtr = NULL;
Tcl_DecrRefCount(objv[0]);
+ Tcl_Release((ClientData) interp);
Tcl_Release((ClientData) assocPtr);
}
@@ -409,8 +400,8 @@ BgErrorDeleteProc(clientData, interp)
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
- ckfree(errPtr->errorMsg);
- ckfree(errPtr->errorInfo);
+ Tcl_DecrRefCount(errPtr->errorMsg);
+ Tcl_DecrRefCount(errPtr->errorInfo);
Tcl_DecrRefCount(errPtr->errorCode);
ckfree((char *) errPtr);
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 60b9344..b59389b 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.156 2004/10/08 15:39:53 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.157 2004/10/15 04:01:29 dgp Exp $
*/
#ifdef STDC_HEADERS
@@ -527,12 +527,6 @@ TclCreateExecEnv(interp)
eePtr->tosPtr = stackPtr - 1;
eePtr->endPtr = stackPtr + (TCL_STACK_INITIAL_SIZE - 2);
- eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
- Tcl_IncrRefCount(eePtr->errorInfo);
-
- eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
- Tcl_IncrRefCount(eePtr->errorCode);
-
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
TclInitAuxDataTypeTable();
@@ -571,8 +565,6 @@ TclDeleteExecEnv(eePtr)
} else {
Tcl_Panic("ERROR: freeing an execEnv whose stack is still in use.\n");
}
- TclDecrRefCount(eePtr->errorInfo);
- TclDecrRefCount(eePtr->errorCode);
ckfree((char *) eePtr);
}
@@ -5142,15 +5134,16 @@ ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, checkStack)
*
* IllegalExprOperandType --
*
- * Used by TclExecuteByteCode to add an error message to errorInfo
- * when an illegal operand type is detected by an expression
- * instruction. The argument opndPtr holds the operand object in error.
+ * Used by TclExecuteByteCode to append an error message to
+ * the interp result when an illegal operand type is detected by an
+ * expression instruction. The argument opndPtr holds the operand
+ * object in error.
*
* Results:
* None.
*
* Side effects:
- * An error message is appended to errorInfo.
+ * An error message is appended to the interp result.
*
*----------------------------------------------------------------------
*/
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 0f31689..befc9c7 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.111 2004/10/07 14:50:22 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.112 2004/10/15 04:01:31 dgp Exp $
*/
#include "tclInt.h"
@@ -1783,23 +1783,23 @@ Tcl_SetErrno(err)
*
* This procedure is typically called after UNIX kernel calls
* return errors. It stores machine-readable information about
- * the error in $errorCode returns an information string for
- * the caller's use.
+ * the error in errorCode field of interp and returns an
+ * information string for the caller's use.
*
* Results:
* The return value is a human-readable string describing the
* error.
*
* Side effects:
- * The global variable $errorCode is reset.
+ * The errorCode field of the interp is set.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_PosixError(interp)
- Tcl_Interp *interp; /* Interpreter whose $errorCode variable
- * is to be changed. */
+ Tcl_Interp *interp; /* Interpreter whose errorCode field
+ * is to be set. */
{
CONST char *id, *msg;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c97e727..f513b19 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.180 2004/10/05 18:14:27 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.181 2004/10/15 04:01:31 dgp Exp $
*/
#ifndef _TCLINT
@@ -888,8 +888,6 @@ typedef struct ExecEnv {
Tcl_Obj **tosPtr; /* Points to current top of stack;
* (stackPtr-1) when the stack is empty. */
Tcl_Obj **endPtr; /* Points to last usable item in stack. */
- Tcl_Obj *errorInfo;
- Tcl_Obj *errorCode;
} ExecEnv;
/*
@@ -1332,7 +1330,10 @@ typedef struct Interp {
Tcl_Obj *returnLevelKey; /* holds "-level" */
Tcl_Obj *returnOptionsKey; /* holds "-options" */
+ Tcl_Obj *errorInfo; /* errorInfo value (now as a Tcl_Obj) */
+ Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable */
Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj) */
+ Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable */
/*
* Resource limiting framework support (TIP#143).
@@ -1395,11 +1396,8 @@ typedef struct Interp {
* don't process any more commands for it, and destroy
* the structure as soon as all nested invocations of
* Tcl_Eval are done.
- * ERR_IN_PROGRESS: Non-zero means an error unwind is already in
- * progress. Zero means a command proc has been
- * invoked since last error occured.
* ERR_ALREADY_LOGGED: Non-zero means information has already been logged
- * in $errorInfo for the current Tcl_Eval instance,
+ * in iPtr->errorInfo for the current Tcl_Eval instance,
* so Tcl_Eval needn't log it (used to implement the
* "error message log" command).
* DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler
@@ -1418,7 +1416,6 @@ typedef struct Interp {
*/
#define DELETED 1
-#define ERR_IN_PROGRESS 2
#define ERR_ALREADY_LOGGED 4
#define DONT_COMPILE_CMDS_INLINE 0x20
#define RAND_SEED_INITIALIZED 0x40
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 5ba48ab..51ce8fd 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.46 2004/10/06 14:59:02 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.47 2004/10/15 04:01:32 dgp Exp $
*/
#include "tclInt.h"
@@ -59,7 +59,7 @@
static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
proc tclInit {} {\n\
- global tcl_libPath tcl_library errorInfo\n\
+ global tcl_libPath tcl_library\n\
global env tclDefaultLibrary\n\
rename tclInit {}\n\
set errors {}\n\
@@ -84,10 +84,10 @@ static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
set tcl_library $i\n\
set tclfile [file join $i init.tcl]\n\
if {[file exists $tclfile]} {\n\
- if {![catch {uplevel #0 [list source $tclfile]} msg]} {\n\
+ if {![catch {uplevel #0 [list source $tclfile]} msg opt]} {\n\
return\n\
} else {\n\
- append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
+ append errors \"$tclfile: $msg\n$opt(-errorinfo)\n\"\n\
}\n\
}\n\
}\n\
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 1e736fe..238b485 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMain.c,v 1.27 2004/06/11 21:30:08 dgp Exp $
+ * RCS: @(#) $Id: tclMain.c,v 1.28 2004/10/15 04:01:32 dgp Exp $
*/
#include "tclInt.h"
@@ -438,7 +438,8 @@ Tcl_Main(argc, argv, appInitProc)
/*
* The following statement guarantees that the errorInfo
- * variable is set properly.
+ * variable is set properly when the error has to do with
+ * the opening or reading of the file.
*/
Tcl_AddErrorInfo(interp, "");
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 4c7a420..6b606f0 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.61 2004/10/06 15:59:24 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.62 2004/10/15 04:01:32 dgp Exp $
*/
#include "tclInt.h"
@@ -175,9 +175,15 @@ static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
static char * ErrorCodeRead _ANSI_ARGS_(( ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
+static char * ErrorInfoRead _ANSI_ARGS_(( ClientData clientData,
+ Tcl_Interp *interp, CONST char *name1,
+ CONST char *name2, int flags));
static char * EstablishErrorCodeTraces _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
CONST char *name1, CONST char *name2, int flags));
+static char * EstablishErrorInfoTraces _ANSI_ARGS_((
+ ClientData clientData, Tcl_Interp *interp,
+ CONST char *name1, CONST char *name2, int flags));
static void FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int GetNamespaceFromObj _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -525,7 +531,7 @@ Tcl_PopCallFrame(interp)
* EstablishErrorCodeTraces --
*
* Creates traces on the ::errorCode variable to keep its value
- * consistent with the expectation of legacy code.
+ * consistent with the expectations of legacy code.
*
* Results:
* None.
@@ -535,6 +541,7 @@ Tcl_PopCallFrame(interp)
*
*----------------------------------------------------------------------
*/
+
static char *
EstablishErrorCodeTraces(clientData, interp, name1, name2, flags)
ClientData clientData;
@@ -549,6 +556,23 @@ EstablishErrorCodeTraces(clientData, interp, name1, name2, flags)
EstablishErrorCodeTraces, (ClientData) NULL);
return NULL;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ErrorCodeRead --
+ *
+ * Called when the ::errorCode variable is read. Copies the
+ * current value of the interp's errorCode field into ::errorCode.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
static char *
ErrorCodeRead(clientData, interp, name1, name2, flags)
@@ -562,8 +586,72 @@ ErrorCodeRead(clientData, interp, name1, name2, flags)
if (flags & TCL_INTERP_DESTROYED) return NULL;
if (iPtr->errorCode == NULL) return NULL;
- Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
- iPtr->errorCode, TCL_GLOBAL_ONLY);
+ Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY);
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EstablishErrorInfoTraces --
+ *
+ * Creates traces on the ::errorInfo variable to keep its value
+ * consistent with the expectations of legacy code.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Read and unset traces are established on ::errorInfo.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+EstablishErrorInfoTraces(clientData, interp, name1, name2, flags)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ CONST char *name1;
+ CONST char *name2;
+ int flags;
+{
+ Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
+ ErrorInfoRead, (ClientData) NULL);
+ Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
+ EstablishErrorInfoTraces, (ClientData) NULL);
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ErrorInfoRead --
+ *
+ * Called when the ::errorInfo variable is read. Copies the
+ * current value of the interp's errorInfo field into ::errorInfo.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+ErrorInfoRead(clientData, interp, name1, name2, flags)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ CONST char *name1;
+ CONST char *name2;
+ int flags;
+{
+ Interp *iPtr = (Interp *)interp;
+
+ if (flags & TCL_INTERP_DESTROYED) return NULL;
+ if (iPtr->errorInfo == NULL) return NULL;
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY);
return NULL;
}
@@ -705,9 +793,10 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
} else {
/*
* In the global namespace create traces to maintain the
- * ::errorCode variable.
+ * ::errorInfo and ::errorCode variables.
*/
iPtr->globalNsPtr = nsPtr;
+ EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
}
@@ -829,11 +918,11 @@ Tcl_DeleteNamespace(namespacePtr)
TclTeardownNamespace(nsPtr);
if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
- /*
+ /*
* If this is the global namespace, then it may have residual
- * "errorInfo" and "errorCode" variables for errors that
- * occurred while it was being torn down. Try to clear the
- * variable list one last time.
+ * "errorInfo" and "errorCode" variables for errors that
+ * occurred while it was being torn down. Try to clear the
+ * variable list one last time.
*/
TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable);
@@ -852,7 +941,8 @@ Tcl_DeleteNamespace(namespacePtr)
nsPtr->flags |= NS_DEAD;
}
} else {
- /* Restore the ::errorCode traces */
+ /* Restore the ::errorInfo and ::errorCode traces */
+ EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
}
}
@@ -868,9 +958,7 @@ Tcl_DeleteNamespace(namespacePtr)
* commands, variables, and child namespaces.
*
* This is kept separate from Tcl_DeleteNamespace so that the global
- * namespace can be handled specially. Global variables like
- * "errorInfo" and "errorCode" need to remain intact while other
- * namespaces and commands are torn down, in case any errors occur.
+ * namespace can be handled specially.
*
* Results:
* None.
@@ -878,8 +966,6 @@ Tcl_DeleteNamespace(namespacePtr)
* Side effects:
* Removes this namespace from its parent's child namespace hashtable.
* Deletes all commands, variables and namespaces in this namespace.
- * If this is the global namespace, the "errorInfo" and "errorCode"
- * variables are left alone and deleted later.
*
*----------------------------------------------------------------------
*/
@@ -894,47 +980,17 @@ TclTeardownNamespace(nsPtr)
Tcl_HashSearch search;
Tcl_Namespace *childNsPtr;
Tcl_Command cmd;
- Namespace *globalNsPtr =
- (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
int i;
/*
* Start by destroying the namespace's variable table,
* since variables might trigger traces.
+ * Variable table should be cleared but not freed!
+ * TclDeleteVars frees it, so we reinitialize it afterwards.
*/
- if (nsPtr == globalNsPtr) {
- /*
- * This is the global namespace. Tearing it down will destroy the
- * ::errorInfo variable. We save and restore it
- * in case there are any errors in progress, so the error details
- * it contains will not be lost. See test namespace-8.5
- */
-
- Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
- NULL, TCL_GLOBAL_ONLY);
-
- if (errorInfo) {
- Tcl_IncrRefCount(errorInfo);
- }
-
- 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);
- }
- } else {
- /*
- * Variable table should be cleared but not freed! TclDeleteVars
- * frees it, so we reinitialize it afterwards.
- */
-
- TclDeleteVars(iPtr, &nsPtr->varTable);
- Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
- }
+ TclDeleteVars(iPtr, &nsPtr->varTable);
+ Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
/*
* Remove the namespace from its parent's child hashtable.
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 833e6d7..1be2e09 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.59 2004/10/06 10:11:05 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.60 2004/10/15 04:01:33 dgp Exp $
*/
#include "tclInt.h"
@@ -1295,7 +1295,7 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
* Side effects:
* If the result returned is TCL_ERROR, traceback information about
* the procedure just executed is appended to the interpreter's
- * "errorInfo" variable.
+ * errorInfo field.
*
*----------------------------------------------------------------------
*/
@@ -1439,7 +1439,7 @@ TclProcCleanupProc(procPtr)
* the procedure, instead of TCL_RETURN.
*
* Side effects:
- * The errorInfo and errorCode variables may get modified.
+ * The errorInfo and errorCode fields may get set.
*
*----------------------------------------------------------------------
*/
@@ -1481,9 +1481,8 @@ TclUpdateReturnInfo(iPtr)
Tcl_DictObjGet(NULL, iPtr->returnOpts,
iPtr->returnErrorinfoKey, &valuePtr);
if (valuePtr != NULL) {
- Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
- NULL, valuePtr, TCL_GLOBAL_ONLY);
- iPtr->flags |= ERR_IN_PROGRESS;
+ iPtr->errorInfo = valuePtr;
+ Tcl_IncrRefCount(iPtr->errorInfo);
}
}
return code;
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 9870501..9fd0bfc 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.14 2004/10/06 15:59:25 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.15 2004/10/15 04:01:33 dgp Exp $
*/
#include "tclInt.h"
@@ -732,12 +732,20 @@ Tcl_ResetResult(interp)
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
if (iPtr->errorCode) {
- Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
+ /* Legacy support */
+ Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
iPtr->errorCode, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(iPtr->errorCode);
iPtr->errorCode = NULL;
}
- iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS);
+ if (iPtr->errorInfo) {
+ /* Legacy support*/
+ Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
+ iPtr->errorInfo, TCL_GLOBAL_ONLY);
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ iPtr->errorInfo = NULL;
+ }
+ iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
@@ -794,26 +802,23 @@ ResetObjResult(iPtr)
* None.
*
* Side effects:
- * The errorCode global variable is modified to hold all of the
+ * The errorCode field of the interp is modified to hold all of the
* arguments to this procedure, in a list form with each argument
- * becoming one element of the list. A flag is set internally
- * to remember that errorCode has been set, so the variable doesn't
- * get set automatically when the error is returned.
+ * becoming one element of the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorCodeVA (interp, argList)
- Tcl_Interp *interp; /* Interpreter in which to access the errorCode
- * variable. */
+ Tcl_Interp *interp; /* Interpreter in which to set errorCode */
va_list argList; /* Variable argument list. */
{
Tcl_Obj *errorObj = Tcl_NewObj();
/*
* Scan through the arguments one at a time, appending them to
- * $errorCode as list elements.
+ * the errorCode field as list elements.
*/
while (1) {
@@ -838,11 +843,9 @@ Tcl_SetErrorCodeVA (interp, argList)
* None.
*
* Side effects:
- * The errorCode global variable is modified to hold all of the
+ * The errorCode field of the interp is modified to hold all of the
* arguments to this procedure, in a list form with each argument
- * becoming one element of the list. A flag is set internally
- * to remember that errorCode has been set, so the variable doesn't
- * get set automatically when the error is returned.
+ * becoming one element of the list.
*
*----------------------------------------------------------------------
*/
@@ -855,7 +858,7 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
/*
* Scan through the arguments one at a time, appending them to
- * $errorCode as list elements.
+ * the errorCode field as list elements.
*/
interp = TCL_VARARGS_START(Tcl_Interp *,arg1,argList);
@@ -876,10 +879,7 @@ Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
* None.
*
* Side effects:
- * The errorCode global variable is modified to be the new value.
- * A flag is set internally to remember that errorCode has been
- * set, so the variable doesn't get set automatically when the
- * error is returned.
+ * The errorCode field of the interp is set to the new value.
*
*----------------------------------------------------------------------
*/
@@ -917,9 +917,9 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
*
* Results:
* The target interp's result is set to a copy of the source interp's
- * result. The source's error information "$errorInfo" may be
- * appended to the target's error information and the source's error
- * code "$errorCode" may be stored in the target's error code.
+ * result. The source's errorInfo field may be transferred to the
+ * target's errorInfo field, and the source's errorCode field may be
+ * transferred to the target's errorCode field.
*
* Side effects:
* None.
@@ -963,17 +963,13 @@ TclTransferResult(sourceInterp, result, targetInterp)
Tcl_ResetResult(targetInterp);
- objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
- TCL_GLOBAL_ONLY);
- if (objPtr) {
- Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
- TCL_GLOBAL_ONLY);
- ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
+ if (iPtr->errorInfo) {
+ ((Interp *) targetInterp)->errorInfo = iPtr->errorInfo;
+ Tcl_IncrRefCount(((Interp *) targetInterp)->errorInfo);
}
- objPtr = ((Interp *) sourceInterp)->errorCode;
- if (objPtr) {
- Tcl_SetObjErrorCode(targetInterp, objPtr);
+ if (iPtr->errorCode) {
+ Tcl_SetObjErrorCode(targetInterp, iPtr->errorCode);
}
}
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 2b0f10f..b2067b3 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.15 2004/10/06 15:59:25 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.16 2004/10/15 04:01:33 dgp Exp $
*/
#include "tclInt.h"
@@ -2413,8 +2413,8 @@ TclVarTraceExists(interp, varName)
* Returns TCL_OK to indicate normal operation. Returns TCL_ERROR
* if invocation of a trace procedure indicated an error. When
* TCL_ERROR is returned and leaveErrMsg is true, then the
- * ::errorInfo variable of iPtr has information about the error
- * appended to it.
+ * errorInfo field of iPtr has information about the error
+ * placed in it.
*
* Side effects:
* Almost anything can happen, depending on trace; this procedure
@@ -2450,10 +2450,13 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
int copiedName;
int code = TCL_OK;
int disposeFlags = 0;
- int saveErrFlags = iPtr->flags
- & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED);
+ int saveErrFlags = iPtr->flags & ERR_ALREADY_LOGGED;
+ Tcl_Obj *saveErrInfo = iPtr->errorInfo;
Tcl_Obj *saveErrCode = iPtr->errorCode;
+ if (saveErrInfo) {
+ Tcl_IncrRefCount(saveErrInfo);
+ }
if (saveErrCode) {
Tcl_IncrRefCount(saveErrCode);
}
@@ -2581,12 +2584,21 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
done:
if (code == TCL_OK) {
iPtr->flags |= saveErrFlags;
+ if (iPtr->errorInfo) {
+ Tcl_DecrRefCount(iPtr->errorInfo);
+ }
+ iPtr->errorInfo = saveErrInfo;
if (iPtr->errorCode) {
Tcl_DecrRefCount(iPtr->errorCode);
}
iPtr->errorCode = saveErrCode;
- } else if (saveErrCode) {
- Tcl_DecrRefCount(saveErrCode);
+ } else {
+ if (saveErrInfo) {
+ Tcl_DecrRefCount(saveErrInfo);
+ }
+ if (saveErrCode) {
+ Tcl_DecrRefCount(saveErrCode);
+ }
}
if (code == TCL_ERROR) {
if (leaveErrMsg) {
generated by cgit v0.12 at 2024-11-05 05:23:46 (GMT)