# This file is a Tcl script to test out Tk's "bind" and "bindtags"

# commands plus the procedures in tkBind.c.

#

# Copyright © 1994 The Regents of the University of California.

# Copyright © 1994-1995 Sun Microsystems, Inc.

# Copyright © 1998-1999 Scriptics Corporation.

# All rights reserved.

#

# TESTFILE INITIALIZATION

#

package require tcltest 2.2; # needed in mode -singleproc 0

# Load the main script main.tcl, which takes care of:

# - setup for the application and the root window

# - importing commands from the tcltest namespace

# - loading of the testutils mechanism along with its utility procs

# - loading of Tk specific test constraints (additionally to constraints

# provided by the package tcltest)

source [file join [tcltest::configure -testdir] main.tcl]

# Ensure a pristine initial window state

resetWindows

#

# COMMON TEST SETUP

#

tk useinputmethods 0

toplevel .t -width 100 -height 50

wm geom .t +0+0

update idletasks

foreach p [event info] {event delete $p}

foreach event [bind Test] {

bind Test $event {}

}

foreach event [bind all] {

bind all $event {}

}

# move the mouse pointer away of the testing area

# otherwise some spurious events may pollute the tests

toplevel .top

wm geometry .top 50x50-50-50

update

event generate .top <Button-1> -warp 1

controlPointerWarpTiming

destroy .top

#

# LOCAL UTILITY PROCS

#

proc testKey {window event type mods} {

global keyInfo numericKeysym

set keyInfo {}

set numericKeysym {}

bind $window <Key> {

set keyInfo [format "%K,0x%%X,0x%%X,%A" %N %k]

set numericKeysym %N

}

focus -force $window

update

event generate $window $event

if {$keyInfo == {}} {

vwait keyInfo

}

set save $keyInfo

set keyInfo {}

set injectcmd [list testinjectkeyevent $type $numericKeysym]

foreach {option} $mods {

lappend injectcmd $option

}

eval $injectcmd

if {$keyInfo == {}} {

vwait keyInfo

}

if {$save != $keyInfo} {

return "[format "0x%x" $numericKeysym] ($mods): $save != $keyInfo"

}

return pass

}

proc testKeyWithMods {window keysym type} {

set result [testKey $window "<$keysym>" $type {}]

if {$result != {pass}} {

return $result

}

set result [testKey $window "<Shift-$keysym>" $type {-shift}]

if {$result != {pass}} {

return $result

}

set result [testKey $window "<Option-$keysym>" $type {-option}]

if {$result != {pass}} {

return $result

}

set result [testKey $window "<Shift-Option-$keysym>" $type {-shift -option}]

if {$result != {pass}} {

return $result

}

return pass

}

proc unsetBindings {} {

bind all <Enter> {}

bind Test <Enter> {}

bind Toplevel <Enter> {}

bind xyz <Enter> {}

bind {a b} <Enter> {}

bind .t <Enter> {}

}

#

# TESTS

#

test bind-1.1 {bind command} -body {

bind

} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}

