Rework test bind-35.1 and simplify it a bit, make it fail in core-8-6-branch that does not have the fix yet.

3 files changed, 22 insertions, 106 deletions

diff --git a/generic/tkTest.c b/generic/tkTest.c
index 1f373ad..a8929b9 100644
--- a/generic/tkTest.c
+++ b/generic/tkTest.c
@@ -206,9 +206,6 @@ static int		TrivialConfigObjCmd(ClientData dummy,
 			    Tcl_Obj * const objv[]);
 static void		TrivialEventProc(ClientData clientData,
 			    XEvent *eventPtr);
-static int		TestgrabObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const objv[]);
 
 /*
  *----------------------------------------------------------------------
@@ -284,9 +281,6 @@ Tktest_Init(
 	    (ClientData) Tk_MainWindow(interp), NULL);
 #endif /* _WIN32 */
 
-    Tcl_CreateObjCommand(interp, "testgrab", TestgrabObjCmd,
-	    (ClientData) Tk_MainWindow(interp), NULL);
-
     /*
      * Create test image type.
      */
@@ -2084,78 +2078,6 @@ CustomOptionFree(
 }
 
 /*
- *----------------------------------------------------------------------
- *
- * TestgrabObjCmd --
- *
- *	This function implements the "testgrab" command, which is used to test
- *	grabbing of windows.
- *
- *	testgrab grabbed  $win: returns true if $win is currently grabbed
- *	testgrab released $win: returns true if $win is currently not grabbed
- *
- *	This function is useful when one wants to test for a grabbing window
- *	at the moment it is called. [grab current] cannot be used for that
- *	purpose because it returns the window dereferenced by eventualGrabWinPtr
- *
- * Results:
- *	A standard Tcl result.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TestgrabObjCmd(
-    ClientData clientData,	/* Main window for application. */
-    Tcl_Interp *interp,		/* Current interpreter. */
-    int objc,			/* Number of arguments. */
-    Tcl_Obj *const objv[])	/* Argument objects. */
-{
-    static const char *const options[] = {"grabbed", "released", NULL};
-    enum option {GRABBED, RELEASED};
-    int index, res = 0;
-    Tk_Window mainWin, tkwin;
-
-    mainWin = (Tk_Window) clientData;
-
-    if (objc < 3) {
-	Tcl_WrongNumArgs(interp, 1, objv, "option window");
-	return TCL_ERROR;
-    }
-
-    if (Tcl_GetIndexFromObjStruct(interp, objv[1], options,
-	    sizeof(char *), "command", 0, &index)!= TCL_OK) {
-	return TCL_ERROR;
-    }
-
-    tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), mainWin);
-    if (tkwin == NULL) {
-        return TCL_ERROR;
-    }
-    /*printf("TestgrabObjCmd %s, grabWinPtr = %p , tkwin = %p\n", options[index],
-            ((TkWindow *) tkwin)->dispPtr->grabWinPtr, tkwin);fflush(stdout);*/
-
-    switch ((enum option) index) {
-    case GRABBED:
-        if (TkGrabState((TkWindow *) tkwin) != TK_GRAB_NONE) {
-            res = 1;
-        }
-	break;
-    case RELEASED:
-        if (TkGrabState((TkWindow *) tkwin) == TK_GRAB_NONE) {
-            res = 1;
-        }
-	break;
-    }
-
-    Tcl_SetObjResult(interp, Tcl_NewBooleanObj(res));
-    return TCL_OK;
-}
-
-/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/tests/bind.test b/tests/bind.test
index e333c6c..33183ca 100644
--- a/tests/bind.test
+++ b/tests/bind.test
@@ -36,12 +36,22 @@ proc unsetBindings {} {
 
 # move the mouse pointer away of the testing area
 # otherwise some spurious events may pollute the tests
-toplevel .top
-wm geometry .top 50x50-50-50
-update
-event generate .top <Button-1> -warp 1
-update
-destroy .top
+# also, this will procure a known grab state at startup
+# for tests mixing grabs and pointer warps
+proc pointerAway {} {
+    toplevel .top
+    wm geometry .top 50x50-50-50
+    update
+    # On KDE/Plasma _with_the_Aurorae_theme_ (at least), setting up the toplevel
+    # will not be finished right after the above 'update'. The WM still
+    # needs some time before the window is fully ready. For me 50 ms is enough,
+    # but let's wait more (it depends on computer performance).
+    after 100 ; update
+    event generate .top <Button-1> -warp 1
+    update
+    destroy .top
+}
+pointerAway
 
 test bind-1.1 {bind command} -body {
     bind
@@ -6709,26 +6719,10 @@ test bind-34.3 {-warp works with null or negative coordinates} -setup {
 } -cleanup {
 } -result {ok ok ok ok}
 
-test bind-35.1 {pointer warp with grab on master, bug [e3888d5820]} -constraints {
-    testgrab
-} -setup {
-    proc waitForGrab {type grabWin} {
-    # process events while $grabWin is not grabbed ($type == "grabbed"),
-    # or while $grabWin is not released ($type == "released"), but don't
-    # spend more than 5 seconds doing this
-        set i 0
-        while {![testgrab $type $grabWin] && $i < 500} {
-            after 10
-            update
-            incr i
-        }
-    }
-    event generate {} <Motion> -warp 1 -x 50 -y 50
-    update idletasks ; # DoWarp is an idle callback
-    after 50         ; # Win specific - wait for SendInput to be executed
+test bind-35.1 {pointer warp with grab on master, bug [e3888d5820]} -setup {
+    pointerAway
     toplevel .top
     grab release .top
-    waitForGrab released .top
     wm geometry .top 200x200+300+300
     label .top.l -height 5 -width 20 -highlightthickness 2 \
             -highlightbackground black -bg yellow -text "My label"
@@ -6741,14 +6735,16 @@ test bind-35.1 {pointer warp with grab on master, bug [e3888d5820]} -constraints
     after 100 ; update
 } -body {
     grab .top  ; # this will queue events
-    waitForGrab grabbed .top
+    after 50
+    update
     event generate .top.l <Motion> -warp 1 -x 10 -y 10
     update idletasks ; after 50
     foreach {x1 y1} [winfo pointerxy .top.l] {}
     event generate {} <Motion> -warp 1 -x 50 -y 50
     update idletasks ; after 50
     grab release .top  ; # this will queue events
-    waitForGrab released .top
+    after 50
+    update
     event generate .top.l <Motion> -warp 1 -x 10 -y 10
     update idletasks ; after 50
     foreach {x2 y2} [winfo pointerxy .top.l] {}
@@ -6759,7 +6755,6 @@ test bind-35.1 {pointer warp with grab on master, bug [e3888d5820]} -constraints
 } -cleanup {
     destroy .top
     unset x1 y1 x2 y2
-    rename waitForGrab {}
 } -result {1}
 
 # cleanup
diff --git a/tests/constraints.tcl b/tests/constraints.tcl
index 49da142..c77fb00 100644
--- a/tests/constraints.tcl
+++ b/tests/constraints.tcl
@@ -207,7 +207,6 @@ testConstraint testcolor     [llength [info commands testcolor]]
 testConstraint testcursor    [llength [info commands testcursor]]
 testConstraint testembed     [llength [info commands testembed]]
 testConstraint testfont      [llength [info commands testfont]]
-testConstraint testgrab      [llength [info commands testgrab]]
 testConstraint testmakeexist [llength [info commands testmakeexist]]
 testConstraint testmenubar   [llength [info commands testmenubar]]
 testConstraint testmetrics   [llength [info commands testmetrics]]