From 2474fc6acea8d8792bb8b166aaff610e72a38244 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 10 May 2007 18:23:56 +0000 Subject: [Tcl Bug 1706140] * generic/tclCmdMZ.c (Trace*Proc): Update Tcl_VarTraceProcs so * generic/tclLink.c (LinkTraceProc): that they call * generic/tclUtil.c (TclPrecTraceProc): Tcl_InterpDeleted() for themselves, and do not rely on (frequently buggy) setting of the TCL_INTERP_DESTROYED flag by the trace core. * generic/tclVar.c: Update callers of CallVarTraces 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/tclVar.c (CallVarTraces): The setting of the TCL_INTERP_DESTROYED flag is now done entirely within the CallVarTraces routine, the only place it can be done right. FossilOrigin-Name: e09d290d78d358bdb642204b2e1d794f4f93e953 --- ChangeLog | 19 ++++++++++++++ generic/tclCmdMZ.c | 8 +++--- generic/tclLink.c | 4 +-- generic/tclUtil.c | 4 +-- generic/tclVar.c | 72 ++++++++++++++++++++---------------------------------- 5 files changed, 54 insertions(+), 53 deletions(-) diff --git a/ChangeLog b/ChangeLog index 7c623c2..f8d028a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,22 @@ +2007-05-10 Don Porter + + [Tcl Bug 1706140] + + * generic/tclCmdMZ.c (Trace*Proc): Update Tcl_VarTraceProcs so + * generic/tclLink.c (LinkTraceProc): that they call + * generic/tclUtil.c (TclPrecTraceProc): Tcl_InterpDeleted() for + themselves, and do not rely on (frequently buggy) setting of the + TCL_INTERP_DESTROYED flag by the trace core. + + * generic/tclVar.c: Update callers of CallVarTraces 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/tclVar.c (CallVarTraces): The setting of the + TCL_INTERP_DESTROYED flag is now done entirely within the + CallVarTraces routine, the only place it can be done right. + 2007-04-30 Daniel Steffen * unix/Makefile.in: add 'tclsh' dependency to install targets that rely diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d4a8732..b663f16 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.27 2006/11/28 22:20:00 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.28 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" @@ -4167,7 +4167,7 @@ TraceCommandProc(clientData, interp, oldName, newName, flags) tcmdPtr->refCount++; - if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { /* * Generate a command to execute by appending list elements * for the old and new command name and the operation. @@ -4627,7 +4627,7 @@ TraceExecutionProc(ClientData clientData, Tcl_Interp *interp, return traceCode; } - if (!(flags & TCL_INTERP_DESTROYED)) { + if (!Tcl_InterpDeleted(interp)) { /* * Check whether the current call is going to eval arbitrary * Tcl code with a generated trace, or whether we are only @@ -4837,7 +4837,7 @@ TraceVarProc(clientData, interp, name1, name2, flags) */ result = NULL; - if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) { + if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) { if (tvarPtr->length != (size_t) 0) { /* * Generate a command to execute by appending list elements diff --git a/generic/tclLink.c b/generic/tclLink.c index f31ad8e..3cbaebb 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.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: tclLink.c,v 1.8.2.1 2005/10/23 22:01:30 msofer Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.8.2.2 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" @@ -250,7 +250,7 @@ LinkTraceProc(clientData, interp, name1, name2, flags) */ 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/tclUtil.c b/generic/tclUtil.c index d12ebe8..ca5ba0e 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.36.2.7 2006/09/30 19:20:12 msofer Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.36.2.8 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" @@ -1970,7 +1970,7 @@ TclPrecTraceProc(clientData, interp, name1, name2, flags) */ 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 b8c608b..b29400e 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.69.2.13 2007/03/13 15:59:52 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.69.2.14 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" @@ -1100,14 +1100,10 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) { 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; } @@ -1157,14 +1153,10 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) part1 = Tcl_GetString(part1Ptr); part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(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; } @@ -1460,6 +1452,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) { 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) { @@ -1516,6 +1511,9 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) part1 = TclGetString(part1Ptr); part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(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) { @@ -1604,7 +1602,8 @@ TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) /* * Invoke any read traces that have been set for the variable if it - * is requested; this is only done in the core when lappending. + * is requested; this is only done in the core by the INST_LAPPEND_* + * instructions. */ if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) @@ -1960,6 +1959,8 @@ Tcl_UnsetVar2(interp, part1, part2, flags) 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); @@ -2170,22 +2171,8 @@ UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags) 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)) - | TCL_TRACE_UNSETS); - /* Decr ref count */ + DeleteArray(iPtr, part1, dummyVarPtr, (flags + & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); } if (TclIsVarScalar(dummyVarPtr) && (dummyVarPtr->value.objPtr != NULL)) { @@ -2782,9 +2769,6 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * variable's old value is unshared we modify it directly, otherwise * we create a new copy to modify: this is "copy on write". * - * 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 to insure that they remain valid * even if the variable was undefined and unused. @@ -2801,7 +2785,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) } 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--; @@ -4183,8 +4167,7 @@ CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) int flags; /* Flags passed to trace procedures: * indicates what's happening to variable, * plus other stuff like TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, and - * TCL_INTERP_DESTROYED. */ + * or TCL_NAMESPACE_ONLY. */ CONST int leaveErrMsg; /* If true, and one of the traces indicates an * error, then leave an error message and stack * trace information in *iPTr. */ @@ -4265,6 +4248,9 @@ CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) continue; } Tcl_Preserve((ClientData) tracePtr); + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -4298,6 +4284,9 @@ CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) continue; } Tcl_Preserve((ClientData) tracePtr); + if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -4618,9 +4607,6 @@ TclDeleteNamespaceVars(nsPtr) } else if (nsPtr == currNsPtr) { 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)) { @@ -4697,9 +4683,6 @@ TclDeleteVars(iPtr, tablePtr) } 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)) { @@ -4934,7 +4917,6 @@ DeleteArray(iPtr, arrayName, varPtr, flags) Var *varPtr; /* Pointer to variable structure. */ int flags; /* Flags to pass to CallVarTraces: * TCL_TRACE_UNSETS and sometimes - * TCL_INTERP_DESTROYED, * TCL_NAMESPACE_ONLY, or * TCL_GLOBAL_ONLY. */ { -- cgit v0.12