summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c45
-rw-r--r--generic/tclCmdAH.c5
-rw-r--r--generic/tclEvent.c26
-rw-r--r--generic/tclInt.h9
-rw-r--r--generic/tclNamesp.c82
-rw-r--r--generic/tclResult.c21
-rw-r--r--generic/tclTrace.c15
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) {