* generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp,

                TclEvalObjvInternal,Tcl_LogCommandInfo):
        * generic/tclCmdAH.c (Tcl_CatchObjCmd):
        * generic/tclEvent.c (BgError,Tcl_BackgroundError,HandleBgErrors):
        * generic/tclInt.h (Interp, ERROR_CODE_SET):
        * generic/tclNamesp.c
                (Tcl_CreateNamespace,Tcl_DeleteNamespace,TclTeardownNamespace):
        * generic/tclResult.c
                (Tcl_ResetResult,Tcl_SetObjErrorCode,TclTransferResult):
        * generic/tclTrace.c (CallVarTraces):
        Reworked management of the "errorCode" 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 ::errorCode as the primary storage.  The
        ERROR_CODE_SET 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 ::errorCode variable to hold the information.

7 files changed, 133 insertions, 70 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6cb7cd0..ca01b83 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.122 2004/10/01 03:19:56 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.123 2004/10/05 18:14:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -241,6 +241,7 @@ Tcl_CreateInterp()
     Tcl_IncrRefCount(iPtr->defaultReturnOpts);
     iPtr->returnOpts = iPtr->defaultReturnOpts;
     Tcl_IncrRefCount(iPtr->returnOpts);
+    iPtr->errorCode = NULL;
 
     iPtr->appendResult = NULL;
     iPtr->appendAvl = 0;
@@ -426,30 +427,6 @@ Tcl_CreateInterp()
 
     TclInterpInit(interp);
 
-    /*
-     * We used to create the "errorInfo" and "errorCode" global vars at this
-     * point because so much of the Tcl implementation assumes they already
-     * exist. This is not quite enough, however, since they can be unset
-     * at any time.
-     *
-     * There are 2 choices:
-     *    + Check every place where a GetVar of those is used 
-     *      and the NULL result is not checked (like in tclLoad.c)
-     *    + Make SetVar,... NULL friendly
-     * We choose the second option because :
-     *    + It is easy and low cost to check for NULL pointer before
-     *      calling strlen()
-     *    + It can be helpfull to other people using those API
-     *    + Passing a NULL value to those closest 'meaning' is empty string
-     *      (specially with the new objects where 0 bytes strings are ok)
-     * So the following init is commented out:              -- dl
-     *
-     * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL,
-     *       "", TCL_GLOBAL_ONLY);
-     * (void) Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL,
-     *       "NONE", TCL_GLOBAL_ONLY);
-     */
-
 #ifndef TCL_GENERIC_ONLY
     TclSetupEnv(interp);
 #endif
@@ -1005,6 +982,10 @@ DeleteInterpProc(interp)
     interp->result = NULL;
     Tcl_DecrRefCount(iPtr->objResultPtr);
     iPtr->objResultPtr = NULL;
+    if (iPtr->errorCode) {
+	Tcl_DecrRefCount(iPtr->errorCode);
+	iPtr->errorCode = NULL;
+    }
     Tcl_DecrRefCount(iPtr->returnOpts);
     Tcl_DecrRefCount(iPtr->defaultReturnOpts);
     Tcl_DecrRefCount(iPtr->returnCodeKey);
@@ -3088,8 +3069,12 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
      */
     if (!(cmdPtr->flags & CMD_IS_DELETED)) {
 	int saveErrFlags = iPtr->flags
-		& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
+		& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED);
 	Tcl_Obj *saveOptions = iPtr->returnOpts;
+	Tcl_Obj *saveErrCode = iPtr->errorCode;
+	if (saveErrCode) {
+	    Tcl_IncrRefCount(saveErrCode);
+	}
 	Tcl_IncrRefCount(saveOptions);
         if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
             traceCode = TclCheckExecutionTraces(interp, command, length,
@@ -3104,6 +3089,12 @@ TclEvalObjvInternal(interp, objc, objv, command, length, flags)
 	    iPtr->returnOpts = saveOptions;
 	    Tcl_IncrRefCount(iPtr->returnOpts);
 	    iPtr->flags |= saveErrFlags;
+	    if (iPtr->errorCode) {
+		Tcl_DecrRefCount(iPtr->errorCode);
+	    }
+	    iPtr->errorCode = saveErrCode;
+	} else if (saveErrCode) {
+	    Tcl_DecrRefCount(saveErrCode);
 	}
 	Tcl_DecrRefCount(saveOptions);
     }
