From 6181e4e8acc4749738972dd987facd578e1d4ba0 Mon Sep 17 00:00:00 2001 From: mdejong Date: Thu, 29 Mar 2001 11:05:49 +0000 Subject: * library/entry.tcl (tkEntryMouseSelect): * library/text.tcl (tkTextSelectTo): When the mouse is dragged with the button down, move the insertion cursor to the current mouse position. * tests/event.test: Add a series of tests for event generation. Add tests for selection, check the position of the insertion cursor. --- ChangeLog | 11 ++ library/entry.tcl | 5 +- library/text.tcl | 12 +- tests/event.test | 394 +++++++++++++++++++++++++++++++++++++++++++++++++++++- 4 files changed, 408 insertions(+), 14 deletions(-) diff --git a/ChangeLog b/ChangeLog index 171f57e..645f34f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +2001-03-29 Mo DeJong + + * library/entry.tcl (tkEntryMouseSelect): + * library/text.tcl (tkTextSelectTo): When + the mouse is dragged with the button down, + move the insertion cursor to the current + mouse position. + * tests/event.test: Add a series of tests + for event generation. Add tests for selection, + check the position of the insertion cursor. + 2001-03-28 Jeff Hobbs * unix/configure: diff --git a/library/entry.tcl b/library/entry.tcl index b44eaad..a826481 100644 --- a/library/entry.tcl +++ b/library/entry.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk entry widgets and provides # procedures that help in implementing those bindings. # -# RCS: @(#) $Id: entry.tcl,v 1.13 2000/05/29 01:43:14 hobbs Exp $ +# RCS: @(#) $Id: entry.tcl,v 1.14 2001/03/29 11:05:49 mdejong Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -390,6 +390,9 @@ proc tkEntryMouseSelect {w x} { $w selection range 0 end } } + if {$tkPriv(mouseMoved)} { + $w icursor $cur + } update idletasks } diff --git a/library/text.tcl b/library/text.tcl index 742f82f..79a49e1 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -3,7 +3,7 @@ # This file defines the default bindings for Tk text widgets and provides # procedures that help in implementing the bindings. # -# RCS: @(#) $Id: text.tcl,v 1.13 2000/07/19 23:22:20 ericm Exp $ +# RCS: @(#) $Id: text.tcl,v 1.14 2001/03/29 11:05:49 mdejong Exp $ # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -581,15 +581,9 @@ proc tkTextSelectTo {w x y {extend 0}} { } } if {$tkPriv(mouseMoved) || [string compare $tkPriv(selectMode) "char"]} { - if {[string compare $tcl_platform(platform) "unix"] \ - && [$w compare $cur < anchor]} { - $w mark set insert $first - } else { - $w mark set insert $last - } - $w tag remove sel 0.0 $first + $w tag remove sel 0.0 end + $w mark set insert $cur $w tag add sel $first $last - $w tag remove sel $last end update idletasks } } diff --git a/tests/event.test b/tests/event.test index f1d0450..42dc3e4 100644 --- a/tests/event.test +++ b/tests/event.test @@ -6,7 +6,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: event.test,v 1.5 2000/04/10 22:43:13 ericm Exp $ +# RCS: @(#) $Id: event.test,v 1.6 2001/03/29 11:05:49 mdejong Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] @@ -22,6 +22,150 @@ raise . # 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] + + event generate $win + _pause 50 + 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 } { + foreach {x1 y1 x2 y2} [$text bbox $ind] break + set middle_y [expr {$y1 + (($y2 - $y1) / 2)}] + return [list $x1 $middle_y] +} + + + + +# Begining of the actual tests + test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { button .b -text Test pack .b @@ -51,19 +195,261 @@ test event-1.2 {event generate } { destroy .e set ::event12result } 1 -# cleanup -::tcltest::cleanupTests -return +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 + focus -force $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 + focus -force $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 + focus -force $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 + focus -force $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 + focus -force $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 + focus -force $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 + focus -force $e + _keypress_string $e "A Tcl/Tk selection test!" + set anchor 1.6 + set selend 1.18 + + set result [list [$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 [$e get sel.first sel.last] + + # 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 [$e get sel.first sel.last] + +} {{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 + focus -force $e + _keypress_string $e "A Tcl/Tk selection test!" + set anchor 6 + set selend 18 + + set result [list [$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 [selection get] + + # 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 [selection get] + +} {{A Tcl/Tk selection test!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} + + + +# cleanup + +destroy .t + +unset keypress_lookup +rename _init_keypress_lookup {} +rename _keypress_lookup {} +rename _keypress {} +rename _pause {} +rename _text_ind_to_x_y {} + +::tcltest::cleanupTests +return -- cgit v0.12