VarReform [Patch 1750051]

	*** POTENTIAL INCOMPATIBILITY *** (tclInt.h and tclCompile.h)

1 files changed, 149 insertions, 69 deletions

diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 0acce21..6ee7798 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.43 2007/07/24 03:14:40 msofer Exp $
+ * RCS: @(#) $Id: tclTrace.c,v 1.44 2007/07/31 17:03:39 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -2407,8 +2407,8 @@ TclVarTraceExists(
 	return NULL;
     }
 
-    if ((varPtr->tracePtr != NULL)
-	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
+    if ((varPtr->flags & VAR_TRACED_READ)
+	    || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) {
 	TclCallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
 		TCL_TRACE_READS, /* leaveErrMsg */ 0);
     }
@@ -2450,6 +2450,34 @@ TclVarTraceExists(
  */
 
 int
+TclObjCallVarTraces(
+    Interp *iPtr,		/* Interpreter containing variable. */
+    register Var *arrayPtr,	/* Pointer to array variable that contains the
+				 * variable, or NULL if the variable isn't an
+				 * element of an array. */
+    Var *varPtr,		/* Variable whose traces are to be invoked. */
+    Tcl_Obj *part1Ptr,
+    Tcl_Obj *part2Ptr,		/* Variable's two-part name. */
+    int flags,			/* Flags passed to trace functions: indicates
+				 * 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. */
+    int index)
+{
+    char *part1, *part2;
+
+    if (!part1Ptr) {
+	part1Ptr = localName(iPtr->varFramePtr, index);
+    }
+    part1 = TclGetString(part1Ptr);
+    part2 = part2Ptr? TclGetString(part2Ptr) : NULL;
+    
+    return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg);
+}
+
+int
 TclCallVarTraces(
     Interp *iPtr,		/* Interpreter containing variable. */
     register Var *arrayPtr,	/* Pointer to array variable that contains the
@@ -2474,7 +2502,9 @@ TclCallVarTraces(
     int code = TCL_OK;
     int disposeFlags = 0;
     Tcl_InterpState state = NULL;
-
+    Tcl_HashEntry *hPtr;
+    int traceflags = flags & VAR_ALL_TRACES;
+    
     /*
      * If there are already similar trace functions active for the variable,
      * don't call them again.
@@ -2484,9 +2514,11 @@ TclCallVarTraces(
 	return code;
     }
     TclSetVarTraceActive(varPtr);
-    varPtr->refCount++;
-    if (arrayPtr != NULL) {
-	arrayPtr->refCount++;
+    if (TclIsVarInHash(varPtr)) {
+	VarHashRefCount(varPtr)++;
+    }
+    if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+	VarHashRefCount(arrayPtr)++;
     }
 
     /*
@@ -2538,10 +2570,12 @@ TclCallVarTraces(
     active.nextPtr = iPtr->activeVarTracePtr;
     iPtr->activeVarTracePtr = &active;
     Tcl_Preserve((ClientData) iPtr);
-    if (arrayPtr != NULL && !TclIsVarTraceActive(arrayPtr)) {
+    if (arrayPtr && !TclIsVarTraceActive(arrayPtr) && (arrayPtr->flags & traceflags)) {
+	hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+		(char *) arrayPtr);
 	active.varPtr = arrayPtr;
-	for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
-		tracePtr = active.nextTracePtr) {
+	for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+	     tracePtr != NULL; tracePtr = active.nextTracePtr) {
 	    active.nextTracePtr = tracePtr->nextPtr;
 	    if (!(tracePtr->flags & flags)) {
 		continue;
@@ -2582,36 +2616,40 @@ TclCallVarTraces(
 	flags |= TCL_TRACE_DESTROYED;
     }
     active.varPtr = varPtr;
-    for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
-	    tracePtr = active.nextTracePtr) {
-	active.nextTracePtr = tracePtr->nextPtr;
-	if (!(tracePtr->flags & flags)) {
-	    continue;
-	}
-	Tcl_Preserve((ClientData) tracePtr);
-	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) {
-	    if (flags & TCL_TRACE_UNSETS) {
-		/*
-		 * Ignore errors in unset traces.
-		 */
-
-		DisposeTraceResult(tracePtr->flags, result);
-	    } else {
-		disposeFlags = tracePtr->flags;
-		code = TCL_ERROR;
+    if (varPtr->flags & traceflags) {
+	hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+		(char *) varPtr);
+	for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+	     tracePtr != NULL; tracePtr = active.nextTracePtr) {
+	    active.nextTracePtr = tracePtr->nextPtr;
+	    if (!(tracePtr->flags & flags)) {
+		continue;
+	    }
+	    Tcl_Preserve((ClientData) tracePtr);
+	    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) {
+		if (flags & TCL_TRACE_UNSETS) {
+		    /*
+		     * Ignore errors in unset traces.
+		     */
+		    
+		    DisposeTraceResult(tracePtr->flags, result);
+		} else {
+		    disposeFlags = tracePtr->flags;
+		    code = TCL_ERROR;
+		}
+	    }
+	    Tcl_Release((ClientData) tracePtr);
+	    if (code == TCL_ERROR) {
+		goto done;
 	    }
