From b39986a99d587498f5ba40e71cddf6ea0360b89f Mon Sep 17 00:00:00 2001 From: culler Date: Wed, 29 May 2024 16:18:42 +0000 Subject: Add a simple version of the processevents test command and use it for the event-9* tests. --- generic/tkTest.c | 46 ++++++++++++++++++++++++++++++ tests/event.test | 85 ++++++++++++++++++++++++++++++-------------------------- 2 files changed, 91 insertions(+), 40 deletions(-) diff --git a/generic/tkTest.c b/generic/tkTest.c index 755a6be..4fc6a80 100644 --- a/generic/tkTest.c +++ b/generic/tkTest.c @@ -147,6 +147,9 @@ typedef struct TrivialCommandHeader { static int ImageObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[]); +static int ProcessEventsObjCmd(ClientData dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj * const objv[]); static int TestbitmapObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[]); @@ -247,6 +250,7 @@ Tktest_Init( return TCL_ERROR; } + Tcl_CreateObjCommand(interp, "processevents", ProcessEventsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "square", SquareObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbitmap", TestbitmapObjCmd, (ClientData) Tk_MainWindow(interp), NULL); @@ -1682,6 +1686,48 @@ ImageDelete( /* *---------------------------------------------------------------------- * + * ProcessEventsObjCmd -- + * + * This function implements the "processevents" command. Currently + * It processes all or events on the queue. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Events are processed + * + *---------------------------------------------------------------------- + */ + +static Tk_RestrictAction +CrossingRestrictProc( + ClientData arg, + XEvent *eventPtr) +{ + if (eventPtr->type == EnterNotify || eventPtr->type == LeaveNotify) { + return TK_PROCESS_EVENT; + } + return TK_DEFER_EVENT; +} + +static int ProcessEventsObjCmd(ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[]) +{ + ClientData oldArg; + Tk_RestrictProc *oldProc; + int count = 0; + oldProc = Tk_RestrictEvents(CrossingRestrictProc, NULL, &oldArg); + while (Tcl_ServiceEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT)) {}; + Tk_RestrictEvents(oldProc, oldArg, &oldArg); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestmakeexistObjCmd -- * * This function implements the "testmakeexist" command. It calls diff --git a/tests/event.test b/tests/event.test index 7fcdab3..10dcf07 100644 --- a/tests/event.test +++ b/tests/event.test @@ -929,13 +929,13 @@ test event-9.11 {pointer window container = parent} -setup { create_and_pack_frames .one wm deiconify .one tkwait visibility .one.f1.f2 - _pause 200 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} + update; # finish display of window set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .one.f1.f2 - _pause 200; # service crossing events + processevents end set result } -cleanup { bind all {} @@ -953,13 +953,13 @@ test event-9.12 {pointer window container != parent} -setup { wm deiconify .one tkwait visibility .one.g event generate .one -warp 1 -x 250 -y 250 - _pause 200 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} + update; # finish mouse warp set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .one.g - _pause 200; # service crossing events -- crashes without this + processevents end set result } -cleanup { bind all {} @@ -975,18 +975,19 @@ test event-9.13 {pointer window is a toplevel, toplevel destination} -setup { wm withdraw .two wm deiconify .two waitForWindowEvent .two - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} + update; # finish displaying windows set result | } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .two waitForWindowEvent .one - # destroying .one here instead of in cleanup makes the test pass - destroy .one + processevents end set result } -cleanup { bind all {} bind all {} + destroy .one unset result } -result {| NotifyNonlinear .one|} @@ -1000,17 +1001,18 @@ test event-9.14 {pointer window is a toplevel, tk internal destination} -setup { wm deiconify .one wm deiconify .two waitForWindowEvent .two - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .two waitForWindowEvent .one.f1.f2 + processevents end + set result +} -cleanup { bind all {} bind all {} destroy .one - set result -} -cleanup { unset result } -result {| NotifyNonlinearVirtual .one| NotifyNonlinearVirtual .one.f1| NotifyNonlinear .one.f1.f2|} @@ -1022,12 +1024,12 @@ test event-9.15 {pointer window is a toplevel, destination is screen root} -setu waitForWindowEvent .two event generate .two -warp 1 -x 275 -y 275 controlPointerWarpTiming - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} set result "|" } -body { - _pause 200; # ensure servicing of all scheduled events (only events expected) + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .two + processevents end set result } -cleanup { bind all {} @@ -1044,13 +1046,13 @@ test event-9.16 {Successive destructions (pointer window + parent), single gener create_and_pack_frames .one wm deiconify .one tkwait visibility .one.f1.f2 - _pause 200 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} + update; # finish displaying window set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .one.f1 - _pause 200; # service crossing events + processevents end set result } -cleanup { bind all {} @@ -1067,15 +1069,16 @@ test event-9.17 {Successive destructions (pointer window + parent), separate cro create_and_pack_frames .one wm deiconify .one tkwait visibility .one.f1.f2 - _pause 200 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} + update; # finish displaying window set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .one.f1.f2 - _pause 200; # service crossing events + update; # make sure window is gone destroy .one.f1 - _pause 200; # service crossing events + update; # make sure window is gone + processevents end set result } -cleanup { bind all {} @@ -1092,17 +1095,18 @@ test event-9.18 {Successive destructions (pointer window + ancestors including i create_and_pack_frames .two wm deiconify .two waitForWindowEvent .two.f1.f2 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .two waitForWindowEvent .one + processevents end + set result +} -cleanup { bind all {} bind all {} destroy .one - set result -} -cleanup { unset result } -result {| NotifyNonlinear .one|} @@ -1114,24 +1118,25 @@ test event-9.19 {Successive destructions (pointer window + ancestors including i wm geometry .two 300x300+100+100 create_and_pack_frames .two wm deiconify .two - waitForWindowEvent .two.f1.f2 toplevel .three pack propagate .three 0 wm geometry .three 300x300+110+110 create_and_pack_frames .three wm deiconify .three waitForWindowEvent .three.f1.f2 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} + update; # finish displaying windows set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .three waitForWindowEvent .two.f1.f2 + processevents end + set result +} -cleanup { bind all {} bind all {} destroy .two - set result -} -cleanup { unset result } -result {| NotifyNonlinearVirtual .two| NotifyNonlinearVirtual .two.f1| NotifyNonlinear .two.f1.f2|} @@ -1144,12 +1149,12 @@ test event-9.20 {Successive destructions (pointer window + ancestors including i create_and_pack_frames .two wm deiconify .two waitForWindowEvent .two.f1.f2 - bind all {append result " %d %W|"} - bind all {append result " %d %W|"} set result "|" } -body { + bind all {append result " %d %W|"} + bind all {append result " %d %W|"} destroy .two - _pause 200; # service events (only screen drawing events expected) + processevents end set result } -cleanup { bind all {} -- cgit v0.12