diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 45 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 5 | ||||
| -rw-r--r-- | generic/tclEvent.c | 26 | ||||
| -rw-r--r-- | generic/tclInt.h | 9 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 82 | ||||
| -rw-r--r-- | generic/tclResult.c | 21 | ||||
| -rw-r--r-- | generic/tclTrace.c | 15 |
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) { |