test bind-1.2 {bind command} -body {

bind a b c d

} -returnCodes error -result {wrong # args: should be "bind window ?pattern? ?command?"}

test bind-1.3 {bind command} -body {

bind .gorp

} -returnCodes error -result {bad window path name ".gorp"}

test bind-1.4 {bind command} -body {

bind foo

} -returnCodes ok -result {}

test bind-1.5 {bind command} -body {

bind .t <gorp-> {}

} -returnCodes ok -result {}

test bind-1.6 {bind command} -body {

frame .t.f

bind .t.f <Enter> {test script}

set result [bind .t.f <Enter>]

bind .t.f <Enter> {}

list $result [bind .t.f <Enter>]

} -cleanup {

destroy .t.f

} -result {{test script} {}}

test bind-1.7 {bind command} -body {

frame .t.f

bind .t.f <Enter> {test script}

bind .t.f <Enter> {+more text}

bind .t.f <Enter>

} -cleanup {

destroy .t.f

} -result {test script

more text}

test bind-1.8 {bind command} -body {

bind .t <gorp-> {test script}

} -returnCodes error -result {bad event type or keysym "gorp"}

test bind-1.9 {bind command} -body {

catch {bind .t <gorp-> {test script}}

bind .t

} -result {}

test bind-1.10 {bind command} -body {

bind .t <gorp->

} -returnCodes ok -result {}

test bind-1.11 {bind command} -body {

frame .t.f

bind .t.f <Enter> {script 1}

bind .t.f <Leave> {script 2}

bind .t.f a {script for a}

bind .t.f b {script for b}

lsort [bind .t.f]

} -cleanup {

destroy .t.f

} -result {<Enter> <Leave> a b}

test bind-2.1 {bindtags command} -body {

bindtags

} -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"}

test bind-2.2 {bindtags command} -body {

bindtags a b c

} -returnCodes error -result {wrong # args: should be "bindtags window ?taglist?"}

test bind-2.3 {bindtags command} -body {

bindtags .foo

} -returnCodes error -result {bad window path name ".foo"}

test bind-2.4 {bindtags command} -body {

bindtags .t

} -result {.t Toplevel all}

test bind-2.5 {bindtags command} -body {

frame .t.f

bindtags .t.f

} -cleanup {

destroy .t.f

} -result {.t.f Frame .t all}

test bind-2.6 {bindtags command} -body {

frame .t.f

bindtags .t.f {{x y z} b c d}

bindtags .t.f

} -cleanup {

destroy .t.f

} -result {{x y z} b c d}

test bind-2.7 {bindtags command} -body {

frame .t.f

bindtags .t.f {x y z}

bindtags .t.f {}

bindtags .t.f

} -cleanup {

destroy .t.f

} -result {.t.f Frame .t all}

test bind-2.8 {bindtags command} -body {

frame .t.f

bindtags .t.f {x y z}

bindtags .t.f {a b c d}

bindtags .t.f

} -cleanup {

destroy .t.f

} -result {a b c d}

test bind-2.9 {bindtags command} -body {

frame .t.f

bindtags .t.f {a b c}

bindtags .t.f "\{"

} -cleanup {

destroy .t.f

} -returnCodes error -result {unmatched open brace in list}

test bind-2.10 {bindtags command} -body {

frame .t.f

bindtags .t.f {a b c}

catch {bindtags .t.f "\{"}

bindtags .t.f

} -cleanup {

destroy .t.f

} -result {.t.f Frame .t all}

test bind-2.11 {bindtags command} -body {

frame .t.f

bindtags .t.f {a b c}

bindtags .t.f "a .gorp b"

} -cleanup {

destroy .t.f

} -returnCodes ok

test bind-2.12 {bindtags command} -body {

frame .t.f

bindtags .t.f {a b c}

catch {bindtags .t.f "a .gorp b"}

bindtags .t.f

} -cleanup {

destroy .t.f

} -result {a .gorp b}

test bind-3.1 {TkFreeBindingTags procedure} -body {

frame .t.f

bindtags .t.f "a b c d"

destroy .t.f

} -cleanup {

destroy .t.f

} -result {}

test bind-3.2 {TkFreeBindingTags procedure} -body {

frame .t.f

catch {bindtags .t.f "a .gorp b .t.f"}

destroy .t.f

} -cleanup {

destroy .t.f

} -result {}

test bind-4.1 {TkBindEventProc procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

update

set x {}

} -body {

bind all <Enter> {lappend x "%W enter all"}

bind Test <Enter> {lappend x "%W enter frame"}

bind Toplevel <Enter> {lappend x "%W enter toplevel"}

bind xyz <Enter> {lappend x "%W enter xyz"}

bind {a b} <Enter> {lappend x "%W enter {a b}"}

bind .t <Enter> {lappend x "%W enter .t"}

bind .t.f <Enter> {lappend x "%W enter .t.f"}

event generate .t.f <Enter>

return $x

} -cleanup {

destroy .t.f

unsetBindings

} -result {{.t.f enter .t.f} {.t.f enter frame} {.t.f enter .t} {.t.f enter all}}

test bind-4.2 {TkBindEventProc procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

update

set x {}

} -body {

bind all <Enter> {lappend x "%W enter all"}

bind Test <Enter> {lappend x "%W enter frame"}

bind Toplevel <Enter> {lappend x "%W enter toplevel"}

bind xyz <Enter> {lappend x "%W enter xyz"}

bind {a b} <Enter> {lappend x "%W enter {a b}"}

bind .t <Enter> {lappend x "%W enter .t"}

bind .t.f <Enter> {lappend x "%W enter .t.f"}

bindtags .t.f {.t.f {a b} xyz}

event generate .t.f <Enter>

return $x

} -cleanup {

destroy .t.f

unsetBindings

} -result {{.t.f enter .t.f} {.t.f enter {a b}} {.t.f enter xyz}}

test bind-4.3 {TkBindEventProc procedure} -body {

set x {}

bind all <Enter> {lappend x "%W enter all"}

bind Test <Enter> {lappend x "%W enter frame"}

bind Toplevel <Enter> {lappend x "%W enter toplevel"}

bind xyz <Enter> {lappend x "%W enter xyz"}

bind {a b} <Enter> {lappend x "%W enter {a b}"}

bind .t <Enter> {lappend x "%W enter .t"}

event generate .t <Enter>

return $x

} -cleanup {

unsetBindings

} -result {{.t enter .t} {.t enter toplevel} {.t enter all}}

test bind-4.4 {TkBindEventProc procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

frame .t.f3 -width 50 -height 50

pack .t.f3

update

set x {}

} -body {

bind all <Enter> {lappend x "%W enter all"}

bind Test <Enter> {lappend x "%W enter frame"}

bind Toplevel <Enter> {lappend x "%W enter toplevel"}

bind xyz <Enter> {lappend x "%W enter xyz"}

bind {a b} <Enter> {lappend x "%W enter {a b}"}

bind .t <Enter> {lappend x "%W enter .t"}

bindtags .t.f {.t.f .t.f2 .t.f3}

bind .t.f <Enter> {lappend x "%W enter .t.f"}

bind .t.f3 <Enter> {lappend x "%W enter .t.f3"}

event generate .t.f <Enter>

return $x

} -cleanup {

destroy .t.f .t.f3

unsetBindings

} -result {{.t.f enter .t.f} {.t.f enter .t.f3}}

test bind-4.5 {TkBindEventProc procedure} -setup {

# This tests memory allocation for objPtr; it won't serve any useful

# purpose unless run with some sort of allocation checker turned on.

frame .t.f -class Test -width 150 -height 100

pack .t.f

update

} -body {

bind all <Enter> {lappend x "%W enter all"}

bind Test <Enter> {lappend x "%W enter frame"}

bind Toplevel <Enter> {lappend x "%W enter toplevel"}

bind xyz <Enter> {lappend x "%W enter xyz"}

bind {a b} <Enter> {lappend x "%W enter {a b}"}

bind .t <Enter> {lappend x "%W enter .t"}

bindtags .t.f {a b c d e f g h i j k l m n o p q r s t u v w x y z}

event generate .t.f <Enter>

} -cleanup {

destroy .t.f

unsetBindings

} -result {}

test bind-5.1 {Tk_CreateBindingTable procedure} -body {

canvas .t.c

.t.c bind foo

} -cleanup {

destroy .t.c

} -result {}

test bind-6.1 {Tk_DeleteBindTable procedure} -body {

canvas .t.c

.t.c bind foo <Button-1> {string 1}

.t.c create rectangle 0 0 100 100

.t.c bind 1 <Button-2> {string 2}

destroy .t.c

} -cleanup {

destroy .t.c

} -result {}

test bind-7.1 {Tk_CreateBinding procedure: bad binding} -body {

canvas .t.c

.t.c bind foo <

} -cleanup {

destroy .t.c

} -returnCodes error -result {no event type or button # or keysym}

test bind-7.3 {Tk_CreateBinding procedure: append} -body {

canvas .t.c

.t.c bind foo <Button-1> "button 1"

.t.c bind foo <Button-1> "+more button 1"

.t.c bind foo <Button-1>

} -cleanup {

destroy .t.c

} -result {button 1

more button 1}

test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} -body {

canvas .t.c

.t.c bind foo <Button-1> "+button 1"

.t.c bind foo <Button-1>

} -cleanup {

destroy .t.c

} -result {button 1}

test bind-8.1 {Tk_CreateBinding: error} -body {

bind . <xyz> "xyz"

} -returnCodes error -result {bad event type or keysym "xyz"}

test bind-9.1 {Tk_DeleteBinding procedure} -body {

frame .t.f -class Test -width 150 -height 100

bind .t.f <

} -cleanup {

destroy .t.f

} -returnCodes ok

test bind-9.2 {Tk_DeleteBinding procedure} -setup {

set result {}

} -body {

frame .t.f -class Test -width 150 -height 100

foreach i {a b c d} {

bind .t.f $i "binding for $i"

}

foreach i {b d a c} {

bind .t.f $i {}

lappend result [lsort [bind .t.f]]

}

return $result

} -cleanup {

destroy .t.f

} -result {{a c d} {a c} c {}}

test bind-9.3 {Tk_DeleteBinding procedure} -setup {

set result {}

} -body {

frame .t.f -class Test -width 150 -height 100

foreach i {<Button-1> <Meta-Button-1> <Control-Button-1> <Double-Alt-Button-1>} {

bind .t.f $i "binding for $i"

}

foreach i {<Control-Button-1> <Double-Alt-Button-1> <Button-1> <Meta-Button-1>} {

bind .t.f $i {}

lappend result [lsort [bind .t.f]]

}

return $result

} -cleanup {

destroy .t.f

} -result {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}}

test bind-10.1 {Tk_GetBinding procedure} -body {

canvas .t.c

.t.c bind foo <

} -cleanup {

destroy .t.c

} -returnCodes error -result {no event type or button # or keysym}

test bind-10.2 {Tk_GetBinding procedure} -body {

canvas .t.c

.t.c bind foo a Test

.t.c bind foo a

} -cleanup {

destroy .t.c

} -result {Test}

test bind-11.1 {Tk_GetAllBindings procedure} -body {

frame .t.f

foreach i "! a \\\{ ~ <Delete> <space> <<Paste>> <Tab> <Linefeed> <Key-<> <Meta-a> <Â>" {

bind .t.f $i Test

}

lsort [bind .t.f]

} -cleanup {

destroy .t.f

} -result "! <<Paste>> <Key-<> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-space> <Key-Â> <Meta-Key-a> a \\\{ ~"

test bind-11.2 {Tk_GetAllBindings procedure} -body {

frame .t.f

foreach i "<Double-Button-1> <Triple-Button-1> <Meta-Control-a> <Double-Alt-Enter> <Button-1>" {

bind .t.f $i Test

}

lsort [bind .t.f]

} -cleanup {

destroy .t.f

} -result {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>}

test bind-11.3 {Tk_GetAllBindings procedure} -body {

frame .t.f

foreach i "<Double-Triple-Button-1> abcd a<Leave>b" {

bind .t.f $i Test

}

lsort [bind .t.f]

} -cleanup {

destroy .t.f

} -result {<Triple-Button-1> a<Leave>b abcd}

test bind-12.1 {Tk_DeleteAllBindings procedure} -body {

frame .t.f -class Test -width 150 -height 100

destroy .t.f

} -result {}

test bind-12.2 {Tk_DeleteAllBindings procedure} -body {

frame .t.f -class Test -width 150 -height 100

foreach i "a b c <Meta-Button-1> <Alt-a> <Control-a>" {

bind .t.f $i x

}

destroy .t.f

} -result {}

test bind-13.1 {Tk_BindEvent procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind Test <Key> {lappend x "%W %K Test Key"}

bind all <Key> {lappend x "%W %K all Key"}

bind Test : {lappend x "%W %K Test :"}

bind all _ {lappend x "%W %K all _"}

bind .t.f : {lappend x "%W %K .t.f :"}

event generate .t.f <:>

event generate .t.f <+>

event generate .t.f <_>

return $x

} -cleanup {

destroy .t.f

bind all <Key> {}

bind Test <Key> {}

bind all _ {}

bind Test : {}

} -result {{.t.f : .t.f :} {.t.f : Test :} {.t.f : all Key} {.t.f + Test Key} {.t.f + all Key} {.t.f _ Test Key} {.t.f _ all _}}

test bind-13.2 {Tk_BindEvent procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind Test <Key> {lappend x "%W %K Test press any"; break}

bind all <Key> {continue; lappend x "%W %K all press any"}

bind .t.f : {lappend x "%W %K .t.f pressed colon"}

event generate .t.f <:>

return $x

} -cleanup {

destroy .t.f

bind all <Key> {}

bind Test <Key> {}

} -result {{.t.f : .t.f pressed colon} {.t.f : Test press any}}

test bind-13.3 {Tk_BindEvent procedure} -setup {

proc bgerror args {}

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind Test <Key> {lappend x "%W %K Test press any"; error Test}

bind .t.f : {lappend x "%W %K .t.f pressed colon"}

event generate .t.f <:>

update

list $x $errorInfo

} -cleanup {

destroy .t.f

bind Test <Key> {}

rename bgerror {}

} -result {{{.t.f : .t.f pressed colon} {.t.f : Test press any}} {Test

while executing

"error Test"

(command bound to event)}}

test bind-13.4 {Tk_BindEvent procedure} -setup {

proc foo {} {

set x 44

event generate .t.f <:>

}

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind Test : {lappend x "%W %K Test"}

bind .t.f : {lappend x "%W %K .t.f"}

foo

return $x

} -cleanup {

destroy .t.f

bind Test : {}

} -result {{.t.f : .t.f} {.t.f : Test}}

test bind-13.5 {Tk_BindEvent procedure} -body {

bind all <Destroy> {lappend x "%W destroyed"}

set x {}

frame .t.g -gorp foo

} -cleanup {

bind all <Destroy> {}

} -returnCodes error -result {unknown option "-gorp"}

test bind-13.6 {Tk_BindEvent procedure} -body {

bind all <Destroy> {lappend x "%W destroyed"}

set x {}

catch {frame .t.g -gorp foo}

return $x

} -cleanup {

bind all <Destroy> {}

} -result {{.t.g destroyed}}

test bind-13.7 {Tk_BindEvent procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f : {lappend x "%W (.t.f binding)"}

bind Test : {lappend x "%W (Test binding)"}

bind all : {bind .t.f : {}; lappend x "%W (all binding)"}

event generate .t.f <:>

return $x

} -cleanup {

bind Test : {}

bind all : {}

destroy .t.f

} -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}}

