Merge 9.0core-tip-626

1 files changed, 370 insertions, 55 deletions

diff --git a/tests/event.test b/tests/event.test
index c56d4d8..3cef258 100644
--- a/tests/event.test
+++ b/tests/event.test
@@ -51,17 +51,17 @@ proc _keypress_lookup {char} {
     global keypress_lookup
 
     if {! [info exists keypress_lookup]} {
-        _init_keypress_lookup
+	_init_keypress_lookup
     }
 
     if {$char == ""} {
-        error "empty char"
+	error "empty char"
     }
 
     if {[info exists keypress_lookup($char)]} {
-        return $keypress_lookup($char)
+	return $keypress_lookup($char)
     } else {
-        return $char
+	return $char
     }
 }
 
@@ -76,12 +76,12 @@ proc _keypress {win key} {
     # the focus if the mouse is moved around.
 
     if {[focus] != $win} {
-        focus -force $win
+	focus -force $win
     }
     event generate $win <Key-$keysym>
     _pause 50
     if {[focus] != $win} {
-        focus -force $win
+	focus -force $win
     }
     event generate $win <KeyRelease-$keysym>
     _pause 50
@@ -91,7 +91,7 @@ proc _keypress {win key} {
 
 proc _keypress_string {win string} {
     foreach letter [split $string ""] {
-        _keypress $win $letter
+	_keypress $win $letter
     }
 }
 
@@ -101,7 +101,7 @@ proc _pause {{msecs 1000}} {
     global _pause
 
     if {! [info exists _pause(number)]} {
-        set _pause(number) 0
+	set _pause(number) 0
     }
 
     set num [incr _pause(number)]
@@ -117,7 +117,7 @@ proc _pause {{msecs 1000}} {
 proc _text_ind_to_x_y {text ind} {
     set bbox [$text bbox $ind]
     if {[llength $bbox] != 4} {
-        error "got bbox \{$bbox\} from $text, index $ind"
+	error "got bbox \{$bbox\} from $text, index $ind"
     }
     foreach {x1 y1 width height} $bbox break
     set middle_y [expr {$y1 + ($height / 2)}]
@@ -128,10 +128,10 @@ proc _text_ind_to_x_y {text ind} {
 
 proc _get_selection {widget} {
     if {[string compare $widget [selection own]] != 0} {
-        return ""
+	return ""
     }
     if {[catch {selection get} sel]} {
-        return ""
+	return ""
     }
     return $sel
 }
@@ -209,7 +209,7 @@ test event-2.2(keypress) {type into entry widget and then delete some text} -set
     deleteWindows
 } -result {MEL}
 test event-2.3(keypress) {type into entry widget, triple click, hit Delete key,
-        and then type some more} -setup {
+	and then type some more} -setup {
     deleteWindows
 } -body {
     set t [toplevel .t]
@@ -222,10 +222,10 @@ test event-2.3(keypress) {type into entry widget, triple click, hit Delete key,
 
     event generate $e <Enter>
     for {set i 0} {$i < 3} {incr i} {
-        _pause 100
-        event generate $e <Button-1>
-        _pause 100
-        event generate $e <ButtonRelease-1>
+	_pause 100
+	event generate $e <Button-1>
+	_pause 100
+	event generate $e <ButtonRelease-1>
     }
 
     _keypress $e Delete
@@ -265,6 +265,7 @@ test event-2.5(keypress) {type into text widget and then delete some text} -setu
 test event-2.6(keypress) {type into text widget, triple click,
     hit Delete key, and then type some more} -setup {
 	deleteWindows
+	update idletasks
 } -body {
     set t [toplevel .t]
     set e [text $t.e]
@@ -276,10 +277,10 @@ test event-2.6(keypress) {type into text widget, triple click,
 
     event generate $e <Enter>
     for {set i 0} {$i < 3} {incr i} {
-        _pause 100
-        event generate $e <Button-1>
-        _pause 100
-        event generate $e <ButtonRelease-1>
+	_pause 100
+	event generate $e <Button-1>
+	_pause 100
+	event generate $e <ButtonRelease-1>
     }
 
     _keypress $e Delete
@@ -318,10 +319,10 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests
 
     set current $anchor
     while {[$e compare $current <= $selend]} {
-        foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
-        event generate $e <B1-Motion> -x $current_x -y $current_y
-        set current [$e index [list $current + 1 char]]
-        _pause 50
+	foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+	event generate $e <B1-Motion> -x $current_x -y $current_y
+	set current [$e index [list $current + 1 char]]
+	_pause 50
     }
 
     event generate $e <ButtonRelease-1> -x $current_x -y $current_y
@@ -338,10 +339,10 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests
     event generate $e <Button-1> -x $current_x -y $current_y
 
     while {[$e compare $current >= [list $anchor - 4 char]]} {
-        foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
-        event generate $e <B1-Motion> -x $current_x -y $current_y
-        set current [$e index [list $current - 1 char]]
-        _pause 50
+	foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+	event generate $e <B1-Motion> -x $current_x -y $current_y
+	set current [$e index [list $current - 1 char]]
+	_pause 50
     }
 
     event generate $e <ButtonRelease-1> -x $current_x -y $current_y
@@ -385,10 +386,10 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests
 
     set current $anchor
     while {$current <= $selend} {
-        foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
-        event generate $e <B1-Motion> -x $current_x -y $current_y
-        incr current
-        _pause 50
+	foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+	event generate $e <B1-Motion> -x $current_x -y $current_y
+	incr current
+	_pause 50
     }
 
     event generate $e <ButtonRelease-1> -x $current_x -y $current_y
@@ -405,10 +406,10 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests
     event generate $e <Button-1> -x $current_x -y $current_y
 
     while {$current >= ($anchor - 4)} {
-        foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
-        event generate $e <B1-Motion> -x $current_x -y $current_y
-        incr current -1
-        _pause 50
+	foreach {current_x current_y} [_text_ind_to_x_y $e $current] break
+	event generate $e <B1-Motion> -x $current_x -y $current_y
+	incr current -1
+	_pause 50
     }
 
     event generate $e <ButtonRelease-1> -x $current_x -y $current_y
@@ -567,7 +568,7 @@ test event-4.2(double-click-drag) {click down, click up, click down again,
 } -result {select 11 7 select 4 { select} {Word select} 2}
 
 test event-5.1(triple-click-drag) {Triple click and drag across lines in a
-        text widget, this should extend the selection to the new line} -setup {
+	text widget, this should extend the selection to the new line} -setup {
 	deleteWindows
 } -body {
     set t [toplevel .t]
@@ -624,12 +625,12 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in a
 } -cleanup {
     deleteWindows
 } -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \
-        "LINE ONE\nLINE TWO\nLINE THREE\n"]
+	"LINE ONE\nLINE TWO\nLINE THREE\n"]
 
 test event-6.1(button-state) {button press in a window that is then
-        destroyed, when the mouse is moved into another window it
-        should not generate a <B1-motion> event since the mouse
-        was not pressed down in that window} -setup {
+	destroyed, when the mouse is moved into another window it
+	should not generate a <B1-motion> event since the mouse
+	was not pressed down in that window} -setup {
 	deleteWindows
 } -body {
     set t [toplevel .t]
@@ -781,8 +782,8 @@ test event-7.2(double-click) {A double click on a lone character
 } -result {4 A 4 A}
 
 test event-8 {event generate with keysyms corresponding to
-              multi-byte virtual keycodes - bug
-              e36963bfe8df9f5e528134707a91b9c0051de723} -constraints nonPortable -setup {
+	      multi-byte virtual keycodes - bug
+	      e36963bfe8df9f5e528134707a91b9c0051de723} -constraints nonPortable -setup {
     deleteWindows
     set res [list ]
 } -body {
@@ -803,13 +804,13 @@ test event-8 {event generate with keysyms corresponding to
     # (system-independent) known keysym, unless the system
     # running the test does not have a keyboard with a
     # diaeresis key.
-    if {[expr {[lindex $res 3] ne "??"}]} {
-        # keyboard has a physical diaeresis key and bug is fixed
-        return "OK"
+    if {[lindex $res 3] ne "??"} {
+	# keyboard has a physical diaeresis key and bug is fixed
+	return "OK"
     } else  {
-        return "Test failed, unless the keyboard tied to the system \
-                on which this test is run does NOT have a diaeresis \
-                physical key - in this case, test is actually void."
+	return "Test failed, unless the keyboard tied to the system \
+		on which this test is run does NOT have a diaeresis \
+		physical key - in this case, test is actually void."
     }
 } -cleanup {
     deleteWindows
@@ -840,12 +841,18 @@ test event-9.1 {enter . window by destroying a toplevel - bug b1d115fa60} -setup
     deleteWindows
     bind . <Enter> $EnterBind
 } -result {.}
-test event-9.2 {enter toplevel window by destroying a toplevel - bug b1d115fa60} -setup {
+
+# This test fails sporadically when run on the macOS CI runner. It does
+# not seem to fail on real computers.  It is not needed since the same
+# thing is tested by 9.13.  So it is simpler to constrain it as notAqua.
+test event-9.2 {enter toplevel window by destroying a toplevel - bug b1d115fa60} \
+-constraints { notAqua} \
+-setup {
     set iconified false
     if {[winfo ismapped .]} {
-        wm iconify .
-        update
-        set iconified true
+	wm iconify .
+	update
+	set iconified true
     }
 } -body {
     toplevel .top1
@@ -869,12 +876,318 @@ test event-9.2 {enter toplevel window by destroying a toplevel - bug b1d115fa60}
 } -cleanup {
     deleteWindows ; # destroy all children of ".", this already includes .top1
     if {$iconified} {
-        wm deiconify .
-        update
+	wm deiconify .
+	update
     }
 } -result {.top1}
 
+proc waitForWindowEvent {w event {timeout 1000}} {
+# This proc is intended to overcome latency of windowing system
+# notifications when toplevel windows are involved. These latencies vary
+# considerably with the window manager in use, with the system load,
+# with configured scheduling priorities for processes, etc ...
+# Waiting for the corresponding window events evades the trouble that is
+# associated with the alternative: waiting or halting the Tk process for a
+# fixed amount of time (using "after ms"). With the latter strategy it's
+# always a gamble how much waiting time is enough on an end user's system.
+# It also leads to long fixed waiting times in order to be on the safe side.
+
+    variable _windowEvent
+
+    # Use counter as a unique ID to prevent subsequent waits
+    # from interfering with each other.
+    set counter [incr _windowEvent(counter)]
+    set _windowEvent($counter) 1
+    set savedBinding [bind $w $event]
+    bind $w $event [list +waitForWindowEvent.signal $counter]
+    set afterID [after $timeout [list set _windowEvent($counter) -1]]
+    vwait _windowEvent($counter)
+    set late [expr {$_windowEvent($counter) == -1}]
+    bind $w $event $savedBinding
+    unset _windowEvent($counter)
+    if {$late} {
+	puts stderr "wait for $event event on $w timed out (> $timeout ms)"
+    } else {
+	after cancel $afterID
+    }
+}
+proc waitForWindowEvent.signal {counter} {
+# Helper proc that records the triggering of a window event.
+    incr ::_windowEvent($counter)
+}
+
+proc create_and_pack_frames {{w {}}} {
+    frame $w.f1 -bg blue -width 200 -height 200
+    pack propagate $w.f1 0
+    frame $w.f1.f2 -bg yellow -width 100 -height 100
+    pack $w.f1.f2 $w.f1 -side bottom -anchor se
+    update idletasks
+}
+
+proc setup_win_mousepointer {w} {
+# Position the window and the mouse pointer as an initial state for some tests.
+# The so-called "pointer window" is the $w window that will now contain the mouse pointer.
+    wm geometry . +700+400; # root window out of our way - must not cover windows from event-9.1*
+    toplevel $w
+    pack propagate $w 0
+    wm geometry $w 300x300+100+100
+    tkwait visibility $w
+    update; # service remaining screen drawing events (e.g. <Expose>)
+    set pointerWin [winfo containing [winfo pointerx $w] [winfo pointery $w]]
+    event generate $w <Motion> -warp 1 -x 250 -y 250
+    if {($pointerWin ne $w) && ([tk windowingsystem] ne "aqua")} {
+	waitForWindowEvent $w <Enter>
+    } else {
+	controlPointerWarpTiming
+    }
+}
+
+test event-9.11 {pointer window container = parent} -setup {
+    setup_win_mousepointer .one
+    wm withdraw .one
+    create_and_pack_frames .one
+    wm deiconify .one
+    tkwait visibility .one.f1.f2
+    _pause 200; # needed for Windows
+    update idletasks; # finish display of window
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .one.f1.f2
+    update
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyInferior .one.f1|}
+
+test event-9.12 {pointer window container != parent} -setup {
+    setup_win_mousepointer .one
+    wm withdraw .one
+    create_and_pack_frames .one
+    pack propagate .one.f1.f2 0
+    pack [frame .one.g -bg orange -width 80 -height 80] -anchor se -side bottom -in .one.f1.f2
+    wm deiconify .one
+    tkwait visibility .one.g
+    event generate .one <Motion> -warp 1 -x 250 -y 250
+    _pause 200; # needed for Windows
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .one.g
+    update
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyNonlinearVirtual .one.f1|<Enter> NotifyNonlinear .one.f1.f2|}
+
+test event-9.13 {pointer window is a toplevel, toplevel destination} -setup {
+    setup_win_mousepointer .one
+    toplevel .two
+    wm geometry .two 300x300+150+150
+    wm withdraw .two
+    wm deiconify .two
+    waitForWindowEvent .two <Enter>
+    update idletasks; # finish displaying windows
+    set result |
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .two
+    waitForWindowEvent .one <Enter>
+    update
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyNonlinear .one|}
+
+test event-9.14 {pointer window is a toplevel, tk internal destination} -setup {
+    setup_win_mousepointer .one
+    wm withdraw .one
+    create_and_pack_frames .one
+    toplevel .two
+    wm geometry .two 300x300+150+150
+    wm withdraw .two
+    wm deiconify .one
+    wm deiconify .two
+    waitForWindowEvent .two <Enter>
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .two
+    waitForWindowEvent .one.f1.f2 <Enter>
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyNonlinearVirtual .one|<Enter> NotifyNonlinearVirtual .one.f1|<Enter> NotifyNonlinear .one.f1.f2|}
+
+test event-9.15 {pointer window is a toplevel, destination is screen root} -setup {
+    setup_win_mousepointer .one; # ensure the mouse pointer is where we want it to be (the .one toplevel is not itself used in this test)
+#    destroy .one
+    toplevel .two
+    wm geometry .two 300x300+150+150
+    wm deiconify .two
+    waitForWindowEvent .two <Enter>
+    update idletasks; # finish displaying .two
+    event generate .two <Motion> -warp 1 -x 275 -y 275
+    controlPointerWarpTiming
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .two
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|}
+
+test event-9.16 {Successive destructions (pointer window + parent), single generation of crossing events} -setup {
+    # Tests correctness of overwriting the dead window struct in
+    # TkPointerDeadWindow() and subsequent reading in GenerateEnterLeave().
+    setup_win_mousepointer .one
+    wm withdraw .one
+    create_and_pack_frames .one
+    wm deiconify .one
+    tkwait visibility .one.f1.f2
+    update idletasks; # finish displaying window
+    _pause 200; # needed for Windows
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .one.f1
+    update
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyInferior .one|}
+
+test event-9.17 {Successive destructions (pointer window + parent), separate crossing events} -setup {
+    # Tests correctness of overwriting the dead window struct in
+    # TkPointerDeadWindow() and subsequent reading in GenerateEnterLeave().
+    setup_win_mousepointer .one
+    wm withdraw .one
+    create_and_pack_frames .one
+    wm deiconify .one
+    tkwait visibility .one.f1.f2
+    update idletasks; # finish displaying window
+    _pause 200; # needed for Windows
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .one.f1.f2
+    update; # make sure window is gone
+    destroy .one.f1
+    update; # make sure window is gone
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyInferior .one.f1|<Enter> NotifyInferior .one|}
+
+test event-9.18 {Successive destructions (pointer window + ancestors including its toplevel), destination is non-root toplevel} -setup {
+    setup_win_mousepointer .one
+    toplevel .two
+    pack propagate .two 0
+    wm geometry .two 300x300+100+100
+    create_and_pack_frames .two
+    wm deiconify .two
+    waitForWindowEvent .two.f1.f2 <Enter>
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .two
+    waitForWindowEvent .one <Enter>
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    unset result
+} -result {|<Enter> NotifyNonlinear .one|}
+
+test event-9.19 {Successive destructions (pointer window + ancestors including its toplevel), destination is internal window, bypass root win} -setup {
+    setup_win_mousepointer .one; # ensure the mouse pointer is where we want it to be (the .one toplevel is not itself used in this test)
+#    destroy .one
+    toplevel .two
+    pack propagate .two 0
+    wm geometry .two 300x300+100+100
+    create_and_pack_frames .two
+    wm deiconify .two
+    toplevel .three
+    pack propagate .three 0
+    wm geometry .three 300x300+110+110
+    create_and_pack_frames .three
+    wm deiconify .three
+    waitForWindowEvent .three.f1.f2 <Enter>
+    update idletasks; # finish displaying windows
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .three
+    waitForWindowEvent .two.f1.f2 <Enter>
+    update idletasks; #finish destroying .two
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    destroy .one
+    destroy .two
+    unset result
+} -result {|<Enter> NotifyNonlinearVirtual .two|<Enter> NotifyNonlinearVirtual .two.f1|<Enter> NotifyNonlinear .two.f1.f2|}
+
+test event-9.20 {Successive destructions (pointer window + ancestors including its toplevel), destination is screen root} -setup {
+    setup_win_mousepointer .one; # ensure the mouse pointer is where we want it to be (the .one toplevel is not itself used in this test)
+    destroy .one
+    toplevel .two
+    pack propagate .two 0
+    wm geometry .two 300x300+100+100
+    create_and_pack_frames .two
+    wm deiconify .two
+    waitForWindowEvent .two.f1.f2 <Enter>
+    set result "|"
+} -body {
+    bind all <Leave> {append result "<Leave> %d %W|"}
+    bind all <Enter> {append result "<Enter> %d %W|"}
+    destroy .two
+    update idletasks; #finish destroying .two
+    set result
+} -cleanup {
+    bind all <Leave> {}
+    bind all <Enter> {}
+    unset result
+} -result {|}
+
 # cleanup
+# macOS sometimes has trouble deleting the test window,
+# causing a failure in focus.test.
+_pause 200;
+deleteWindows
 update
 unset -nocomplain keypress_lookup
 rename _init_keypress_lookup {}
@@ -883,6 +1196,8 @@ rename _keypress {}
 rename _pause {}
 rename _text_ind_to_x_y {}
 rename _get_selection {}
+rename create_and_pack_frames {}
+rename setup_win_mousepointer {}
 
 cleanupTests
 return