From c65a445e5417d6ff91c27f357f0862f3d229130f Mon Sep 17 00:00:00 2001 From: aniap Date: Fri, 25 Jul 2008 13:40:15 +0000 Subject: Update to tcltest2 --- tests/bind.test | 8284 +++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 5975 insertions(+), 2309 deletions(-) diff --git a/tests/bind.test b/tests/bind.test index 77b8373..9f0f941 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -7,2743 +7,6401 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: bind.test,v 1.20 2008/07/23 23:24:26 nijtmans Exp $ +# RCS: @(#) $Id: bind.test,v 1.21 2008/07/25 13:40:15 aniap Exp $ package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands tk useinputmethods 0 -catch {destroy .b} -toplevel .b -width 100 -height 50 -wm geom .b +0+0 +toplevel .t -width 100 -height 50 +wm geom .t +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 +foreach p [event info] {event delete $p} +foreach event [bind Test] { + bind Test $event {} } -setup - -foreach i [bind Test] { - bind Test $i {} +foreach event [bind all] { + bind all $event {} } -foreach i [bind all] { - bind all $i {} + + +proc unsetBindings {} { + bind all {} + bind Test {} + bind Toplevel {} + bind xyz {} + bind {a b} {} + bind .t {} } -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 + +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} { - 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} { +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 gen .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 gen .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 gen .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 gen .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. - 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 -} {} - -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 { + 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 gen .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-6.2 {Tk_DeleteBindTable procedure: pending bindings deleted later} -constraints { + testcbind +} -body { 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> + load {} Tk + tk useinputmethods 0 + load {} Tktest + wm geometry . +0+0 + frame .g -width 50 -height 50 + bindtags .g {a b c d} + pack .g + 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 .g <1> } set x [foo eval set x] + return $x +} -cleanup { 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 + bind a <1> {} + bind b <1> {} + bind c <1> {} + bind c <2> {} + destroy .g +} -result {a1 bye.all2 bye.a1 b1 bye.c1} + +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.2 {Tk_CreateBinding procedure: replace existing C binding} -constraints { + testcbind +} -body { + frame .t.f + set x {} + testcbind .t.f <1> "xyz" "lappend x bye.1" + bind .t.f <1> "abc" + return $x +} -cleanup { + destroy .t.f +} -result {bye.1} +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} { - 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" +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 {TkCreateBindingProcedure: error} -constraints { + testcbind +} -body { + testcbind . "xyz" +} -returnCodes error -result {bad event type or keysym "xyz"} +test bind-8.2 {TkCreateBindingProcedure: new binding} -constraints { + testcbind +} -setup { + frame .t.f set x {} - event gen .b.f <1> - bind .b.f <1> {} - set x -} {.b.f Frame} +} -body { + testcbind .t.f <1> "lappend x 1" "lappend x bye.1" + event gen .t.f <1> + destroy .t.f + return $x +} -result {bye.1} +test bind-8.3 {TkCreateBindingProcedure: replace existing} -constraints { + testcbind +} -setup { + frame .t.f + pack .t.f + set x {} +} -body { + testcbind .t.f <1> "lappend x old1" "lappend x bye.old1" + testcbind .t.f <1> "lappend x new1" "lappend x bye.new1" + return $x +} -cleanup { + destroy .t.f +} -result {bye.old1} +test bind-8.4 {TkCreateBindingProcedure: replace existing while pending} -constraints { + testcbind +} -setup { + frame .t.f + pack .t.f + update + set x {} +} -body { + testcbind .t.f <1> "lappend x .t.f; testcbind Frame <1> {lappend x Frame}" + testcbind Frame <1> "lappend x never" + event gen .t.f <1> + bind .t.f <1> {} + return $x +} -cleanup { + destroy .t.f + bind Frame <1> {} +} -result {.t.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 +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 .b.f $i "binding for $i" + bind .t.f $i "binding for $i" } - set result {} foreach i {b d a c} { - bind .b.f $i {} - lappend result [lsort [bind .b.f]] + bind .t.f $i {} + lappend result [lsort [bind .t.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 + 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 .b.f $i "binding for $i" + bind .t.f $i "binding for $i" } - set result {} foreach i { <1> } { - bind .b.f $i {} - lappend result [lsort [bind .b.f]] + bind .t.f $i {} + lappend result [lsort [bind .t.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} + return $result +} -cleanup { + destroy .t.f +} -result {{ } { } {}} +test bind-9.4 {Tk_DeleteBinding procedure: pending bindings delete later} -constraints { + testcbind +} -setup { + frame .t.f + pack .t.f + update + set x {} +} -body { + bindtags .t.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> + event gen .t.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 + return $x +} -cleanup { + destroy .t.f + bind c <1> {} + bind c <2> {} +} -result {a1 bye.c2 b1 bye.c1 bye.a1} + +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-10.3 {Tk_GetBinding procedure: C binding} -constraints { + testcbind +} -body { + frame .t.f + testcbind .t.f <1> "foo" + list [bind .t.f] [bind .t.f <1>] +} -cleanup { + destroy .t.f +} -result { {}} + + +test bind-11.1 {Tk_GetAllBindings procedure} -body { + frame .t.f foreach i "! a \\\{ ~ <> " { - bind .b.f $i Test + bind .t.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 + 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 .b.f $i Test + bind .t.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 + 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 .b.f $i Test + bind .t.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 + 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 .b.f $i x + bind .t.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 + destroy .t.f +} -result {} +test bind-12.3 {Tk_DeleteAllBindings procedure: pending bindings deleted later} -constraints { + testcbind +} -setup { + frame .t.f + pack .t.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"} +} -body { + testcbind .t.f <1> {lappend x before; event gen .t.f <2>; lappend x after} {lappend x bye.f1} + testcbind .t.f <2> {destroy .t.f} {lappend x bye.f2} + bind .t.f {lappend x fDestroy} + testcbind .t.f <3> {foo} {lappend x bye.f3} + event gen .t.f <1> + return $x +} -cleanup { + destroy .t.f +} -result {before fDestroy bye.f3 bye.f2 after bye.f1} -test bind-13.1 {Tk_BindEvent procedure} { - setup - bind .b.f a {lappend x "%W %K .b.f press a"} +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 {} - 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"} +} -body { + 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"} + bind .t.f a {lappend x "%W %K .t.f press a"} + + event gen .t.f + event gen .t.f + event gen .t.f + return $x +} -cleanup { + destroy .t.f + bind all {} + bind Test {} + bind all x {} + bind Test a {} +} -result {{.t.f a .t.f press a} {.t.f a Test press a} {.t.f a all press any} {.t.f b Test press any} {.t.f b all press any} {.t.f x Test press any} {.t.f x all press x}} -test bind-13.2 {Tk_BindEvent procedure} { - setup - bind .b.f b {lappend x "%W %K .b.f press a"} +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 {} - 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"} +} -body { + bind Test {lappend x "%W %K Test press any"; break} + bind all {continue; lappend x "%W %K all press any"} + bind .t.f b {lappend x "%W %K .t.f press a"} + + event gen .t.f + return $x +} -cleanup { + destroy .t.f + bind all {} + bind Test {} +} -result {{.t.f b .t.f press a} {.t.f b 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 {} - event gen .b.f +} -body { + bind Test {lappend x "%W %K Test press any"; error Test} + bind .t.f b {lappend x "%W %K .t.f press a"} + event gen .t.f update list $x $errorInfo -} {{{.b.f b .b.f press a} {.b.f b Test press any}} {Test +} -cleanup { + destroy .t.f + bind Test {} + rename bgerror {} +} -result {{{.t.f b .t.f press a} {.t.f b Test press any}} {Test while executing "error Test" (command bound to event)}} -rename bgerror {} -test bind-13.4 {Tk_BindEvent procedure} { +test bind-13.4 {Tk_BindEvent procedure} -setup { proc foo {} { - set x 44 - event gen .b.f + set x 44 + event gen .t.f } - setup - bind .b.f a {lappend x "%W %K .b.f press a"} + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} +} -body { + bind Test a {lappend x "%W %K Test press a"} + bind .t.f a {lappend x "%W %K .t.f press a"} foo - set x -} {{.b.f a .b.f press a} {.b.f a Test press a}} -test bind-13.5 {Tk_BindEvent procedure} { + return $x +} -cleanup { + destroy .t.f + bind Test a {} +} -result {{.t.f a .t.f press a} {.t.f a Test press a}} + +test bind-13.5 {Tk_BindEvent procedure} -body { 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)"} + 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 {} - event gen .b.f + 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 z {lappend x "%W z (.t.f binding)"} + bind Test z {lappend x "%W z (.t.f binding)"} + bind all z {bind .t.f z {}; lappend x "%W z (.t.f binding)"} + event gen .t.f + return $x +} -cleanup { 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)"} + destroy .t.f +} -result {{.t.f z (.t.f binding)} {.t.f z (.t.f binding)} {.t.f z (.t.f 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 {} - event gen .b.f +} -body { + bind .t.f z {lappend x "%W z (.t.f binding)"} + bind Test z {lappend x "%W z (.t.f binding)"} + bind all z {destroy .t.f; lappend x "%W z (.t.f binding)"} + event gen .t.f + return $x +} -cleanup { bind Test z {} bind all z {} + destroy .t.f +} -result {{.t.f z (.t.f binding)} {.t.f z (.t.f binding)} {.t.f z (.t.f 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 gen .t.f + event gen .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 gen .t.f -serial 100 -detail NotifyAncestor + event gen .t.f -serial 101 -detail NotifyInferior + event gen .t.f -serial 102 -detail NotifyAncestor + event gen .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 gen .t.f -serial 100 -x 100 -y 200 -when tail + update + event gen .t.f -serial 101 -x 200 -y 300 -when tail + event gen .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 gen .t.f -serial 100 -when tail + event gen .t.f -serial 101 -when tail + event gen .t.f -serial 102 -when tail + event gen .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 gen .t.f -keysym a + event gen .t.f -keysym a + return $x +} -cleanup { + destroy .t.f +} -result {Keya Releasea} +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 gen .t.f -keycode 0 + event gen .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