diff options
| -rw-r--r-- | ChangeLog | 19 | ||||
| -rw-r--r-- | generic/tclLink.c | 4 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 6 | ||||
| -rw-r--r-- | generic/tclTrace.c | 27 | ||||
| -rw-r--r-- | generic/tclUtil.c | 4 | ||||
| -rw-r--r-- | generic/tclVar.c | 72 |
6 files changed, 69 insertions, 63 deletions
@@ -1,3 +1,22 @@ +2007-05-07 Don Porter <dgp@users.sourceforge.net> + + [Tcl Bug 1706140] + + * generic/tclLink.c (LinkTraceProc): Update Tcl_VarTraceProcs so that + * generic/tclNamesp.c (Error*Read): they call Tcl_InterpDeleted() + * generic/tclTrace.c (Trace*Proc): for themselves, and do not rely + * generic/tclUtil.c (TclPrecTraceProc): on (frequently buggy) setting + of the TCL_INTERP_DESTROYED flag by the trace core. + + * generic/tclVar.c: Update callers of TclCallVarTraces to not + pass in the TCL_INTERP_DESTROYED flag. Also apply filters so that + public routines only pass documented flag values down to lower level + routines. + + * generic/tclTrace.c (TclCallVarTraces): The setting of the + TCL_INTERP_DESTROYED flag is now done entirely within the + TclCallVarTraces routine, the only place it can be done right. + 2007-05-06 Donal K. Fellows <dkf@users.sf.net> * generic/tclInt.h (ExtraFrameInfo): Create a new mechanism for diff --git a/generic/tclLink.c b/generic/tclLink.c index 8d3bc1a..0f33c03 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.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: tclLink.c,v 1.21 2007/04/10 14:47:16 dkf Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.22 2007/05/07 19:45:33 dgp Exp $ */ #include "tclInt.h" @@ -262,7 +262,7 @@ LinkTraceProc( */ if (flags & TCL_TRACE_UNSETS) { - if (flags & TCL_INTERP_DESTROYED) { + if (Tcl_InterpDeleted(interp)) { Tcl_DecrRefCount(linkPtr->varName); ckfree((char *) linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 3f6ecf8..c090271 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -22,7 +22,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.133 2007/04/24 17:50:53 dgp Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.134 2007/05/07 19:45:33 dgp Exp $ */ #include "tclInt.h" @@ -622,7 +622,7 @@ ErrorCodeRead( { Interp *iPtr = (Interp *)interp; - if (flags & TCL_INTERP_DESTROYED) { + if (Tcl_InterpDeleted(interp)) { return NULL; } if (iPtr->errorCode) { @@ -696,7 +696,7 @@ ErrorInfoRead( { Interp *iPtr = (Interp *)interp; - if (flags & TCL_INTERP_DESTROYED) { + if (Tcl_InterpDeleted(interp)) { return NULL; } if (iPtr->errorInfo) { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 56a165d..a575f04 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.36 2007/04/10 14:47:17 dkf Exp $ + * RCS: @(#) $Id: tclTrace.c,v 1.37 2007/05/07 19:45:33 dgp Exp $ */ #include "tclInt.h" @@ -1269,7 +1269,7 @@ TraceCommandProc( tcmdPtr->refCount++; - if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) + if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { /* * Generate a command to execute by appending list elements for the @@ -1750,7 +1750,7 @@ TraceExecutionProc( return traceCode; } - if (!(flags & TCL_INTERP_DESTROYED) && !Tcl_LimitExceeded(interp)) { + if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { /* * Check whether the current call is going to eval arbitrary Tcl code * with a generated trace, or whether we are only going to setup @@ -1958,7 +1958,7 @@ TraceVarProc( */ result = NULL; - if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED) + if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { if (tvarPtr->length != (size_t) 0) { /* @@ -2457,10 +2457,8 @@ TclCallVarTraces( CONST char *part1, CONST char *part2, /* Variable's two-part name. */ int flags, /* Flags passed to trace functions: indicates - * what's happening to variable, plus other - * stuff like TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, and - * TCL_INTERP_DESTROYED. */ + * what's happening to variable, plus maybe + * TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */ int leaveErrMsg) /* If true, and one of the traces indicates an * error, then leave an error message and * stack trace information in *iPTr. */ @@ -2524,6 +2522,13 @@ TclCallVarTraces( } /* + * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can + * set it correctly. + */ + + flags &= ~TCL_INTERP_DESTROYED; + + /* * Invoke traces on the array containing the variable, if relevant. */ @@ -2543,6 +2548,9 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); } + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2582,6 +2590,9 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *)iPtr, code); } + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index adced82..fe7f18a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.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: tclUtil.c,v 1.81 2007/03/21 18:02:51 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.82 2007/05/07 19:45:33 dgp Exp $ */ #include "tclInt.h" @@ -2143,7 +2143,7 @@ TclPrecTraceProc( */ if (flags & TCL_TRACE_UNSETS) { - if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); diff --git a/generic/tclVar.c b/generic/tclVar.c index 2e5f39d..dc76825 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.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: tclVar.c,v 1.133 2007/05/02 00:31:22 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.134 2007/05/07 19:45:34 dgp Exp $ */ #include "tclInt.h" @@ -1097,15 +1097,10 @@ Tcl_GetVar2Ex( { Var *varPtr, *arrayPtr; - /* - * We need a special flag check to see if we want to create part 1, - * because commands like lappend require read traces to trigger for - * previously non-existent values. - */ - + /* Filter to pass through only the flags this interface supports. */ + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); varPtr = TclLookupVar(interp, part1, part2, flags, "read", - /*createPart1*/ (flags & TCL_TRACE_READS), - /*createPart2*/ 1, &arrayPtr); + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } @@ -1155,15 +1150,10 @@ Tcl_ObjGetVar2( part1 = TclGetString(part1Ptr); part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); - /* - * We need a special flag check to see if we want to create part 1, - * because commands like lappend require read traces to trigger for - * previously non-existent values. - */ - + /* Filter to pass through only the flags this interface supports. */ + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", - /*createPart1*/ (flags & TCL_TRACE_READS), - /*createPart2*/ 1, &arrayPtr); + /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } @@ -1453,6 +1443,9 @@ Tcl_SetVar2Ex( { Var *varPtr, *arrayPtr; + /* Filter to pass through only the flags this interface supports. */ + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG + |TCL_APPEND_VALUE|TCL_LIST_ELEMENT); varPtr = TclLookupVar(interp, part1, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -1512,6 +1505,9 @@ Tcl_ObjSetVar2( part1 = TclGetString(part1Ptr); part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); + /* Filter to pass through only the flags this interface supports. */ + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG + |TCL_APPEND_VALUE|TCL_LIST_ELEMENT); varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -1603,7 +1599,8 @@ TclPtrSetVar( /* * Invoke any read traces that have been set for the variable if it is - * requested; this is only done in the core when lappending. + * requested; this is only done in the core by the INST_LAPPEND_* + * instructions. */ if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) @@ -1936,6 +1933,8 @@ Tcl_UnsetVar2( part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); + /* Filter to pass through only the flags this interface supports. */ + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); result = TclObjUnsetVar2(interp, part1Ptr, part2, flags); TclDecrRefCount(part1Ptr); @@ -2121,8 +2120,8 @@ UnsetVarStruct( if ((dummyVar.tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { dummyVar.flags &= ~VAR_TRACE_ACTIVE; - TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_INTERP_DESTROYED)) + TclCallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, (flags + & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; @@ -2146,21 +2145,8 @@ UnsetVarStruct( dummyVarPtr = &dummyVar; if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { - /* - * Deleting the elements of the array may cause traces to be fired on - * those elements. Before deleting them, bump the reference count of - * the array, so that if those trace procs make a global or upvar link - * to the array, the array is not deleted when the call stack gets - * popped (we will delete the array ourselves later in this function). - * - * Bumping the count can lead to the odd situation that elements of - * the array are being deleted when the array still exists, but since - * the array is about to be removed anyway, that shouldn't really - * matter. - */ - - DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + DeleteArray(iPtr, part1, dummyVarPtr, (flags + & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); /* @@ -2390,10 +2376,7 @@ Tcl_LappendObjCmd( createdNewObj = 0; /* - * Use the TCL_TRACE_READS flag to ensure that if we have an array - * with no elements set yet, but with a read trace on it, we will - * create the variable and get read traces triggered. Note that you - * have to protect the variable pointers around the TclPtrGetVar call + * Protect the variable pointers around the TclPtrGetVar call * to insure that they remain valid even if the variable was undefined * and unused. */ @@ -2409,7 +2392,7 @@ Tcl_LappendObjCmd( } part1 = TclGetString(objv[1]); varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, - (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG)); + TCL_LEAVE_ERR_MSG); varPtr->refCount--; if (arrayPtr != NULL) { arrayPtr->refCount--; @@ -4078,9 +4061,6 @@ TclDeleteNamespaceVars( } else if (nsPtr == (Namespace *) Tcl_GetCurrentNamespace(interp)) { flags = TCL_NAMESPACE_ONLY; } - if (Tcl_InterpDeleted(interp)) { - flags |= TCL_INTERP_DESTROYED; - } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_FirstHashEntry(tablePtr, &search)) { @@ -4158,9 +4138,6 @@ TclDeleteVars( } else if (tablePtr == &currNsPtr->varTable) { flags |= TCL_NAMESPACE_ONLY; } - if (Tcl_InterpDeleted(interp)) { - flags |= TCL_INTERP_DESTROYED; - } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -4389,8 +4366,7 @@ DeleteArray( Var *varPtr, /* Pointer to variable structure. */ int flags) /* Flags to pass to TclCallVarTraces: * TCL_TRACE_UNSETS and sometimes - * TCL_INTERP_DESTROYED, TCL_NAMESPACE_ONLY, - * or TCL_GLOBAL_ONLY. */ + * TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */ { Tcl_HashSearch search; register Tcl_HashEntry *hPtr; |