-	}
-	Tcl_Release((ClientData) tracePtr);
-	if (code == TCL_ERROR) {
-	    goto done;
 	}
     }
 
@@ -2684,14 +2722,16 @@ TclCallVarTraces(
 	}
     }
 
-    if (arrayPtr != NULL) {
-	arrayPtr->refCount--;
+    if (arrayPtr && TclIsVarInHash(arrayPtr)) {
+	VarHashRefCount(arrayPtr)--;
     }
     if (copiedName) {
 	Tcl_DStringFree(&nameCopy);
     }
     TclClearVarTraceActive(varPtr);
-    varPtr->refCount--;
+    if (TclIsVarInHash(varPtr)) {
+	VarHashRefCount(varPtr)--;
+    }
     iPtr->activeVarTracePtr = active.nextPtr;
     Tcl_Release((ClientData) iPtr);
     return code;
@@ -2793,11 +2833,12 @@ Tcl_UntraceVar2(
     ClientData clientData)	/* Arbitrary argument to pass to proc. */
 {
     register VarTrace *tracePtr;
-    VarTrace *prevPtr;
+    VarTrace *prevPtr, *nextPtr;
     Var *varPtr, *arrayPtr;
     Interp *iPtr = (Interp *) interp;
     ActiveVarTrace *activePtr;
-    int flagMask;
+    int flagMask, allFlags = 0;
+    Tcl_HashEntry *hPtr;
 
     /*
      * Set up a mask to mask out the parts of the flags that we are not
@@ -2807,7 +2848,7 @@ Tcl_UntraceVar2(
     flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
     varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ NULL,
 	    /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-    if (varPtr == NULL) {
+    if (varPtr == NULL || !(varPtr->flags & VAR_ALL_TRACES & flags)) {
 	return;
     }
 
@@ -2822,15 +2863,19 @@ Tcl_UntraceVar2(
     flagMask |= TCL_TRACE_OLD_STYLE;
 #endif
     flags &= flagMask;
-    for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
+
+    hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+	    (char *) varPtr);
+    for (tracePtr = (VarTrace *) Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
 	    prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
 	if (tracePtr == NULL) {
-	    return;
+	    goto updateFlags;
 	}
 	if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
 		&& (tracePtr->clientData == clientData)) {
 	    break;
 	}
+	allFlags |= tracePtr->flags;
     }
 
     /*
@@ -2845,19 +2890,32 @@ Tcl_UntraceVar2(
 	    activePtr->nextTracePtr = tracePtr->nextPtr;
 	}
     }
+    nextPtr = tracePtr->nextPtr;
     if (prevPtr == NULL) {
-	varPtr->tracePtr = tracePtr->nextPtr;
+	if (nextPtr) {
+	    Tcl_SetHashValue(hPtr, nextPtr);
+	} else {
+	    Tcl_DeleteHashEntry(hPtr);
+	}
     } else {
-	prevPtr->nextPtr = tracePtr->nextPtr;
+	prevPtr->nextPtr = nextPtr;
     }
     Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
 
-    /*
-     * If this is the last trace on the variable, and the variable is unset
-     * and unused, then free up the variable.
-     */
-
-    if (TclIsVarUndefined(varPtr)) {
+    for (tracePtr = nextPtr; tracePtr != NULL;
+	    tracePtr = tracePtr->nextPtr) {
+	allFlags |= tracePtr->flags;
+    }
+    
+    updateFlags:
+    varPtr->flags &= ~VAR_ALL_TRACES;
+    if (allFlags & VAR_ALL_TRACES) {
+	varPtr->flags |= (allFlags & VAR_ALL_TRACES);
+    } else if (TclIsVarUndefined(varPtr)) {
+	/*
+	 * If this is the last trace on the variable, and the variable is
+	 * unset and unused, then free up the variable.
+	 */
 	TclCleanupVar(varPtr, NULL);
     }
 }
@@ -2934,8 +2992,10 @@ Tcl_VarTraceInfo2(
 				 * next trace after that one. If NULL, this
 				 * call will return the first trace. */
 {
+    Interp *iPtr = (Interp *) interp;
     register VarTrace *tracePtr;
     Var *varPtr, *arrayPtr;
+    Tcl_HashEntry *hPtr;
 
     varPtr = TclLookupVar(interp, part1, part2,
 	    flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ NULL,
@@ -2948,19 +3008,25 @@ Tcl_VarTraceInfo2(
      * Find the relevant trace, if any, and return its clientData.
      */
 
-    tracePtr = varPtr->tracePtr;
-    if (prevClientData != NULL) {
-	for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
-	    if ((tracePtr->clientData == prevClientData)
-		    && (tracePtr->traceProc == proc)) {
-		tracePtr = tracePtr->nextPtr;
-		break;
+    hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
+	    (char *) varPtr);
+
+    if (hPtr) {
+	tracePtr = Tcl_GetHashValue(hPtr);
+
+	if (prevClientData != NULL) {
+	    for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
+		if ((tracePtr->clientData == prevClientData)
+			&& (tracePtr->traceProc == proc)) {
+		    tracePtr = tracePtr->nextPtr;
+		    break;
+		}
 	    }
 	}
-    }
-    for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
-	if (tracePtr->traceProc == proc) {
-	    return tracePtr->clientData;
+	for (; tracePtr!=NULL ; tracePtr=tracePtr->nextPtr) {
+	    if (tracePtr->traceProc == proc) {
+		return tracePtr->clientData;
+	    }
 	}
     }
     return NULL;
@@ -2982,6 +3048,7 @@ Tcl_VarTraceInfo2(
  *	A trace is set up on the variable given by varName, such that future
  *	references to the variable will be intermediated by proc. See the
  *	manual entry for complete details on the calling sequence for proc.
+ *     The variable's flags are updated.
  *
  *----------------------------------------------------------------------
  */
@@ -3019,7 +3086,7 @@ Tcl_TraceVar(
  *	A trace is set up on the variable given by part1 and part2, such that
  *	future references to the variable will be intermediated by proc. See
  *	the manual entry for complete details on the calling sequence for
- *	proc.
+ *	proc. The variable's flags are updated.
  *
  *----------------------------------------------------------------------
  */
@@ -3092,8 +3159,11 @@ TraceVarEx(
 				 * caller to free if this function returns
 				 * TCL_ERROR. */
 {
+    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *arrayPtr;
     int flagMask;
+    Tcl_HashEntry *hPtr;
+    int new;
 
     /*
      * We strip 'flags' down to just the parts which are relevant to
@@ -3130,8 +3200,18 @@ TraceVarEx(
     flagMask |= TCL_TRACE_OLD_STYLE;
 #endif
     tracePtr->flags = tracePtr->flags & flagMask;
-    tracePtr->nextPtr = varPtr->tracePtr;
-    varPtr->tracePtr = tracePtr;
+
+    hPtr = Tcl_CreateHashEntry(&iPtr->varTraces,
+	    (char *) varPtr, &new);
+    if (new) {
+	tracePtr->nextPtr = NULL;
+    } else {
+	tracePtr->nextPtr = (VarTrace *) Tcl_GetHashValue(hPtr);
+    }
+    Tcl_SetHashValue(hPtr, (char *) tracePtr);
+
+    varPtr->flags |= (tracePtr->flags & VAR_ALL_TRACES);
+
     return TCL_OK;
 }