Import Tk 8.5.15 (as of svn r89086)

generic/ttk/ttkTrace.c

@@ -0,0 +1,190 @@
+/*
+ * Copyright 2003, Joe English
+ *
+ * Simplified interface to Tcl_TraceVariable.
+ *
+ * PROBLEM: Can't distinguish "variable does not exist" (which is OK) 
+ * from other errors (which are not).
+ */
+
+#include <tk.h>
+#include "ttkTheme.h"
+#include "ttkWidget.h"
+
+struct TtkTraceHandle_
+{
+    Tcl_Interp		*interp;	/* Containing interpreter */
+    Tcl_Obj 		*varnameObj;	/* Name of variable being traced */
+    Ttk_TraceProc	callback;	/* Callback procedure */
+    void		*clientData;	/* Data to pass to callback */
+};
+
+/*
+ * Tcl_VarTraceProc for trace handles.
+ */
+static char *
+VarTraceProc(
+    ClientData clientData,	/* Widget record pointer */
+    Tcl_Interp *interp, 	/* Interpreter containing variable. */
+    const char *name1,		/* (unused) */
+    const char *name2,		/* (unused) */
+    int flags)			/* Information about what happened. */
+{
+    Ttk_TraceHandle *tracePtr = clientData;
+    const char *name, *value;
+    Tcl_Obj *valuePtr;
+
+    if (flags & TCL_INTERP_DESTROYED) {
+	return NULL;
+    }
+
+    name = Tcl_GetString(tracePtr->varnameObj);
+
+    /*
+     * If the variable is being unset, then re-establish the trace:
+     */
+    if (flags & TCL_TRACE_DESTROYED) {
+	/*
+	 * If a prior call to Ttk_UntraceVariable() left behind an
+	 * indicator that we wanted this handler to be deleted (see below),
+	 * cleanup the ClientData bits and exit.
+	 */
+	if (tracePtr->interp == NULL) {
+	    Tcl_DecrRefCount(tracePtr->varnameObj);
+	    ckfree((ClientData)tracePtr);
+	    return NULL;
+	}
+	Tcl_TraceVar(interp, name,
+		TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+		VarTraceProc, clientData);
+	tracePtr->callback(tracePtr->clientData, NULL);
+	return NULL;
+    }
+
+    /*
+     * Call the callback:
+     */
+    valuePtr = Tcl_GetVar2Ex(interp, name, NULL, TCL_GLOBAL_ONLY);
+    value = valuePtr ?  Tcl_GetString(valuePtr) : NULL;
+    tracePtr->callback(tracePtr->clientData, value);
+
+    return NULL;
+}
+
+/* Ttk_TraceVariable(interp, varNameObj, callback, clientdata) --
+ * 	Attach a write trace to the specified variable,
+ * 	which will pass the variable's value to 'callback'
+ * 	whenever the variable is set.
+ *
+ * 	When the variable is unset, passes NULL to the callback
+ * 	and reattaches the trace.
+ */
+Ttk_TraceHandle *Ttk_TraceVariable(
+    Tcl_Interp *interp,
+    Tcl_Obj *varnameObj,
+    Ttk_TraceProc callback,
+    void *clientData)
+{
+    Ttk_TraceHandle *h = (Ttk_TraceHandle*)ckalloc(sizeof(*h));
+    int status;
+
+    h->interp = interp;
+    h->varnameObj = Tcl_DuplicateObj(varnameObj);
+    Tcl_IncrRefCount(h->varnameObj);
+    h->clientData = clientData;
+    h->callback = callback;
+
+    status = Tcl_TraceVar(interp, Tcl_GetString(varnameObj),
+	    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+	    VarTraceProc, (ClientData)h);
+
+    if (status != TCL_OK) {
+	Tcl_DecrRefCount(h->varnameObj);
+	ckfree((ClientData)h);
+	return NULL;
+    }
+
+    return h;
+}
+
+/*
+ * Ttk_UntraceVariable --
+ * 	Remove previously-registered trace and free the handle.
+ */
+void Ttk_UntraceVariable(Ttk_TraceHandle *h)
+{
+    if (h) {
+	ClientData cd = NULL;
+
+	/*
+	 * Workaround for Tcl Bug 3062331.  The trace design problem is
+	 * that when variable unset traces fire, Tcl documents that the
+	 * traced variable has already been unset.  It's already gone.
+	 * So from within an unset trace, if you try to call
+	 * Tcl_UntraceVar() on that variable, it will do nothing, because
+	 * the variable by that name can no longer be found.  It's gone.
+	 * This means callers of Tcl_UntraceVar() that might be running
+	 * in response to an unset trace have to handle the possibility
+	 * that their Tcl_UntraceVar() call will do nothing.  In this case,
+	 * we have to support the possibility that Tcl_UntraceVar() will
+	 * leave the trace in place, so we need to leave the ClientData
+	 * untouched so when that trace does fire it will not crash.
+	 */
+
+	/*
+	 * Search the traces on the variable to see if the one we are tasked
+	 * with removing is present.
+	 */
+	while ((cd = Tcl_VarTraceInfo(h->interp, Tcl_GetString(h->varnameObj),
+		TCL_GLOBAL_ONLY, VarTraceProc, cd)) != NULL) {
+	    if (cd == (ClientData) h) {
+		break;
+	    }
+	}
+	/*
+	 * If the trace we wish to delete is not visible, Tcl_UntraceVar
+	 * will do nothing, so don't try to call it.  Instead set an
+	 * indicator in the Ttk_TraceHandle that we need to cleanup later.
+	 */
+	if (cd == NULL) {
+	    h->interp = NULL;
+	    return;
+	}
+	Tcl_UntraceVar(h->interp, Tcl_GetString(h->varnameObj),
+		TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+		VarTraceProc, (ClientData)h);
+	Tcl_DecrRefCount(h->varnameObj);
+	ckfree((ClientData)h);
+    }
+}
+
+/*
+ * Ttk_FireTrace --
+ * 	Executes a trace handle as if the variable has been written.
+ *
+ * 	Note: may reenter the interpreter.
+ */
+int Ttk_FireTrace(Ttk_TraceHandle *tracePtr)
+{
+    Tcl_Interp *interp = tracePtr->interp;
+    void *clientData = tracePtr->clientData;
+    const char *name = Tcl_GetString(tracePtr->varnameObj);
+    Ttk_TraceProc callback = tracePtr->callback;
+    Tcl_Obj *valuePtr;
+    const char *value;
+
+    /* Read the variable.
+     * Note that this can reenter the interpreter, and anything can happen --
+     * including the current trace handle being freed!
+     */
+    valuePtr = Tcl_GetVar2Ex(interp, name, NULL, TCL_GLOBAL_ONLY);
+    value = valuePtr ? Tcl_GetString(valuePtr) : NULL;
+
+    /* Call callback.
+     */
+    callback(clientData, value);
+
+    return TCL_OK;
+}
+
+/*EOF*/