test bind-13.8 {Tk_BindEvent procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f : {lappend x "%W (.t.f binding)"}

bind Test : {lappend x "%W (Test binding)"}

bind all : {destroy .t.f; lappend x "%W (all binding)"}

event generate .t.f <:>

return $x

} -cleanup {

bind Test : {}

bind all : {}

destroy .t.f

} -result {{.t.f (.t.f binding)} {.t.f (Test binding)} {.t.f (all binding)}}

test bind-13.9 {Tk_BindEvent procedure} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button-1> {lappend x "%W z (.t.f <Button-1> binding)"}

bind .t.f <Button> {lappend x "%W z (.t.f <Button> binding)"}

event generate .t.f <Button-1>

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

} -result {{.t.f z (.t.f <Button-1> binding)} {.t.f z (.t.f <Button> binding)}}

test bind-13.10 {Tk_BindEvent procedure: don't ignore NotifyInferior - bug 47d4f29159} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Enter> "lappend x Enter%#"

bind .t.f <Leave> "lappend x Leave%#"

event generate .t.f <Enter> -serial 100 -detail NotifyAncestor

event generate .t.f <Enter> -serial 101 -detail NotifyInferior

event generate .t.f <Leave> -serial 102 -detail NotifyAncestor

event generate .t.f <Leave> -serial 103 -detail NotifyInferior

return $x

} -cleanup {

destroy .t.f

} -result {Enter100 Enter101 Leave102 Leave103}

