# This file is a Tcl script to test the code in tkEvent.c. It is # organized in the standard fashion for Tcl tests. # # Copyright © 1994 The Regents of the University of California. # Copyright © 1994-1995 Sun Microsystems, Inc. # Copyright © 1998-1999 Scriptics Corporation. # All rights reserved. package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test # XXX This test file is woefully incomplete. Right now it only tests # a few of the procedures in tkEvent.c. Please add more tests whenever # possible. # Setup table used to query key events. proc _init_keypress_lookup {} { global keypress_lookup # Characters with meaning to Tcl... array set keypress_lookup [list \ - minus \ > greater \ \" quotedbl \ \# numbersign \ \$ dollar \ \; semicolon \ \[ bracketleft \ \\ backslash \ \] bracketright \ \{ braceleft \ \} braceright \ " " space \ \xA0 nobreakspace \ "\n" Return \ "\t" Tab] } # Lookup an event in the keypress table. # For example: # Q -> Q # ; -> semicolon # > -> greater # Delete -> Delete # Escape -> Escape proc _keypress_lookup {char} { global keypress_lookup if {! [info exists keypress_lookup]} { _init_keypress_lookup } if {$char == ""} { error "empty char" } if {[info exists keypress_lookup($char)]} { return $keypress_lookup($char) } else { return $char } } # Lookup and generate a pair of Key and KeyRelease events proc _keypress {win key} { set keysym [_keypress_lookup $key] # Force focus to the window before delivering # each event so that a window manager using # a focus follows mouse will not steal away # the focus if the mouse is moved around. if {[focus] != $win} { focus -force $win } event generate $win _pause 50 if {[focus] != $win} { focus -force $win } event generate $win _pause 50 } # Call _keypress for each character in the given string proc _keypress_string {win string} { foreach letter [split $string ""] { _keypress $win $letter } } # Delay script execution for a given amount of time proc _pause {{msecs 1000}} { global _pause if {! [info exists _pause(number)]} { set _pause(number) 0 } set num [incr _pause(number)] set _pause($num) 0 after $msecs "set _pause($num) 1" vwait _pause($num) unset _pause($num) } # Helper proc to convert index to x y position 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" } foreach {x1 y1 width height} $bbox break set middle_y [expr {$y1 + ($height / 2)}] return [list $x1 $middle_y] } # Return selection only if owned by the given widget proc _get_selection {widget} { if {[string compare $widget [selection own]] != 0} { return "" } if {[catch {selection get} sel]} { return "" } return $sel } # Begining of the actual tests test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup { deleteWindows set x {} } -body { button .b -text Test pack .b bindtags .b .b update bind .b { lappend x destroy event generate .b event generate .b } bind .b { lappend x button } destroy .b return $x } -cleanup { deleteWindows } -result {destroy} test event-1.2 {event generate } -setup { deleteWindows catch {unset ::event12result} } -body { set ::event12result 0 pack [entry .e] update bind .e {set ::event12result "1"} focus -force .e event generate .e destroy .e set ::event12result } -cleanup { deleteWindows } -result 1 test event-2.1(keypress) {type into entry widget and hit Return} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e set return_binding 0 bind $e {set return_binding 1} tkwait visibility $e _keypress_string $e HELLO\n list [$e get] $return_binding } -cleanup { deleteWindows } -result {HELLO 1} test event-2.2(keypress) {type into entry widget and then delete some text} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e # Avoid a hang when macOS puts the mouse pointer on the green button wm geometry .t +200+100 _keypress_string $e MELLO _keypress $e BackSpace _keypress $e BackSpace $e get } -cleanup { deleteWindows } -result {MEL} test event-2.3(keypress) {type into entry widget, triple click, hit Delete key, and then type some more} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e JUMP set result [$e get] event generate $e for {set i 0} {$i < 3} {incr i} { _pause 100 event generate $e _pause 100 event generate $e } _keypress $e Delete _keypress_string $e UP lappend result [$e get] } -cleanup { deleteWindows } -result {JUMP UP} test event-2.4(keypress) {type into text widget and hit Return} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e set return_binding 0 bind $e {set return_binding 1} tkwait visibility $e _keypress_string $e HELLO\n list [$e get 1.0 end] $return_binding } -cleanup { deleteWindows } -result [list "HELLO\n\n" 1] test event-2.5(keypress) {type into text widget and then delete some text} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e MELLO _keypress $e BackSpace _keypress $e BackSpace $e get 1.0 1.end } -cleanup { deleteWindows } -result {MEL} test event-2.6(keypress) {type into text widget, triple click, hit Delete key, and then type some more} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e JUMP set result [$e get 1.0 1.end] event generate $e for {set i 0} {$i < 3} {incr i} { _pause 100 event generate $e _pause 100 event generate $e } _keypress $e Delete _keypress_string $e UP lappend result [$e get 1.0 1.end] } -cleanup { deleteWindows } -result {JUMP UP} test event-3.1(click-drag) {click and drag in a text widget, this tests tkTextSelectTo in text.tcl} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e "A Tcl/Tk selection test!" set anchor 1.6 set selend 1.18 set result [list] lappend result [$e get 1.0 1.end] # Get the x,y coords of the second T in "Tcl/Tk" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down to set the insert cursor position event generate $e event generate $e -x $anchor_x -y $anchor_y # Save the position of the insert cursor lappend result [$e index insert] # Now drag until selend is highlighted, then click up set current $anchor while {[$e compare $current <= $selend]} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y set current [$e index [list $current + 1 char]] _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] # Now click and click and drag to the left, over "Tcl/Tk selection" event generate $e -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 -x $current_x -y $current_y set current [$e index [list $current - 1 char]] _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] } -cleanup { deleteWindows } -result {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} test event-3.2(click-drag) {click and drag in an entry widget, this tests tkEntryMouseSelect in entry.tcl} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e "A Tcl/Tk selection!" set anchor 6 set selend 18 set result [list] lappend result [$e get] # Get the x,y coords of the second T in "Tcl/Tk" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down to set the insert cursor position event generate $e event generate $e -x $anchor_x -y $anchor_y # Save the position of the insert cursor lappend result [$e index insert] # Now drag until selend is highlighted, then click up set current $anchor while {$current <= $selend} { foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y incr current _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] # Now click and click and drag to the left, over "Tcl/Tk selection" event generate $e -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 -x $current_x -y $current_y incr current -1 _pause 50 } event generate $e -x $current_x -y $current_y _pause 200 # Save the position of the insert cursor lappend result [$e index insert] # Save the highlighted text lappend result [_get_selection $e] } -cleanup { deleteWindows } -result {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} test event-4.1(double-click-drag) {click down, click up, click down again, then drag in a text widget} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e "Word select test" set anchor 1.8 # Get the x,y coords of the second e in "select" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down, release, then click down again event generate $e event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 # Save the highlighted text set result [list] lappend result [_get_selection $e] # Insert cursor should be at beginning of "select" lappend result [$e index insert] # Move mouse one character to the left set current [$e index [list $anchor - 1 char]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Insert cursor should be before the l in "select" lappend result [$e index insert] # Selection should still be the word "select" lappend result [_get_selection $e] # Move mouse to the space before the word "select" set current [$e index [list $current - 3 char]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 200 lappend result [$e index insert] lappend result [_get_selection $e] # Move mouse to the r in "Word" set current 1.2 foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Selection should now be "Word select" lappend result [_get_selection $e] # Insert cursor should be before the r in "Word" lappend result [$e index insert] return $result } -cleanup { deleteWindows } -result {select 1.5 1.7 select 1.4 { select} {Word select} 1.2} test event-4.2(double-click-drag) {click down, click up, click down again, then drag in an entry widget} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e "Word select test" set anchor 8 # Get the x,y coords of the second e in "select" foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break # Click down, release, then click down again event generate $e event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 set result [list] lappend result [_get_selection $e] # Insert cursor should be at the end of "select" lappend result [$e index insert] # Move mouse one character to the left set current [expr {$anchor - 1}] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Insert cursor should be before the l in "select" lappend result [$e index insert] # Selection should still be the word "select" lappend result [_get_selection $e] # Move mouse to the space before the word "select" set current [expr {$current - 3}] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 lappend result [$e index insert] lappend result [_get_selection $e] # Move mouse to the r in "Word" set current [expr {$current - 2}] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 # Selection should now be "Word select" lappend result [_get_selection $e] # Insert cursor should be before the r in "Word" lappend result [$e index insert] return $result } -cleanup { deleteWindows } -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 { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e _keypress_string $e "LINE ONE\nLINE TWO\nLINE THREE" set anchor 3.2 # Triple click one third line leaving mouse down foreach {anchor_x anchor_y} [_text_ind_to_x_y $e $anchor] break event generate $e event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 event generate $e -x $anchor_x -y $anchor_y _pause 50 set result [list] lappend result [_get_selection $e] # Drag up to second line set current [$e index [list $anchor - 1 line]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 lappend result [_get_selection $e] # Drag up to first line set current [$e index [list $current - 1 line]] foreach {current_x current_y} [_text_ind_to_x_y $e $current] break event generate $e -x $current_x -y $current_y _pause 50 lappend result [_get_selection $e] return $result } -cleanup { deleteWindows } -result [list "LINE THREE\n" "LINE 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 event since the mouse was not pressed down in that window} -setup { deleteWindows } -body { set t [toplevel .t] event generate $t destroy $t set t [toplevel .t] set motion nomotion bind $t {set motion inmotion} event generate $t return $motion } -cleanup { deleteWindows } -result {nomotion} test event-7.1(double-click) {A double click on a lone character in a text widget should select that character} -setup { deleteWindows } -body { set t [toplevel .t] set e [text $t.e] pack $e tkwait visibility $e focus -force $e _keypress_string $e "On A letter" set anchor 1.3 # Get x,y coords just inside the left # and right hand side of the letter A foreach {x1 y1 width height} [$e bbox $anchor] break set middle_y [expr {$y1 + ($height / 2)}] set left_x [expr {$x1 + 2}] set left_y $middle_y set right_x [expr {($x1 + $width) - 2}] set right_y $middle_y # Double click near left hand egde of the letter A event generate $e event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 set result [list] lappend result [$e index insert] lappend result [_get_selection $e] # Clear selection by clicking at 0,0 event generate $e -x 0 -y 0 _pause 50 event generate $e -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 lappend result [$e index insert] lappend result [_get_selection $e] return $result } -cleanup { deleteWindows unset x1 y1 width height middle_y left_x left_y right_x right_y } -result {1.3 A 1.3 A} test event-7.2(double-click) {A double click on a lone character in an entry widget should select that character} -setup { deleteWindows } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e focus -force $e _keypress_string $e "On A letter" set anchor 3 # Get x,y coords just inside the left # and right hand side of the letter A foreach {x1 y1 width height} [$e bbox $anchor] break set middle_y [expr {$y1 + ($height / 2)}] set left_x [expr {$x1 + 2}] set left_y $middle_y set right_x [expr {($x1 + $width) - 2}] set right_y $middle_y # Double click near left hand egde of the letter A event generate $e event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 event generate $e -x $left_x -y $left_y _pause 50 set result [list] lappend result [$e index insert] lappend result [_get_selection $e] # Clear selection by clicking at 0,0 event generate $e -x 0 -y 0 _pause 50 event generate $e -x 0 -y 0 _pause 50 # Double click near right hand edge of the letter A event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 event generate $e -x $right_x -y $right_y _pause 50 lappend result [$e index insert] lappend result [_get_selection $e] return $result } -cleanup { deleteWindows unset x1 y1 width height middle_y left_x left_y right_x right_y } -result {4 A 4 A} test event-8 {event generate with keysyms corresponding to multi-byte virtual keycodes - bug e36963bfe8df9f5e528134707a91b9c0051de723} -constraints nonPortable -setup { deleteWindows set res [list ] } -body { set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e bind $e {lappend res keycode: %k keysym: %K} focus -force $e update event generate $e # The value now contained in $res depends on the actual # physical keyboard layout and keycode generated, from # the hardware on which the test suite happens to run. # We don't need (and we can't really) check correctness # of the (system-dependent) keycode received, however # Tk should be able to associate this keycode to a # (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" } 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." } } -cleanup { deleteWindows } -result {OK} test event-9 {no event is generated for the container window when its managed window in which the mouse pointer was inside gets destroyed - bug 9e1312f32c} -setup { set res [list ] set iconified false if {[winfo ismapped .]} { wm iconify . update set iconified true } } -body { toplevel .top pack propagate .top 0 bind .top {lappend res %W} pack [frame .top.f -bg green -width 50 -height 50] -anchor se -side bottom tkwait visibility .top.f after 50 update focus -force .top.f event generate .top.f -warp 1 -x 25 -y 25 ; # sent to .top and .top.f controlPointerWarpTiming update ; # idletasks not enough destroy .top.f ; # no event sent update set res } -cleanup { deleteWindows if {$iconified} { wm deiconify . update } } -result {.top .top.f} test event-9.1 {enter . window by destroying a toplevel - bug b1d115fa60} -setup { set EnterBind [bind . ] } -body { wm geometry . 200x200+300+300 wm deiconify . _pause 200 toplevel .top2 -width 200 -height 200 wm geometry .top2 +[expr {[winfo rootx .]+50}]+[expr {[winfo rooty .]+50}] update idletasks wm deiconify .top2 update idletasks raise .top2 _pause 400 event generate .top2 -warp 1 -x 50 -y 50 _pause 100 bind . {lappend res %W} set res [list ] destroy .top2 update idletasks _pause 200 set res } -cleanup { deleteWindows bind . $EnterBind } -result {.} test event-9.2 {enter toplevel window by destroying a toplevel - bug b1d115fa60} -setup { set iconified false if {[winfo ismapped .]} { wm iconify . update set iconified true } } -body { toplevel .top1 wm geometry .top1 200x200+300+300 wm deiconify .top1 _pause 200 toplevel .top2 -width 200 -height 200 wm geometry .top2 +[expr {[winfo rootx .top1]+50}]+[expr {[winfo rooty .top1]+50}] _pause 200 wm deiconify .top2 update idletasks raise .top2 _pause 400 event generate .top2 -warp 1 -x 50 -y 50 _pause 100 bind .top1 {lappend res %W} set res [list ] destroy .top2 _pause 200 set res } -cleanup { deleteWindows ; # destroy all children of ".", this already includes .top1 if {$iconified} { wm deiconify . update } } -result {.top1} # cleanup update unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} rename _keypress {} rename _pause {} rename _text_ind_to_x_y {} rename _get_selection {} cleanupTests return