path: root/tests/event.test

# 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.8 2002/02/14 12:13:51 mdejong Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

foreach i [winfo children .] {
    destroy $i
}
wm geometry . {}
raise .

# 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]

    event generate $win <KeyPress-$keysym>
    _pause 50
    event generate $win <KeyRelease-$keysym>
    _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 width height} [$text bbox $ind] 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 <Destroy> {
	lappend x destroy
	event generate .b <1>
	event generate .b <ButtonRelease-1>
    }
    bind .b <1> {
	lappend x button
    }
    set x {}
    destroy .b
    set x
} {destroy}

test event-1.2 {event generate <Alt-z>} {
	catch {destroy .e}
	catch {unset ::event12result}
	set ::event12result 0
	pack [entry .e]
	update
	bind .e <Alt-z> {set ::event12result "1"}
	focus -force .e ; event generate .e <Alt-z>
	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 <Return> {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 <Enter>
    for {set i 0} {$i < 3} {incr i} {
        _pause 100
        event generate $e <ButtonPress-1>
        _pause 100
        event generate $e <ButtonRelease-1>
    }

    _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 <Return> {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 <Enter>
    for {set i 0} {$i < 3} {incr i} {
        _pause 100
        event generate $e <ButtonPress-1>
        _pause 100
        event generate $e <ButtonRelease-1>
    }

    _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]
    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 <Enter>
    event generate $e <ButtonPress-1> -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 <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
    _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 <ButtonPress-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
    }

    event generate $e <ButtonRelease-1> -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
    focus -force $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 <Enter>
    event generate $e <ButtonPress-1> -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 <B1-Motion> -x $current_x -y $current_y
        incr current
        _pause 50
    }

    event generate $e <ButtonRelease-1> -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 <ButtonPress-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
    }

    event generate $e <ButtonRelease-1> -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}}



# cleanup

destroy .t

unset 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