TIP#165 (user data field) implementation.

7 files changed, 170 insertions, 31 deletions

diff --git a/ChangeLog b/ChangeLog
index 4d72ae2..41fe711 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2004-08-29  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
+
+	TIP#165 IMPLEMENTATION
+
+	* generic/tk.h (XVirtualEvent): Added user_data field to
+	structure.
+	* generic/tkBind.c (ExpandPercents, HandleEventGenerate): 
+	* generic/tkEvent.c (Tk_HandleEvent): Handle putting data into the
+	user_data field, passing it to scripts as %d substitution, and
+	releasing the field's contents once the event has been processed.
+	* doc/bind.n, doc/event.n, tests/bind.test: Docs + tests.
+
 2004-08-26  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* library/text.tcl (::tk::TextTranspose): Ensure that Transpose is
diff --git a/doc/bind.n b/doc/bind.n
index d89c601..2c51fd5 100644
--- a/doc/bind.n
+++ b/doc/bind.n
@@ -6,7 +6,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: bind.n,v 1.16 2004/08/20 10:56:36 dkf Exp $
+'\" RCS: @(#) $Id: bind.n,v 1.17 2004/08/29 09:27:35 dkf Exp $
 '\" 
 .so man.macros
 .TH bind n 8.0 Tk "Tk Built-In Commands"
@@ -85,7 +85,6 @@ a particular button or keysym.  Any of the fields may be omitted,
 as long as at least one of \fItype\fR and \fIdetail\fR is present.
 The fields must be separated by white space or dashes.
 .PP
-.VS
 The third form of pattern is used to specify a user-defined, named virtual
 event.  It has the following syntax:
 .CS
@@ -98,11 +97,10 @@ virtual event to modify it.  Bindings on a virtual event may be created
 before the virtual event is defined, and if the definition of a virtual
 event changes dynamically, all windows bound to that virtual event will
 respond immediately to the new definition.  
-
+.PP
 Some widgets (e.g. \fBmenu\fR and \fBtext\fR) issue virtual events
 when their internal state is updated in some ways.  Please see the
 manual page for each widget for details.
-.VE
 .SS "MODIFIERS"
 .PP
 Modifiers consist of any of the following values:
@@ -407,7 +405,11 @@ The \fIcount\fR field from the event.  Valid only for \fBExpose\fR events.
 Indicates that there are \fIcount\fP pending \fBExpose\fP events which have not
 yet been delivered to the window.
 .IP \fB%d\fR 5
-The \fIdetail\fR field from the event.  The \fB%d\fR is replaced by
+The \fIdetail\fR
+.VS 8.5
+or \fIuser_data\fR
+.VE 8.5
+field from the event.  The \fB%d\fR is replaced by
 a string identifying the detail.  For \fBEnter\fR,
 \fBLeave\fR, \fBFocusIn\fR, and \fBFocusOut\fR events,
 the string will be one of the following:
@@ -426,6 +428,13 @@ For \fBConfigureRequest\fR events, the string will be one of:
 Below	None
 BottomIf	TopIf\fR
 .DE
+.VS
+For virtual events, the string will be whatever value is stored in the
+\fIuser_data\fR field when the event was created (typically with
+\fBevent generate\fR), or the empty string if the field is NULL.
+Virtual events corresponding to key sequence presses (see \fBevent
+add\fR for details) set the \fIuser_data\fR to NULL.
+.VE
 For events other than these, the substituted string is undefined.
 .RE
 .IP \fB%f\fR 5
diff --git a/doc/event.n b/doc/event.n
index c74b483..6b988bb 100644
--- a/doc/event.n
+++ b/doc/event.n
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: event.n,v 1.9 2004/08/20 10:56:36 dkf Exp $
+'\" RCS: @(#) $Id: event.n,v 1.10 2004/08/29 09:27:35 dkf Exp $
 '\" 
 .so man.macros
 .TH event n 8.3 Tk "Tk Built-In Commands"
@@ -107,6 +107,13 @@ Corresponds to the \fB%b\fR substitution for binding scripts.
 \fINumber\fR must be an integer;  it specifies the \fIcount\fR field
 for the event.  Valid for \fBExpose\fR events.
 Corresponds to the \fB%c\fR substitution for binding scripts.