@@ -3307,7 +3298,7 @@ Tcl_LogCommandInfo(interp, script, command, length)
     Tcl_AppendToObj(message, "\"", -1);
     TclAppendObjToErrorInfo(interp, message);
     Tcl_DecrRefCount(message);
-    if (!(iPtr->flags & ERROR_CODE_SET)) {
+    if (!iPtr->errorCode) {
 	Tcl_SetErrorCode(interp, "NONE", NULL);
     }
 }
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 1af7958..6208c93 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.50 2004/09/30 23:06:47 dgp Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.51 2004/10/05 18:14:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -298,8 +298,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
 	    Tcl_DictObjGet(NULL, options, iPtr->returnErrorcodeKey, &value);
 	    if (NULL == value) {
 		Tcl_DictObjPut(NULL, options, iPtr->returnErrorcodeKey,
-			Tcl_ObjGetVar2(interp, iPtr->execEnvPtr->errorCode,
-			NULL, TCL_GLOBAL_ONLY));
+			iPtr->errorCode);
 	    }
 	    value = NULL;
 	    Tcl_DictObjGet(NULL, options, iPtr->returnErrorlineKey, &value);
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 292e09b..5a38ad7 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.46 2004/09/27 16:24:24 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.47 2004/10/05 18:14:27 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -33,7 +33,7 @@ typedef struct BgError {
 				 * Malloc-ed. */
     char *errorInfo;		/* Value of the errorInfo variable
 				 * (malloc-ed). */
-    char *errorCode;		/* Value of the errorCode variable
+    Tcl_Obj *errorCode;		/* Value of the errorCode variable
 				 * (malloc-ed). */
     struct BgError *nextPtr;	/* Next in list of all pending error
 				 * reports for this interpreter, or NULL
@@ -163,6 +163,7 @@ Tcl_BackgroundError(interp)
     CONST char *errResult, *varValue;
     ErrAssocData *assocPtr;
     int length;
+    Interp *iPtr = (Interp *) interp;
 
     /*
      * The Tcl_AddErrorInfo call below (with an empty string) ensures that
@@ -186,12 +187,15 @@ Tcl_BackgroundError(interp)
     }
     errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
     strcpy(errPtr->errorInfo, varValue);
-    varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
-    if (varValue == NULL) {
-	varValue = "";
+
+    if (iPtr->errorCode) {
+	errPtr->errorCode = iPtr->errorCode;
+    } else {
+	/* Does this ever happen ? */
+	errPtr->errorCode = Tcl_NewObj();
     }
-    errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
-    strcpy(errPtr->errorCode, varValue);
+    Tcl_IncrRefCount(errPtr->errorCode);
+
     errPtr->nextPtr = NULL;
 
     assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
@@ -266,8 +270,8 @@ HandleBgErrors(clientData)
 
 	Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
 		TCL_GLOBAL_ONLY);
-	Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
-		TCL_GLOBAL_ONLY);
+	Tcl_SetVar2Ex(interp, "errorCode", NULL,
+		assocPtr->firstBgPtr->errorCode, TCL_GLOBAL_ONLY);
 
 	/*
 	 * Create and invoke the bgerror command.
@@ -358,7 +362,7 @@ doneWithInterp:
 	if (assocPtr->firstBgPtr) {
 	    ckfree(assocPtr->firstBgPtr->errorMsg);
 	    ckfree(assocPtr->firstBgPtr->errorInfo);
-	    ckfree(assocPtr->firstBgPtr->errorCode);
+	    Tcl_DecrRefCount(assocPtr->firstBgPtr->errorCode);
 	    errPtr = assocPtr->firstBgPtr->nextPtr;
 	    ckfree((char *) assocPtr->firstBgPtr);
 	    assocPtr->firstBgPtr = errPtr;
@@ -407,7 +411,7 @@ BgErrorDeleteProc(clientData, interp)
 	assocPtr->firstBgPtr = errPtr->nextPtr;
 	ckfree(errPtr->errorMsg);
 	ckfree(errPtr->errorInfo);
-	ckfree(errPtr->errorCode);
+	Tcl_DecrRefCount(errPtr->errorCode);
 	ckfree((char *) errPtr);
     }
     Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index e525c52..c97e727 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.179 2004/10/01 12:45:19 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.180 2004/10/05 18:14:27 dgp Exp $
  */
 
 #ifndef _TCLINT
