# This file is a Tcl script to test out Tk's "bind" and "bindtags" # commands plus the procedures in tkBind.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. package require tcltest 2.2 namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands 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 {} } proc unsetBindings {} { bind all {} bind Test {} bind Toplevel {} bind xyz {} bind {a b} {} bind .t {} } # 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 -warp 1 update destroy .top 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 {} } -returnCodes ok -result {} test bind-1.6 {bind command} -body { frame .t.f bind .t.f {test script} set result [bind .t.f ] bind .t.f {} list $result [bind .t.f ] } -cleanup { destroy .t.f } -result {{test script} {}} test bind-1.7 {bind command} -body { frame .t.f bind .t.f {test script} bind .t.f {+more text} bind .t.f } -cleanup { destroy .t.f } -result {test script more text} test bind-1.8 {bind command} -body { bind .t {test script} } -returnCodes error -result {bad event type or keysym "gorp"} test bind-1.9 {bind command} -body { catch {bind .t {test script}} bind .t } -result {} test bind-1.10 {bind command} -body { bind .t } -returnCodes ok -result {} test bind-1.11 {bind command} -body { frame .t.f bind .t.f {script 1} bind .t.f {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 { 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 {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bind .t.f {lappend x "%W enter .t.f"} event generate .t.f 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 {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bind .t.f {lappend x "%W enter .t.f"} bindtags .t.f {.t.f {a b} xyz} event generate .t.f 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 {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} event generate .t 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 {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {lappend x "%W enter .t"} bindtags .t.f {.t.f .t.f2 .t.f3} bind .t.f {lappend x "%W enter .t.f"} bind .t.f3 {lappend x "%W enter .t.f3"} event generate .t.f 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 {lappend x "%W enter all"} bind Test {lappend x "%W enter frame"} bind Toplevel {lappend x "%W enter toplevel"} bind xyz {lappend x "%W enter xyz"} bind {a b} {lappend x "%W enter {a b}"} bind .t {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 } -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 <1> {string 1} .t.c create rectangle 0 0 100 100 .t.c bind 1 <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 <1> "button 1" .t.c bind foo <1> "+more button 1" .t.c bind foo <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 <1> "+button 1" .t.c bind foo <1> } -cleanup { destroy .t.c } -result {button 1} test bind-8.1 {Tk_CreateBinding: error} -body { bind . "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 {<1> } { bind .t.f $i "binding for $i" } foreach i { <1> } { bind .t.f $i {} lappend result [lsort [bind .t.f]] } return $result } -cleanup { destroy .t.f } -result {{ } { } {}} 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 \\\{ ~ <> " { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f } -result {! <> a \{ ~} test bind-11.2 {Tk_GetAllBindings procedure} -body { frame .t.f foreach i " <1>" { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f } -result { } test bind-11.3 {Tk_GetAllBindings procedure} -body { frame .t.f foreach i " abcd ab" { bind .t.f $i Test } lsort [bind .t.f] } -cleanup { destroy .t.f } -result { ab 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 " { 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 {lappend x "%W %K Test KeyPress"} bind all {lappend x "%W %K all KeyPress"} 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 {} bind Test {} bind all _ {} bind Test : {} } -result {{.t.f colon .t.f :} {.t.f colon Test :} {.t.f colon all KeyPress} {.t.f plus Test KeyPress} {.t.f plus all KeyPress} {.t.f underscore Test KeyPress} {.t.f underscore 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 {lappend x "%W %K Test press any"; break} bind all {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 {} bind Test {} } -result {{.t.f colon .t.f pressed colon} {.t.f colon 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 {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 {} rename bgerror {} } -result {{{.t.f colon .t.f pressed colon} {.t.f colon 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 colon .t.f} {.t.f colon Test}} test bind-13.5 {Tk_BindEvent procedure} -body { bind all {lappend x "%W destroyed"} set x {} frame .t.g -gorp foo } -cleanup { bind all {} } -returnCodes error -result {unknown option "-gorp"} test bind-13.6 {Tk_BindEvent procedure} -body { bind all {lappend x "%W destroyed"} set x {} catch {frame .t.g -gorp foo} return $x } -cleanup { bind all {} } -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 <1> {lappend x "%W z (.t.f <1> binding)"} bind .t.f {lappend x "%W z (.t.f binding)"} event generate .t.f event generate .t.f return $x } -cleanup { destroy .t.f } -result {{.t.f z (.t.f <1> binding)} {.t.f z (.t.f binding)}} test bind-13.10 {Tk_BindEvent procedure: ignore NotifyInferior} -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 Enter%#" bind .t.f "lappend x Leave%#" event generate .t.f -serial 100 -detail NotifyAncestor event generate .t.f -serial 101 -detail NotifyInferior event generate .t.f -serial 102 -detail NotifyAncestor event generate .t.f -serial 103 -detail NotifyInferior return $x } -cleanup { destroy .t.f } -result {Enter100 Leave102} 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 "lappend x Motion%#(%x,%y)" event generate .t.f -serial 100 -x 100 -y 200 -when tail update event generate .t.f -serial 101 -x 200 -y 300 -when tail event generate .t.f -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 "lappend x %K%#" bind .t.f "lappend x %K%#" event generate .t.f -serial 100 -when tail event generate .t.f -serial 101 -when tail event generate .t.f -serial 102 -when tail event generate .t.f -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 "lappend x Key%K" bind .t.f "lappend x Release%K" event generate .t.f -keysym colon event generate .t.f -keysym colon return $x } -cleanup { destroy .t.f } -result {Keycolon Releasecolon} 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 "lappend x Key%K" bind .t.f "lappend x Release%K" event generate .t.f -keycode 0 event generate .t.f -keycode 0 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