+.VS 8.5
+.TP
+\fB\-data\fI string\fR
+\fIString\fR may be any value; it specifies the \fIuser_data\fR field
+for the event.  Only valid for virtual events.  Corresponds to the
+\fB%d\fR substitution for virtual events in binding scripts.
+.VE 8.5
 .TP
 \fB\-delta\fI number\fR
 \fINumber\fR must be an integer;  it specifies the \fIdelta\fR field
diff --git a/generic/tk.h b/generic/tk.h
index 2ba5439..142f79a 100644
--- a/generic/tk.h
+++ b/generic/tk.h
@@ -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: tk.h,v 1.80 2004/03/26 19:57:34 dgp Exp $
+ * RCS: @(#) $Id: tk.h,v 1.81 2004/08/29 09:27:35 dkf Exp $
  */
 
 #ifndef _TK
@@ -681,6 +681,9 @@ typedef struct {
     unsigned int state;	    /* key or button mask */
     Tk_Uid name;	    /* Name of virtual event. */
     Bool same_screen;	    /* same screen flag */
+    Tcl_Obj *user_data;     /* application-specific data reference; Tk will
+			     * decrement the reference count *once* when it
+			     * has finished processing the event. */
 } XVirtualEvent;
 
 typedef struct {
diff --git a/generic/tkBind.c b/generic/tkBind.c
index 03453c8..c8a5b78 100644
--- a/generic/tkBind.c
+++ b/generic/tkBind.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: tkBind.c,v 1.34 2004/07/05 21:21:52 dkf Exp $
+ *  RCS: @(#) $Id: tkBind.c,v 1.35 2004/08/29 09:27:35 dkf Exp $
  */
 
 #include "tkPort.h"
@@ -2392,6 +2392,14 @@ ExpandPercents(winPtr, before, eventPtr, keySym, dsPtr)
 		    } else {
 			string = "";
 		    }
+		} else if (flags & VIRTUAL) {
+		    XVirtualEvent *vePtr = (XVirtualEvent *) eventPtr;
+
+		    if (vePtr->user_data != NULL) {
+			string = Tcl_GetString(vePtr->user_data);
+		    } else {
+			string = "";
+		    }
 		}
 		goto doString;
 	    case 'f':
@@ -3323,10 +3331,11 @@ HandleEventGenerate(interp, mainWin, objc, objv)
     Tk_Window tkwin, tkwin2;
     TkWindow *mainPtr;
     unsigned long eventMask;
+    Tcl_Obj *userDataObj;
     static CONST char *fieldStrings[] = {
 	"-when",	"-above",	"-borderwidth",	"-button",
-	"-count",	"-delta",	"-detail",	"-focus",
-	"-height",
+	"-count",	"-data",	"-delta",	"-detail",
+	"-focus",	"-height",
 	"-keycode",	"-keysym",	"-mode",	"-override",
 	"-place",	"-root",	"-rootx",	"-rooty",
 	"-sendevent",	"-serial",	"-state",	"-subwindow",
@@ -3335,8 +3344,8 @@ HandleEventGenerate(interp, mainWin, objc, objv)
     };
     enum field {
 	EVENT_WHEN,	EVENT_ABOVE,	EVENT_BORDER,	EVENT_BUTTON,
-	EVENT_COUNT,	EVENT_DELTA,	EVENT_DETAIL,	EVENT_FOCUS,
-	EVENT_HEIGHT,
+	EVENT_COUNT,	EVENT_DATA,	EVENT_DELTA,	EVENT_DETAIL,
+	EVENT_FOCUS,	EVENT_HEIGHT,
 	EVENT_KEYCODE,	EVENT_KEYSYM,	EVENT_MODE,	EVENT_OVERRIDE,
 	EVENT_PLACE,	EVENT_ROOT,	EVENT_ROOTX,	EVENT_ROOTY,
 	EVENT_SEND,	EVENT_SERIAL,	EVENT_STATE,	EVENT_SUBWINDOW,
@@ -3366,6 +3375,7 @@ HandleEventGenerate(interp, mainWin, objc, objv)
 
     p = name;
     eventMask = 0;
+    userDataObj = NULL;
     count = ParseEventDescription(interp, &p, &pat, &eventMask);
     if (count == 0) {
 	return TCL_ERROR;
@@ -3519,6 +3529,18 @@ HandleEventGenerate(interp, mainWin, objc, objv)
 		}
 		break;
 	    }
+	    case EVENT_DATA:
+		if (flags & VIRTUAL) {
+		    /*
+		     * Do not increment reference count until after
+		     * parsing completes and we know that the event
+		     * generation is really going to happen.
+		     */
+		    userDataObj = valuePtr;
+		} else {
+		    goto badopt;
+		}
+		break;
 	    case EVENT_DELTA: {
 		if (Tcl_GetIntFromObj(interp, valuePtr, &number) != TCL_OK) {
 		    return TCL_ERROR;
@@ -3846,6 +3868,19 @@ HandleEventGenerate(interp, mainWin, objc, objv)
 		Tcl_GetStringFromObj(optionPtr, NULL), "\" option", NULL);
 	return TCL_ERROR;
     }
+    if (userDataObj != NULL) {
+	XVirtualEvent *vePtr = (XVirtualEvent *) &event;
+
+	/*
+	 * Must be virtual event to set that variable to non-NULL.
+	 * Now we want to install the object into the event.  Note
+	 * that we must incr the refcount before firing it into the
+	 * low-level event subsystem; the refcount will be decremented
+	 * once the event has been processed.
+	 */
+	vePtr->user_data = userDataObj;
+	Tcl_IncrRefCount(userDataObj);
+    }
     if (synch != 0) {
 	Tk_HandleEvent(&event);
     } else {
diff --git a/generic/tkEvent.c b/generic/tkEvent.c
index ad9e29a..3b4b5a1 100644
--- a/generic/tkEvent.c
+++ b/generic/tkEvent.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: tkEvent.c,v 1.24 2004/07/29 21:48:07 georgeps Exp $
+ * RCS: @(#) $Id: tkEvent.c,v 1.25 2004/08/29 09:27:35 dkf Exp $
  */
 
 #include "tkPort.h"
@@ -1281,7 +1281,7 @@ Tk_HandleEvent(eventPtr)
     Tcl_Interp *interp = (Tcl_Interp *) NULL;
 
     ThreadSpecificData *tsdPtr = (ThreadSpecificData *) 
-	Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
+	    Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
 
   
     UpdateButtonEventState (eventPtr);
@@ -1291,21 +1291,21 @@ Tk_HandleEvent(eventPtr)
      * and can return.
      */
     if (InvokeGenericHandlers (tsdPtr, eventPtr)) {
-        return;
+	goto releaseUserData;
     }
     
     if (RefreshKeyboardMappingIfNeeded (eventPtr)) {
-        /*
+	/*
 	 * We are done with a MappingNotify event.
 	 */
-        return;
+	goto releaseUserData;
     }
 
     mask = GetEventMaskFromXEvent(eventPtr);
     winPtr = GetTkWindowFromXEvent(eventPtr);
 
     if (winPtr == NULL) {
-        return;
+	goto releaseUserData;
     }
 
     /*
@@ -1319,7 +1319,7 @@ Tk_HandleEvent(eventPtr)
 
     if ((winPtr->flags & TK_ALREADY_DEAD)
 	    && (eventPtr->type != DestroyNotify)) {
-	return;
+	goto releaseUserData;
     }
 
     if (winPtr->mainPtr != NULL) {
@@ -1328,24 +1328,24 @@ Tk_HandleEvent(eventPtr)
 	interp = winPtr->mainPtr->interp;
 
 	/*
-         * Protect interpreter for this window from possible deletion
-         * while we are dealing with the event for this window. Thus,
-         * widget writers do not have to worry about protecting the
-         * interpreter in their own code.
-         */
+	 * Protect interpreter for this window from possible deletion
+	 * while we are dealing with the event for this window. Thus,
+	 * widget writers do not have to worry about protecting the
+	 * interpreter in their own code.
+	 */
 	Tcl_Preserve((ClientData) interp);
 
 	result = ((InvokeFocusHandlers(&winPtr, mask, eventPtr)) 
-	   || (InvokeMouseHandlers(winPtr, mask, eventPtr)));
+		|| (InvokeMouseHandlers(winPtr, mask, eventPtr)));
 
 	if (result) {
-	    goto done;
+	    goto releaseInterpreter;
 	}
     }
 
 #ifdef TK_USE_INPUT_METHODS
     if (InvokeInputMethods(winPtr, eventPtr)) {
-	goto done;
+	goto releaseInterpreter;
     }
 #endif
     /*
@@ -1377,7 +1377,7 @@ Tk_HandleEvent(eventPtr)
 		    Tk_InternAtom((Tk_Window) winPtr, "WM_PROTOCOLS")) {
 		TkWmProtocolEventProc(winPtr, eventPtr);
 	    } else {
-       	        InvokeClientMessageHandlers(tsdPtr, (Tk_Window)winPtr, eventPtr);
+		InvokeClientMessageHandlers(tsdPtr, (Tk_Window)winPtr, eventPtr);
 	    }
 	}
     } else {
@@ -1410,15 +1410,32 @@ Tk_HandleEvent(eventPtr)
 	}
     }
     tsdPtr->pendingPtr = ip.nextPtr;
-done:
 
     /*
      * Release the interpreter for this window so that it can be potentially
      * deleted if requested.
      */
     
+releaseInterpreter:
     if (interp != (Tcl_Interp *) NULL) {
-        Tcl_Release((ClientData) interp);
+	Tcl_Release((ClientData) interp);
+    }
+
+    /*
+     * Release the user_data from the event (if it is a virtual event
+     * and the field was non-NULL in the first place.)  Note that this
+     * is done using a Tcl_Obj interface, and we set the field back to
+     * NULL afterwards out of paranoia.
+     */
+
+releaseUserData:
+    if (eventPtr->type == VirtualEvent) {
+	XVirtualEvent *vePtr = (XVirtualEvent *) eventPtr;
+
+	if (vePtr->user_data != NULL) {
+	    Tcl_DecrRefCount(vePtr->user_data);
+	    vePtr->user_data = NULL;
+	}
     }
 }
 
