[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.

5 files changed, 50 insertions, 63 deletions

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;