test bind-13.11 {Tk_BindEvent procedure: collapse Motions} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Motion> "lappend x Motion%#(%x,%y)"

event generate .t.f <Motion> -serial 100 -x 100 -y 200 -when tail

update

event generate .t.f <Motion> -serial 101 -x 200 -y 300 -when tail

event generate .t.f <Motion> -serial 102 -x 300 -y 400 -when tail

update

return $x

} -cleanup {

destroy .t.f

} -result {Motion100(100,200) Motion102(300,400)}

test bind-13.12 {Tk_BindEvent procedure: collapse repeating modifiers} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

} -body {

bind .t.f <Key> "lappend x %K%#"

bind .t.f <KeyRelease> "lappend x %K%#"

event generate .t.f <Shift_L> -serial 100 -when tail

event generate .t.f <KeyRelease-Shift_L> -serial 101 -when tail

event generate .t.f <Shift_L> -serial 102 -when tail

event generate .t.f <KeyRelease-Shift_L> -serial 103 -when tail

update

} -cleanup {

destroy .t.f

} -result {}

test bind-13.13 {Tk_BindEvent procedure: valid key detail} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Key> "lappend x Key%K"

bind .t.f <KeyRelease> "lappend x Release%K"

event generate .t.f <Key> -keysym :

event generate .t.f <KeyRelease> -keysym :

