summaryrefslogtreecommitdiffstats
path: root/generic/tclTrace.c
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2007-07-31 17:03:34 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2007-07-31 17:03:34 (GMT)
commitc78aef8e3103f916ede55e36edd8f5fb876ab0f6 (patch)
tree6bef95f9839cbc6e08ab7040bd9bbd6c9925a5f8 /generic/tclTrace.c
parent4de8702e9bdf3ad59efdba5918502f6b9f23c827 (diff)
downloadtcl-c78aef8e3103f916ede55e36edd8f5fb876ab0f6.zip
tcl-c78aef8e3103f916ede55e36edd8f5fb876ab0f6.tar.gz
tcl-c78aef8e3103f916ede55e36edd8f5fb876ab0f6.tar.bz2
VarReform [Patch 1750051]
*** POTENTIAL INCOMPATIBILITY *** (tclInt.h and tclCompile.h)
Diffstat (limited to 'generic/tclTrace.c')
-rw-r--r--generic/tclTrace.c218
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;
}