@@ -1332,6 +1332,8 @@ typedef struct Interp {
     Tcl_Obj *returnLevelKey;	/* holds "-level" */
     Tcl_Obj *returnOptionsKey;	/* holds "-options" */
 
+    Tcl_Obj *errorCode;		/* errorCode value (now as a Tcl_Obj) */
+
     /*
      * Resource limiting framework support (TIP#143).
      */
@@ -1400,10 +1402,6 @@ typedef struct Interp {
  *			in $errorInfo for the current Tcl_Eval instance,
  *			so Tcl_Eval needn't log it (used to implement the
  *			"error message log" command).
- * ERROR_CODE_SET:	Non-zero means that Tcl_SetErrorCode has been
- *			called to record information for the current
- *			error.	Zero means Tcl_Eval must clear the
- *			errorCode variable if an error is returned.
  * DONT_COMPILE_CMDS_INLINE: Non-zero means that the bytecode compiler
  *			should not compile any commands into an inline
  *			sequence of instructions. This is set 1, for
@@ -1422,7 +1420,6 @@ typedef struct Interp {
 #define DELETED				    1
 #define ERR_IN_PROGRESS			    2
 #define ERR_ALREADY_LOGGED		    4
-#define ERROR_CODE_SET			    8
 #define DONT_COMPILE_CMDS_INLINE	 0x20
 #define RAND_SEED_INITIALIZED		 0x40
 #define SAFE_INTERP			 0x80
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 1528e0f..3a86859 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.59 2004/10/05 16:26:32 dgp Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.60 2004/10/05 18:14:28 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -172,6 +172,12 @@ typedef struct EnsembleCmdRep {
 static void		DeleteImportedCmd _ANSI_ARGS_((ClientData clientData));
 static void		DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
 			    Tcl_Obj *copyPtr));
+static char *		ErrorCodeRead _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 void		FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
 static int		GetNamespaceFromObj _ANSI_ARGS_((
 			    Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -516,6 +522,54 @@ Tcl_PopCallFrame(interp)
 /*
  *----------------------------------------------------------------------
  *
+ * EstablishErrorCodeTraces --
+ *
+ *	Creates traces on the ::errorCode variable to keep its value
+ *	consistent with the expectation of legacy code.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Read and unset traces are established on ::errorCode.
+ *
+ *----------------------------------------------------------------------
+ */
+static char *
+EstablishErrorCodeTraces(clientData, interp, name1, name2, flags)
+    ClientData clientData;
+    Tcl_Interp *interp;
+    CONST char *name1;
+    CONST char *name2;
+    int flags;
+{
+    Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
+	    ErrorCodeRead, (ClientData) NULL);
+    Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
+	    EstablishErrorCodeTraces, (ClientData) NULL);
+    return NULL;
+}
+
+static char *
+ErrorCodeRead(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->errorCode == NULL) return NULL;
+    Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
+	    iPtr->errorCode, TCL_GLOBAL_ONLY);
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_CreateNamespace --
  *
  *	Creates a new namespace with the given name. If there is no
@@ -649,6 +703,13 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
         entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
 	        &newEntry);
         Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
+    } else {
+	/* 
+	 * In the global namespace create traces to maintain the
+	 * ::errorCode variable.
+	 */
+	iPtr->globalNsPtr = nsPtr;
+	EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
     }
 
     /*
@@ -791,7 +852,10 @@ Tcl_DeleteNamespace(namespacePtr)
             } else {
                 nsPtr->flags |= NS_DEAD;
             }
-        }
+        } else {
+	    /* Restore the ::errorCode traces */
+	    EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
+	}
     }
 }
 