return $x

} -cleanup {

destroy .t.f

} -result {Key: Release:}

test bind-13.14 {Tk_BindEvent procedure: invalid key detail} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Key> "lappend x Key%K"

bind .t.f <KeyRelease> "lappend x Release%K"

event generate .t.f <Key> -keycode -1

event generate .t.f <KeyRelease> -keycode -1

return $x

} -cleanup {

destroy .t.f

} -result {Key?? Release??}

test bind-13.15 {Tk_BindEvent procedure: button detail} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button> "lappend x Button%b"

bind .t.f <ButtonRelease> "lappend x Release%b"

event generate .t.f <Button> -button 1

event generate .t.f <ButtonRelease> -button 3

set x

} -cleanup {

destroy .t.f

} -result {Button1 Release3}

test bind-13.16 {Tk_BindEvent procedure: virtual detail} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <<Paste>> "lappend x Paste"

event generate .t.f <<Paste>>

return $x

} -cleanup {

destroy .t.f

} -result {Paste}

test bind-13.17 {Tk_BindEvent procedure: virtual event in event stream} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <<Paste>> "lappend x Paste"

event generate .t.f <<Paste>>

return $x

} -cleanup {

destroy .t.f

} -result {Paste}

test bind-13.18 {Tk_BindEvent procedure: match detail physical} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button-2> {set x Button-2}

