# 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. # # RCS: @(#) $Id: bind.test,v 1.1.1.2 2009/03/24 10:20:26 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 tk useinputmethods 0 catch {destroy .b} toplevel .b -width 100 -height 50 wm geom .b +0+0 update idletasks proc setup {} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 pack .b.f focus -force .b.f foreach p [event info] {event delete $p} update } setup foreach i [bind Test] { bind Test $i {} } foreach i [bind all] { bind all $i {} } test bind-1.1 {bind command} { list [catch {bind} msg] $msg } {1 {wrong # args: should be "bind window ?pattern? ?command?"}} test bind-1.2 {bind command} { list [catch {bind a b c d} msg] $msg } {1 {wrong # args: should be "bind window ?pattern? ?command?"}} test bind-1.3 {bind command} { list [catch {bind .gorp} msg] $msg } {1 {bad window path name ".gorp"}} test bind-1.4 {bind command} { list [catch {bind foo} msg] $msg } {0 {}} test bind-1.5 {bind command} { list [catch {bind .b {}} msg] $msg } {0 {}} test bind-1.6 {bind command} { catch {destroy .b.f} frame .b.f bind .b.f {test script} set result [bind .b.f ] bind .b.f {} list $result [bind .b.f ] } {{test script} {}} test bind-1.7 {bind command} { catch {destroy .b.f} frame .b.f bind .b.f {test script} bind .b.f {+more text} bind .b.f } {test script more text} test bind-1.8 {bind command} { list [catch {bind .b {test script}} msg] $msg [bind .b] } {1 {bad event type or keysym "gorp"} {}} test bind-1.9 {bind command} { list [catch {bind .b } msg] $msg } {0 {}} test bind-1.10 {bind command} { catch {destroy .b.f} frame .b.f bind .b.f {script 1} bind .b.f {script 2} bind .b.f a {script for a} bind .b.f b {script for b} lsort [bind .b.f] } { a b} test bind-2.1 {bindtags command} { list [catch {bindtags} msg] $msg } {1 {wrong # args: should be "bindtags window ?taglist?"}} test bind-2.2 {bindtags command} { list [catch {bindtags a b c} msg] $msg } {1 {wrong # args: should be "bindtags window ?taglist?"}} test bind-2.3 {bindtags command} { list [catch {bindtags .foo} msg] $msg } {1 {bad window path name ".foo"}} test bind-2.4 {bindtags command} { bindtags .b } {.b Toplevel all} test bind-2.5 {bindtags command} { catch {destroy .b.f} frame .b.f bindtags .b.f } {.b.f Frame .b all} test bind-2.6 {bindtags command} { catch {destroy .b.f} frame .b.f bindtags .b.f {{x y z} b c d} bindtags .b.f } {{x y z} b c d} test bind-2.7 {bindtags command} { catch {destroy .b.f} frame .b.f bindtags .b.f {x y z} bindtags .b.f {} bindtags .b.f } {.b.f Frame .b all} test bind-2.8 {bindtags command} { catch {destroy .b.f} frame .b.f bindtags .b.f {x y z} bindtags .b.f {a b c d} bindtags .b.f } {a b c d} test bind-2.9 {bindtags command} { catch {destroy .b.f} frame .b.f bindtags .b.f {a b c} list [catch {bindtags .b.f "\{"} msg] $msg [bindtags .b.f] } {1 {unmatched open brace in list} {.b.f Frame .b all}} test bind-2.10 {bindtags command} { catch {destroy .b.f} frame .b.f bindtags .b.f {a b c} list [catch {bindtags .b.f "a .gorp b"} msg] $msg [bindtags .b.f] } {0 {} {a .gorp b}} test bind-3.1 {TkFreeBindingTags procedure} { catch {destroy .b.f} frame .b.f bindtags .b.f "a b c d" destroy .b.f } {} test bind-3.2 {TkFreeBindingTags procedure} { catch {destroy .b.f} frame .b.f catch {bindtags .b.f "a .gorp b .b.f"} destroy .b.f } {} 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 .b {lappend x "%W enter .b"} test bind-4.1 {TkBindEventProc procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 pack .b.f update bind .b.f {lappend x "%W enter .b.f"} set x {} event gen .b.f set x } {{.b.f enter .b.f} {.b.f enter frame} {.b.f enter .b} {.b.f enter all}} test bind-4.2 {TkBindEventProc procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 pack .b.f update bind .b.f {lappend x "%W enter .b.f"} bindtags .b.f {.b.f {a b} xyz} set x {} event gen .b.f set x } {{.b.f enter .b.f} {.b.f enter {a b}} {.b.f enter xyz}} test bind-4.3 {TkBindEventProc procedure} { set x {} event gen .b set x } {{.b enter .b} {.b enter toplevel} {.b enter all}} test bind-4.4 {TkBindEventProc procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 pack .b.f update bindtags .b.f {.b.f .b.f2 .b.f3} frame .b.f3 -width 50 -height 50 pack .b.f3 bind .b.f {lappend x "%W enter .b.f"} bind .b.f3 {lappend x "%W enter .b.f3"} set x {} event gen .b.f destroy .b.f3 set x } {{.b.f enter .b.f} {.b.f enter .b.f3}} test bind-4.5 {TkBindEventProc procedure} { # This tests memory allocation for objPtr; it won't serve any useful # purpose unless run with some sort of allocation checker turned on. catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 pack .b.f update bindtags .b.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 gen .b.f } {} bind all {} bind Test {} bind Toplevel {} bind xyz {} bind {a b} {} bind .b {} test bind-5.1 {Tk_CreateBindingTable procedure} { catch {destroy .b.c} canvas .b.c .b.c bind foo } {} testConstraint testcbind [llength [info commands testcbind]] test bind-6.1 {Tk_DeleteBindTable procedure} { catch {destroy .b.c} canvas .b.c .b.c bind foo <1> {string 1} .b.c create rectangle 0 0 100 100 .b.c bind 1 <2> {string 2} destroy .b.c } {} test bind-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} testcbind { catch {interp delete foo} interp create foo foo eval { load {} Tk tk useinputmethods 0 load {} Tktest wm geometry . +0+0 frame .t -width 50 -height 50 bindtags .t {a b c d} pack .t update set x {} testcbind a <1> "lappend x a1; destroy ." "lappend x bye.a1" bind b <1> "lappend x b1" testcbind c <1> "lappend x c1" "lappend x bye.c1" testcbind c <2> "lappend x all2" "lappend x bye.all2" event gen .t <1> } set x [foo eval set x] interp delete foo set x } {a1 bye.all2 bye.a1 b1 bye.c1} test bind-7.1 {Tk_CreateBinding procedure: bad binding} { catch {destroy .b.c} canvas .b.c list [catch {.b.c bind foo <} msg] $msg } {1 {no event type or button # or keysym}} test bind-7.2 {Tk_CreateBinding procedure: replace existing C binding} testcbind { catch {destroy .b.f} frame .b.f testcbind .b.f <1> "xyz" "lappend x bye.1" set x {} bind .b.f <1> "abc" destroy .b.f set x } {bye.1} test bind-7.3 {Tk_CreateBinding procedure: append} { catch {destroy .b.c} canvas .b.c .b.c bind foo <1> "button 1" .b.c bind foo <1> "+more button 1" .b.c bind foo <1> } {button 1 more button 1} test bind-7.4 {Tk_CreateBinding procedure: append to non-existing} { catch {destroy .b.c} canvas .b.c .b.c bind foo <1> "+button 1" .b.c bind foo <1> } {button 1} test bind-8.1 {TkCreateBindingProcedure: error} testcbind { list [catch {testcbind . "xyz"} msg] $msg } {1 {bad event type or keysym "xyz"}} test bind-8.2 {TkCreateBindingProcedure: new binding} testcbind { catch {destroy .b.f} frame .b.f testcbind .b.f <1> "lappend x 1" "lappend x bye.1" set x {} event gen .b.f <1> destroy .b.f set x } {bye.1} test bind-8.3 {TkCreateBindingProcedure: replace existing} testcbind { catch {destroy .b.f} frame .b.f pack .b.f set x {} testcbind .b.f <1> "lappend x old1" "lappend x bye.old1" testcbind .b.f <1> "lappend x new1" "lappend x bye.new1" set x } {bye.old1} test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} testcbind { catch {destroy .b.f} frame .b.f pack .b.f update testcbind .b.f <1> "lappend x .b.f; testcbind Frame <1> {lappend x Frame}" testcbind Frame <1> "lappend x never" set x {} event gen .b.f <1> bind .b.f <1> {} set x } {.b.f Frame} test bind-9.1 {Tk_DeleteBinding procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 list [catch {bind .b.f <} msg] $msg } {0 {}} test bind-9.2 {Tk_DeleteBinding procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 foreach i {a b c d} { bind .b.f $i "binding for $i" } set result {} foreach i {b d a c} { bind .b.f $i {} lappend result [lsort [bind .b.f]] } set result } {{a c d} {a c} c {}} test bind-9.3 {Tk_DeleteBinding procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 foreach i {<1> } { bind .b.f $i "binding for $i" } set result {} foreach i { <1> } { bind .b.f $i {} lappend result [lsort [bind .b.f]] } set result } {{ } { } {}} test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} testcbind { catch {destroy .b.f} frame .b.f pack .b.f update bindtags .b.f {a b c} testcbind a <1> {lappend x a1; bind c <1> {}; bind c <2> {}} {lappend x bye.a1} bind b <1> {lappend x b1} testcbind c <1> {lappend x c1} {lappend x bye.c1} testcbind c <2> {lappend x c2} {lappend x bye.c2} set x {} event gen .b.f <1> bind a <1> {} bind b <1> {} set x } {a1 bye.c2 b1 bye.c1 bye.a1} test bind-10.1 {Tk_GetBinding procedure} { catch {destroy .b.c} canvas .b.c list [catch {.b.c bind foo <} msg] $msg } {1 {no event type or button # or keysym}} test bind-10.2 {Tk_GetBinding procedure} { catch {destroy .b.c} canvas .b.c .b.c bind foo a Test .b.c bind foo a } {Test} test bind-10.3 {Tk_GetBinding procedure: C binding} testcbind { catch {destroy .b.f} frame .b.f testcbind .b.f <1> "foo" list [bind .b.f] [bind .b.f <1>] } { {}} test bind-11.1 {Tk_GetAllBindings procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 foreach i "! a \\\{ ~ <> " { bind .b.f $i Test } lsort [bind .b.f] } {! <> a \{ ~} test bind-11.2 {Tk_GetAllBindings procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 foreach i " <1>" { bind .b.f $i Test } lsort [bind .b.f] } { } test bind-11.3 {Tk_GetAllBindings procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 foreach i " abcd ab" { bind .b.f $i Test } lsort [bind .b.f] } { ab abcd} test bind-12.1 {Tk_DeleteAllBindings procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 destroy .b.f } {} test bind-12.2 {Tk_DeleteAllBindings procedure} { catch {destroy .b.f} frame .b.f -class Test -width 150 -height 100 foreach i "a b c " { bind .b.f $i x } destroy .b.f } {} test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} testcbind { catch {destroy .b.f} frame .b.f pack .b.f update testcbind .b.f <1> {lappend x before; event gen .b.f <2>; lappend x after} {lappend x bye.f1} testcbind .b.f <2> {destroy .b.f} {lappend x bye.f2} bind .b.f {lappend x fDestroy} testcbind .b.f <3> {foo} {lappend x bye.f3} set x {} event gen .b.f <1> set x } {before fDestroy bye.f3 bye.f2 after bye.f1} bind Test {lappend x "%W %K Test press any"} bind all {lappend x "%W %K all press any"} bind Test a {lappend x "%W %K Test press a"} bind all x {lappend x "%W %K all press x"} test bind-13.1 {Tk_BindEvent procedure} { setup bind .b.f a {lappend x "%W %K .b.f press a"} set x {} event gen .b.f event gen .b.f event gen .b.f set x } {{.b.f a .b.f press a} {.b.f a Test press a} {.b.f a all press any} {.b.f b Test press any} {.b.f b all press any} {.b.f x Test press any} {.b.f x all press x}} bind Test {lappend x "%W %K Test press any"; break} bind all {continue; lappend x "%W %K all press any"} test bind-13.2 {Tk_BindEvent procedure} { setup bind .b.f b {lappend x "%W %K .b.f press a"} set x {} event gen .b.f set x } {{.b.f b .b.f press a} {.b.f b Test press any}} if {[info procs bgerror] == "bgerror"} { rename bgerror {} } proc bgerror args {} bind Test {lappend x "%W %K Test press any"; error Test} test bind-13.3 {Tk_BindEvent procedure} { setup bind .b.f b {lappend x "%W %K .b.f press a"} set x {} event gen .b.f update list $x $errorInfo } {{{.b.f b .b.f press a} {.b.f b Test press any}} {Test while executing "error Test" (command bound to event)}} rename bgerror {} test bind-13.4 {Tk_BindEvent procedure} { proc foo {} { set x 44 event gen .b.f } setup bind .b.f a {lappend x "%W %K .b.f press a"} set x {} foo set x } {{.b.f a .b.f press a} {.b.f a Test press a}} test bind-13.5 {Tk_BindEvent procedure} { bind all {lappend x "%W destroyed"} set x {} list [catch {frame .b.g -gorp foo} msg] $msg $x } {1 {unknown option "-gorp"} {{.b.g destroyed}}} foreach i [bind all] { bind all $i {} } foreach i [bind Test] { bind Test $i {} } test bind-13.6 {Tk_BindEvent procedure} { setup bind .b.f z {lappend x "%W z (.b.f binding)"} bind Test z {lappend x "%W z (.b.f binding)"} bind all z {bind .b.f z {}; lappend x "%W z (.b.f binding)"} set x {} event gen .b.f bind Test z {} bind all z {} set x } {{.b.f z (.b.f binding)} {.b.f z (.b.f binding)} {.b.f z (.b.f binding)}} test bind-13.7 {Tk_BindEvent procedure} { setup bind .b.f z {lappend x "%W z (.b.f binding)"} bind Test z {lappend x "%W z (.b.f binding)"} bind all z {destroy .b.f; lappend x "%W z (.b.f binding)"} set x {} event gen .b.f bind Test z {} bind all z {} set x } {{.b.f z (.b.f binding)} {.b.f z (.b.f binding)} {.b.f z (.b.f binding)}} test bind-13.8 {Tk_BindEvent procedure} { setup bind .b.f <1> {lappend x "%W z (.b.f <1> binding)"} bind .b.f {lappend x "%W z (.b.f binding)"} set x {} event gen .b.f event gen .b.f set x } {{.b.f z (.b.f <1> binding)} {.b.f z (.b.f binding)}} test bind-13.9 {Tk_BindEvent procedure: ignore NotifyInferior} { setup bind .b.f "lappend x Enter%#" bind .b.f "lappend x Leave%#" set x {} event gen .b.f -serial 100 -detail NotifyAncestor event gen .b.f -serial 101 -detail NotifyInferior event gen .b.f -serial 102 -detail NotifyAncestor event gen .b.f -serial 103 -detail NotifyInferior set x } {Enter100 Leave102} test bind-13.10 {Tk_BindEvent procedure: collapse Motions} { setup bind .b.f "lappend x Motion%#(%x,%y)" set x {} event gen .b.f -serial 100 -x 100 -y 200 -when tail update event gen .b.f -serial 101 -x 200 -y 300 -when tail event gen .b.f -serial 102 -x 300 -y 400 -when tail update set x } {Motion100(100,200) Motion102(300,400)} test bind-13.11 {Tk_BindEvent procedure: collapse repeating modifiers} { setup bind .b.f "lappend x %K%#" bind .b.f "lappend x %K%#" event gen .b.f -serial 100 -when tail event gen .b.f -serial 101 -when tail event gen .b.f -serial 102 -when tail event gen .b.f -serial 103 -when tail update } {} test bind-13.12 {Tk_BindEvent procedure: valid key detail} { setup bind .b.f "lappend x Key%K" bind .b.f "lappend x Release%K" set x {} event gen .b.f -keysym a event gen .b.f -keysym a set x } {Keya Releasea} test bind-13.13 {Tk_BindEvent procedure: invalid key detail} { setup bind .b.f "lappend x Key%K" bind .b.f "lappend x Release%K" set x {} event gen .b.f -keycode 0 event gen .b.f -keycode 0 set x } {Key?? Release??} test bind-13.14 {Tk_BindEvent procedure: button detail} { setup bind .b.f