From 07296cfdb73a6d68eb6b921fd25c7c9dacdf1eec Mon Sep 17 00:00:00 2001 From: Keith Seitz Date: Tue, 24 Sep 2002 20:24:18 +0000 Subject: import tk 8.4.0 --- tcl/tests/bind.test | 2681 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2681 insertions(+) create mode 100644 tcl/tests/bind.test (limited to 'tcl/tests/bind.test') diff --git a/tcl/tests/bind.test b/tcl/tests/bind.test new file mode 100644 index 00000000000..536188c0a6d --- /dev/null +++ b/tcl/tests/bind.test @@ -0,0 +1,2681 @@ +# 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$ + +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 + +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 + 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