event add <<Paste>> <Button-2>

bind .t.f <<Paste>> {set x Paste}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button-2>

} -result {Button-2}

test bind-13.19 {Tk_BindEvent procedure: no match detail physical} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button-2>

bind .t.f <<Paste>> {set x Paste}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button-2>

} -result {Paste}

test bind-13.20 {Tk_BindEvent procedure: match detail virtual} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button-2>

bind .t.f <<Paste>> "lappend x Paste"

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button-2>

} -result {Paste}

test bind-13.21 {Tk_BindEvent procedure: no match detail virtual} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button-2>

bind .t.f <<Paste>> "lappend x Paste"

event generate .t.f <Button>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button-2>

} -result {}

test bind-13.22 {Tk_BindEvent procedure: match no-detail physical} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button> {set x Button}

event add <<Paste>> <Button>

bind .t.f <<Paste>> {set x Paste}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button>

} -result {Button}

test bind-13.23 {Tk_BindEvent procedure: no match no-detail physical} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button>

bind .t.f <<Paste>> {set x Paste}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button>

} -result {Paste}

test bind-13.24 {Tk_BindEvent procedure: match no-detail virtual} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button>

bind .t.f <<Paste>> "lappend x Paste"

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button>

} -result {Paste}

test bind-13.25 {Tk_BindEvent procedure: no match no-detail virtual} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Key>

bind .t.f <<Paste>> "lappend x Paste"

event generate .t.f <Button>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Key>

} -result {}

test bind-13.26 {Tk_BindEvent procedure: precedence} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button-2>

event add <<Copy>> <Button>

bind .t.f <Button-2> "lappend x Button-2"

bind .t.f <<Paste>> "lappend x Paste"

bind .t.f <Button> "lappend x Button"

bind .t.f <<Copy>> "lappend x Copy"

event generate .t.f <Button-2>

bind .t.f <Button-2> {}

event generate .t.f <Button-2>

bind .t.f <<Paste>> {}

event generate .t.f <Button-2>

bind .t.f <Button> {}

event generate .t.f <Button-2>

bind .t.f <<Copy>> {}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button-2>

event delete <<Copy>> <Button>

} -result {Button-2 Paste Button Copy}

test bind-13.27 {Tk_BindEvent procedure: no detail virtual pattern list} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button-2> {set x Button-2}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

} -result {Button-2}

test bind-13.28 {Tk_BindEvent procedure: detail virtual pattern list} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button-2>

bind .t.f <<Paste>> {set x Paste}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button-2>

} -result {Paste}

test bind-13.29 {Tk_BindEvent procedure: no no-detail virtual pattern list} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button> {set x Button}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

} -result {Button}

test bind-13.30 {Tk_BindEvent procedure: no-detail virtual pattern list} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

event add <<Paste>> <Button>

bind .t.f <<Paste>> {set x Paste}

event generate .t.f <Button-2>

return $x

} -cleanup {

destroy .t.f

event delete <<Paste>> <Button>

} -result {Paste}

test bind-13.31 {Tk_BindEvent procedure: no match} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

} -body {

event generate .t.f <Button-2>

} -cleanup {

destroy .t.f

} -result {}

test bind-13.32 {Tk_BindEvent procedure: match} -setup {

frame .t.f -class Test -width 150 -height 100

pack .t.f

focus -force .t.f

update

set x {}

} -body {

bind .t.f <Button-2> {set x Button-2}

event generate .t.f <Button-2>

return $x

} -cleanup {