Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcl/tcl/ChangeLog,v
retrieving revision 1.2282
diff -u -r1.2282 ChangeLog
--- ChangeLog 5 Oct 2004 15:45:00 -0000 1.2282
+++ ChangeLog 5 Oct 2004 18:03:46 -0000
@@ -1,5 +1,28 @@
2004-10-05 Don Porter <[email protected]>
+ * 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.
+
+ ***POTENTIAL INCOMPATIBILITY***
+ Code that sets traces on the ::errorCode value may notice a
+ difference in timing of the firing of those traces.
+
* generic/tclNamesp.c (Tcl_PopCallFrame): Removed Bug 1038021
workaround. That bug is now fixed.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.122
diff -u -r1.122 tclBasic.c
--- generic/tclBasic.c 1 Oct 2004 03:19:56 -0000 1.122
+++ generic/tclBasic.c 5 Oct 2004 18:03:47 -0000
@@ -241,6 +241,7 @@
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 @@
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 @@
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 @@
*/
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 @@
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_AppendToObj(message, "\"", -1);
TclAppendObjToErrorInfo(interp, message);
Tcl_DecrRefCount(message);
- if (!(iPtr->flags & ERROR_CODE_SET)) {
+ if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", NULL);
}
}
Index: generic/tclCmdAH.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclCmdAH.c,v
retrieving revision 1.50
diff -u -r1.50 tclCmdAH.c
--- generic/tclCmdAH.c 30 Sep 2004 23:06:47 -0000 1.50
+++ generic/tclCmdAH.c 5 Oct 2004 18:03:47 -0000
@@ -298,8 +298,7 @@
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);
Index: generic/tclEvent.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEvent.c,v
retrieving revision 1.46
diff -u -r1.46 tclEvent.c
--- generic/tclEvent.c 27 Sep 2004 16:24:24 -0000 1.46
+++ generic/tclEvent.c 5 Oct 2004 18:03:47 -0000
@@ -33,7 +33,7 @@
* 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 @@
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 @@
}
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 @@
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 @@
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 @@
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);
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.179
diff -u -r1.179 tclInt.h
--- generic/tclInt.h 1 Oct 2004 12:45:19 -0000 1.179
+++ generic/tclInt.h 5 Oct 2004 18:03:48 -0000
@@ -1332,6 +1332,8 @@
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 @@
* 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 @@
#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
Index: generic/tclNamesp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNamesp.c,v
retrieving revision 1.59
diff -u -r1.59 tclNamesp.c
--- generic/tclNamesp.c 5 Oct 2004 16:26:32 -0000 1.59
+++ generic/tclNamesp.c 5 Oct 2004 18:03:50 -0000
@@ -172,6 +172,12 @@
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 @@
/*
*----------------------------------------------------------------------
*
+ * 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 @@
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 @@
} else {
nsPtr->flags |= NS_DEAD;
}
- }
+ } else {
+ /* Restore the ::errorCode traces */
+ EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
+ }
}
}
@@ -843,22 +907,17 @@
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 @@
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
Index: generic/tclResult.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclResult.c,v
retrieving revision 1.11
diff -u -r1.11 tclResult.c
--- generic/tclResult.c 30 Sep 2004 23:06:48 -0000 1.11
+++ generic/tclResult.c 5 Oct 2004 18:03:50 -0000
@@ -801,7 +801,13 @@
}
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 @@
{
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 @@
((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);
}
Index: generic/tclTrace.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTrace.c,v
retrieving revision 1.13
diff -u -r1.13 tclTrace.c
--- generic/tclTrace.c 1 Oct 2004 00:10:23 -0000 1.13
+++ generic/tclTrace.c 5 Oct 2004 18:03:51 -0000
@@ -2451,7 +2451,12 @@
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 @@
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) {