@@ -843,22 +907,17 @@ TclTeardownNamespace(nsPtr)
     if (nsPtr == globalNsPtr) {
 	/*
 	 * This is the global namespace.  Tearing it down will destroy the
-	 * ::errorInfo and ::errorCode variables.  We save and restore them
+	 * ::errorInfo variable.  We save and restore it 
 	 * in case there are any errors in progress, so the error details
-	 * they contain will not be lost.  See test namespace-8.5
+	 * it contains will not be lost.  See test namespace-8.5
 	 */
 
 	Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
 		NULL, TCL_GLOBAL_ONLY);
-	Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
-		NULL, TCL_GLOBAL_ONLY);
 			                
 	if (errorInfo) {
 	    Tcl_IncrRefCount(errorInfo);
 	}   
-	if (errorCode) {
-	    Tcl_IncrRefCount(errorCode);
-	}
 
 	TclDeleteVars(iPtr, &nsPtr->varTable);
 	Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
@@ -868,11 +927,6 @@ TclTeardownNamespace(nsPtr)
 		    errorInfo, TCL_GLOBAL_ONLY);
 	    Tcl_DecrRefCount(errorInfo);
 	}   
-	if (errorCode) {
-	    Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
-		    errorCode, TCL_GLOBAL_ONLY);
-	    Tcl_DecrRefCount(errorCode);
-	}
     } else {
 	/*
 	 * Variable table should be cleared but not freed! TclDeleteVars
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 9e83796..2bd52dd 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.11 2004/09/30 23:06:48 dgp Exp $
+ * RCS: @(#) $Id: tclResult.c,v 1.12 2004/10/05 18:14:28 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -801,7 +801,13 @@ Tcl_ResetResult(interp)
     }
     iPtr->result = iPtr->resultSpace;
     iPtr->resultSpace[0] = 0;
-    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
+    if (iPtr->errorCode) {
+	Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
+		iPtr->errorCode, TCL_GLOBAL_ONLY);
+	Tcl_DecrRefCount(iPtr->errorCode);
+	iPtr->errorCode = NULL;
+    }
+    iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS);
 }
 
 /*
@@ -955,9 +961,11 @@ Tcl_SetObjErrorCode(interp, errorObjPtr)
 {
     Interp *iPtr = (Interp *) interp;
     
-    Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
-	    errorObjPtr, TCL_GLOBAL_ONLY);
-    iPtr->flags |= ERROR_CODE_SET;
+    if (iPtr->errorCode) {
+	Tcl_DecrRefCount(iPtr->errorCode);
+    }
+    iPtr->errorCode = errorObjPtr;
+    Tcl_IncrRefCount(iPtr->errorCode);
 }
 
 /*
@@ -1033,8 +1041,7 @@ TclTransferResult(sourceInterp, result, targetInterp)
 	    ((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
 	}
 
-	objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
-		TCL_GLOBAL_ONLY);
+	objPtr = ((Interp *) sourceInterp)->errorCode;
 	if (objPtr) {
 	    Tcl_SetObjErrorCode(targetInterp, objPtr);
 	}
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 91cd63d..dc8cbd3 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.13 2004/10/01 00:10:23 dgp Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.14 2004/10/05 18:14:28 dgp Exp $
  */
 
 #include "tclInt.h"
@@ -2451,7 +2451,12 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
     int code = TCL_OK;
     int disposeFlags = 0;
     int saveErrFlags = iPtr->flags
-	    & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
+	    & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED);
+    Tcl_Obj *saveErrCode = iPtr->errorCode;
+
+    if (saveErrCode) {
+	Tcl_IncrRefCount(saveErrCode);
+    }
 
     /*
      * If there are already similar trace procedures active for the
@@ -2576,6 +2581,12 @@ TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
     done:
     if (code == TCL_OK) {
 	iPtr->flags |= saveErrFlags;
+	if (iPtr->errorCode) {
+	    Tcl_DecrRefCount(iPtr->errorCode);
+	}
+	iPtr->errorCode = saveErrCode;
+    } else if (saveErrCode) {
+	Tcl_DecrRefCount(saveErrCode);
     }
     if (code == TCL_ERROR) {
 	if (leaveErrMsg) {