summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2004-10-15 04:01:22 (GMT)
committerdgp <dgp@users.sourceforge.net>2004-10-15 04:01:22 (GMT)
commit0eb70513827981212a928f0a5b63afb70c53c960 (patch)
treea5072bb17646340c040c80672eeba059e8b393f0 /generic
parent2b7d6e025eefe41b48ec7f948602faf2d3bf7055 (diff)
downloadtcl-0eb70513827981212a928f0a5b63afb70c53c960.zip
tcl-0eb70513827981212a928f0a5b63afb70c53c960.tar.gz
tcl-0eb70513827981212a928f0a5b63afb70c53c960.tar.bz2
* 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.
Diffstat (limited to 'generic')
-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
13 files changed, 339 insertions, 281 deletions
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) {