# This file is a Tcl script to test the code in tkEvent.c. It is # organized in the standard fashion for Tcl tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: event.test,v 1.1.1.1 2007/07/10 15:05:18 duncan Exp $ package require tcltest 2.1 namespace import -force tcltest::configure namespace import -force tcltest::testsDirectory configure -testdir [file join [pwd] [file dirname [info script]]] configure -loadfile [file join [testsDirectory] constraints.tcl] tcltest::loadTestedCommands # 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 scan A %c start scan Z %c finish for {set i $start} {$i <= $finish} {incr i} { set l [format %c $i] set keypress_lookup($l) $l } scan a %c start scan z %c finish for {set i $start} {$i <= $finish} {incr i} { set l [format %c $i] set keypress_lookup($l) $l } scan 0 %c start scan 9 %c finish for {set i $start} {$i <= $finish} {incr i} { set l [format %c $i] set keypress_lookup($l) $l } array set keypress_lookup [list \ " " space \ ! exclam \ \" quotedbl \ \# numbersign \ \$ dollar \ % percent \ & ampersand \ ( parenleft \ ) parenright \ * asterisk \ + plus \ , comma \ - minus \ . period \ / slash \ : colon \ \; semicolon \ < less \ = equal \ > greater \ ? question \ @ at \ \[ bracketleft \ \\ backslash \ \] bracketright \ ^ asciicircum \ _ underscore \ \{ braceleft \ | bar \ \} braceright \ ~ asciitilde \ ' apostrophe \ "\n" Return] } # Lookup an event in the keypress table. # For example: # Q -> Q # . -> period # / -> slash # 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 KeyPress 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} { button .b -text Test pack .b bindtags .b .b update bind .b { lappend x destroy event generate .b <1> event generate .b } bind .b <1> { lappend x button } set x {} destroy .b set x } {destroy} test event-1.2 {event generate } { catch {destroy .e} catch {unset ::event12result} set ::event12result 0 pack [entry .e] update bind .e {set ::event12result "1"} focus -force .e ; event generate .e destroy .e set ::event12result } 1 test event-keypress-1.1 { type into entry widget and hit Return } { destroy .t 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 } {HELLO 1} test event-keypress-1.2 { type into entry widget and then delete some text } { destroy .t set t [toplevel .t] set e [entry $t.e] pack $e tkwait visibility $e _keypress_string $e MELLO _keypress $e BackSpace _keypress $e BackSpace $e get } MEL test event-keypress-1.3 { type into entry widget, triple click, hit Delete key, and then type some more } { destroy .t 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] } {JUMP UP} test event-keypress-1.4 { type into text widget and hit Return } { destroy .t 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 } [list "HELLO\n\n" 1] test event-keypress-1.5 { type into text widget and then delete some text } { destroy .t 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 } MEL test event-keypress-1.6 { type into text widget, triple click, hit Delete key, and then type some more } { destroy .t 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] } {JUMP UP} test event-click-drag-1.1 { click and drag in a text widget, this tests tkTextSelectTo in text.tcl } { destroy .t 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] } {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} test event-click-drag-1.2 { click and drag in an entry widget, this tests tkEntryMouseSelect in entry.tcl } { destroy .t 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] } {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} test event-double-click-drag-1.1 { click down, click up, click down again, then drag in a text widget } { destroy .t 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 end 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] set result } {select 1.11 1.7 select 1.4 { select} {Word select} 1.2} test event-double-click-drag-1.2 { click down, click up, click down again, then drag in an entry widget } { destroy .t 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] set result } {select 11 7 select 4 { select} {Word select} 2} test event-triple-click-drag-1.1 { Triple click and drag across lines in a text widget, this should extend the selection to the new line } { destroy .t 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] set result } [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \ "LINE ONE\nLINE TWO\nLINE THREE\n"] test event-button-state-1.1 { 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. } { destroy .t set t [toplevel .t] event generate $t destroy $t set t [toplevel .t] set motion nomotion bind $t {set motion inmotion} event generate $t set motion } nomotion # cleanup destroy .t unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} rename _keypress {} rename _pause {} rename _text_ind_to_x_y {} rename _get_selection {} ::tcltest::cleanupTests return