diff --git a/tests/bind.test b/tests/bind.test
index 6bf6160..786e79a 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -7,7 +7,7 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: bind.test,v 1.15 2004/07/05 21:21:53 dkf Exp $
+# RCS: @(#) $Id: bind.test,v 1.16 2004/08/29 09:27:35 dkf Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
@@ -2696,8 +2696,64 @@ test bind-31.3 {MouseWheel events} {
     set x
 } {240 10 30}
 
+test bind-32.1 {virtual event user_data field - bad generation} {
+    setup
+    # Check no confusion, since Focus events use %d for something else
+    list [catch {event gen .b.f <FocusIn> -data foo} msg] $msg
+} {1 {<FocusIn> event doesn't accept "-data" option}}
+test bind-32.2 {virtual event user_data field - NULL, synch} {
+    setup
+    set x {}
+    bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
+    event gen .b.f <<TestUserData>>
+    set x
+} {TestUserData >{}<}
+test bind-32.3 {virtual event user_data field - shared, synch} {
+    setup
+    set x {}
+    bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
+    event gen .b.f <<TestUserData>> -data "foo bar"
+    set x
+} {TestUserData >foo bar<}
+test bind-32.4 {virtual event user_data field - unshared, synch} {
+    setup
+    set x {}
+    bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
+    event gen .b.f <<TestUserData>> -data [string index abc 1]
+    set x
+} {TestUserData >b<}
+# Note that asynch event handling can only really catch any potential
+# extra errors when used in combination with a tool like Purify or
+# Valgrind. Such testing is rarely done, but at least any problem with
+# reference handling will eventually show up with these tests...
+test bind-32.5 {virtual event user_data field - NULL, asynch} {
+    setup
+    set x {}
+    bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
+    event gen .b.f <<TestUserData>> -when head
+    list $x [update] $x
+} {{} {} {TestUserData >{}<}}
+test bind-32.6 {virtual event user_data field - shared, asynch} {
+    setup
+    set x {}
+    bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
+    event gen .b.f <<TestUserData>> -data "foo bar" -when head
+    list $x [update] $x
+} {{} {} {TestUserData >foo bar<}}
+test bind-32.7 {virtual event user_data field - unshared, asynch} {
+    setup
+    set x {}
+    bind .b.f <<TestUserData>> {set x "TestUserData >%d<"}
+    event gen .b.f <<TestUserData>> -data [string index abc 1] -when head
+    list $x [update] $x
+} {{} {} {TestUserData >b<}}
+
 destroy .b
 
 # cleanup
 cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End: