diff options
Diffstat (limited to 'tests')
88 files changed, 57707 insertions, 24611 deletions
diff --git a/tests/bell.test b/tests/bell.test index 16fea0f..4f7df97 100644 --- a/tests/bell.test +++ b/tests/bell.test @@ -5,32 +5,40 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test bell-1.1 {bell command} { - list [catch {bell a} msg] $msg -} {1 {bad option "a": must be -displayof or -nice}} -test bell-1.2 {bell command} { - list [catch {bell a b} msg] $msg -} {1 {bad option "a": must be -displayof or -nice}} -test bell-1.3 {bell command} { - list [catch {bell -displayof gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test bell-1.4 {bell command} { - list [catch {bell -nice -displayof} msg] $msg -} {1 {wrong # args: should be "bell ?-displayof window? ?-nice?"}} -test bell-1.5 {bell command} { - list [catch {bell -nice -nice -nice} msg] $msg -} {0 {}} -test bell-1.6 {bell command} { - list [catch {bell -displayof . -nice} msg] $msg -} {0 {}} -test bell-1.7 {bell command} { - list [catch {bell -nice -displayof . -nice} msg] $msg -} {1 {wrong # args: should be "bell ?-displayof window? ?-nice?"}} -test bell-1.8 {bell command} { +test bell-1.1 {bell command} -body { + bell a +} -returnCodes {error} -result {bad option "a": must be -displayof or -nice} + +test bell-1.2 {bell command} -body { + bell a b +} -returnCodes {error} -result {bad option "a": must be -displayof or -nice} + +test bell-1.3 {bell command} -body { + bell -displayof gorp +} -returnCodes {error} -result {bad window path name "gorp"} + +test bell-1.4 {bell command} -body { + bell -nice -displayof +} -returnCodes {error} -result {wrong # args: should be "bell ?-displayof window? ?-nice?"} + +test bell-1.5 {bell command} -body { + bell -nice -nice -nice +} -returnCodes {ok} -result {} ;#keep -result {} and -retutnCodes {ok} for clarity? + +test bell-1.6 {bell command} -body { + bell -displayof . -nice +} -returnCodes {ok} -result {} + +test bell-1.7 {bell command} -body { + bell -nice -displayof . -nice +} -returnCodes {error} -result {wrong # args: should be "bell ?-displayof window? ?-nice?"} + +test bell-1.8 {bell command} -body { puts "Bell should ring now ..." flush stdout after 200 @@ -39,8 +47,7 @@ test bell-1.8 {bell command} { bell -nice after 200 bell -} {} +} -result {} -# cleanup cleanupTests return diff --git a/tests/bgerror.test b/tests/bgerror.test index fa33d31..fd9594a 100644 --- a/tests/bgerror.test +++ b/tests/bgerror.test @@ -5,49 +5,58 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test bgerror-1.1 {bgerror / tkerror compat} { +test bgerror-1.1 {bgerror / tkerror compat} -setup { set errRes {} proc tkerror {err} { - global errRes; - set errRes $err; + global errRes; + set errRes $err; } +} -body { after 0 {error err1} vwait errRes; - set errRes; -} err1 + return $errRes; +} -cleanup { + catch {rename tkerror {}} +} -result {err1} -test bgerror-1.2 {bgerror / tkerror compat / accumulation} { +test bgerror-1.2 {bgerror / tkerror compat / accumulation} -setup { set errRes {} proc tkerror {err} { - global errRes; - lappend errRes $err; + global errRes; + lappend errRes $err; } +} -body { after 0 {error err1} after 0 {error err2} after 0 {error err3} update - set errRes; -} {err1 err2 err3} + return $errRes; +} -cleanup { + catch {rename tkerror {}} +} -result {err1 err2 err3} -test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} { +test bgerror-1.3 {bgerror / tkerror compat / accumulation / break} -setup { set errRes {} proc tkerror {err} { - global errRes; - lappend errRes $err; - return -code break "skip!"; + global errRes; + lappend errRes $err; + return -code break "skip!"; } +} -body { after 0 {error err1} after 0 {error err2} after 0 {error err3} update - set errRes; -} err1 + return $errRes; +} -cleanup { + catch {rename tkerror {}} +} -result {err1} -catch {rename tkerror {}} # some testing of the default error dialog # would be needed too, but that's not easy at all diff --git a/tests/bind.test b/tests/bind.test index 9892fec..c777d66 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -7,2741 +7,6051 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* 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 <Enter> {} + bind Test <Enter> {} + bind Toplevel <Enter> {} + bind xyz <Enter> {} + bind {a b} <Enter> {} + bind .t <Enter> {} } -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 <gorp-> {}} msg] $msg -} {0 {}} -test bind-1.6 {bind command} { - catch {destroy .b.f} - frame .b.f - bind .b.f <Enter> {test script} - set result [bind .b.f <Enter>] - bind .b.f <Enter> {} - list $result [bind .b.f <Enter>] -} {{test script} {}} -test bind-1.7 {bind command} { - catch {destroy .b.f} - frame .b.f - bind .b.f <Enter> {test script} - bind .b.f <Enter> {+more text} - bind .b.f <Enter> -} {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 <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} { - list [catch {bind .b <gorp-> {test script}} msg] $msg [bind .b] -} {1 {bad event type or keysym "gorp"} {}} -test bind-1.9 {bind command} { - list [catch {bind .b <gorp->} msg] $msg -} {0 {}} -test bind-1.10 {bind command} { - catch {destroy .b.f} - frame .b.f - bind .b.f <Enter> {script 1} - bind .b.f <Leave> {script 2} - bind .b.f a {script for a} - bind .b.f b {script for b} - lsort [bind .b.f] -} {<Enter> <Leave> 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 <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 .b <Enter> {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 <Enter> {lappend x "%W enter .b.f"} - set x {} - event gen .b.f <Enter> - 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 <Enter> {lappend x "%W enter .b.f"} - bindtags .b.f {.b.f {a b} xyz} - set x {} - event gen .b.f <Enter> - 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 <Enter> - 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 <Enter> {lappend x "%W enter .b.f"} - bind .b.f3 <Enter> {lappend x "%W enter .b.f3"} - set x {} - event gen .b.f <Enter> - 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 <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. - 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 <Enter> -} {} -bind all <Enter> {} -bind Test <Enter> {} -bind Toplevel <Enter> {} -bind xyz <Enter> {} -bind {a b} <Enter> {} -bind .b <Enter> {} - -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 { - 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 + 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 <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} { - 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> "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 +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> "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 .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> <Meta-1> <Control-1> <Double-Alt-1>} { - bind .b.f $i "binding for $i" + bind .t.f $i "binding for $i" } - set result {} foreach i {<Control-1> <Double-Alt-1> <1> <Meta-1>} { - bind .b.f $i {} - lappend result [lsort [bind .b.f]] + bind .t.f $i {} + lappend result [lsort [bind .t.f]] } - set result -} {{<Button-1> <Double-Alt-Button-1> <Meta-Button-1>} {<Button-1> <Meta-Button-1>} <Meta-Button-1> {}} -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>] -} {<Button-1> {}} - -test bind-11.1 {Tk_GetAllBindings procedure} { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 + 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> <less> <Meta-a> <Acircumflex>" { - bind .b.f $i Test + bind .t.f $i Test } - lsort [bind .b.f] -} {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> 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 {! <<Paste>> <Key-Acircumflex> <Key-Delete> <Key-Linefeed> <Key-Tab> <Key-less> <Key-space> <Meta-Key-a> a \{ ~} +test bind-11.2 {Tk_GetAllBindings procedure} -body { + frame .t.f foreach i "<Double-1> <Triple-1> <Meta-Control-a> <Double-Alt-Enter> <1>" { - bind .b.f $i Test + bind .t.f $i Test } - lsort [bind .b.f] -} {<Button-1> <Control-Meta-Key-a> <Double-Alt-Enter> <Double-Button-1> <Triple-Button-1>} -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 {<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-1> abcd a<Leave>b" { - bind .b.f $i Test + bind .t.f $i Test } - lsort [bind .b.f] -} {<Triple-Button-1> a<Leave>b 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 {<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-1> <Alt-a> <Control-a>" { - 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-13.1 {Tk_BindEvent procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .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 <Destroy> {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 <KeyPress> {lappend x "%W %K Test press any"} -bind all <KeyPress> {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 { + bind Test <KeyPress> {lappend x "%W %K Test KeyPress"} + bind all <KeyPress> {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 <Key-colon> + event generate .t.f <Key-plus> + event generate .t.f <Key-underscore> + return $x +} -cleanup { + destroy .t.f + bind all <KeyPress> {} + bind Test <KeyPress> {} + 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.1 {Tk_BindEvent procedure} { - setup - bind .b.f a {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 <Key-a> - event gen .b.f <Key-b> - event gen .b.f <Key-x> - 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 <KeyPress> {lappend x "%W %K Test press any"; break} -bind all <KeyPress> {continue; lappend x "%W %K all press any"} +} -body { + bind Test <KeyPress> {lappend x "%W %K Test press any"; break} + bind all <KeyPress> {continue; lappend x "%W %K all press any"} + bind .t.f : {lappend x "%W %K .t.f pressed colon"} + + event generate .t.f <Key-colon> + return $x +} -cleanup { + destroy .t.f + bind all <KeyPress> {} + bind Test <KeyPress> {} +} -result {{.t.f colon .t.f pressed colon} {.t.f colon Test 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 <Key-b> - 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 <KeyPress> {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"} +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 <Key-b> +} -body { + bind Test <KeyPress> {lappend x "%W %K Test press any"; error Test} + bind .t.f : {lappend x "%W %K .t.f pressed colon"} + event generate .t.f <Key-colon> update list $x $errorInfo -} {{{.b.f b .b.f press a} {.b.f b Test press any}} {Test +} -cleanup { + destroy .t.f + bind Test <KeyPress> {} + 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)}} -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 <Key-a> + set x 44 + event generate .t.f <Key-colon> } - 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 : {lappend x "%W %K Test"} + bind .t.f : {lappend x "%W %K .t.f"} 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 : {} +} -result {{.t.f colon .t.f} {.t.f colon Test}} + +test bind-13.5 {Tk_BindEvent procedure} -body { bind all <Destroy> {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 <Key-z> - 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 <Key-z> - 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 <ButtonPress> {lappend x "%W z (.b.f <ButtonPress> binding)"} - set x {} - event gen .b.f <Button-1> - event gen .b.f <Button-2> - set x -} {{.b.f z (.b.f <1> binding)} {.b.f z (.b.f <ButtonPress> binding)}} -test bind-13.9 {Tk_BindEvent procedure: ignore NotifyInferior} { - setup - bind .b.f <Enter> "lappend x Enter%#" - bind .b.f <Leave> "lappend x Leave%#" - set x {} - event gen .b.f <Enter> -serial 100 -detail NotifyAncestor - event gen .b.f <Enter> -serial 101 -detail NotifyInferior - event gen .b.f <Leave> -serial 102 -detail NotifyAncestor - event gen .b.f <Leave> -serial 103 -detail NotifyInferior - set x -} {Enter100 Leave102} -test bind-13.10 {Tk_BindEvent procedure: collapse Motions} { - setup - bind .b.f <Motion> "lappend x Motion%#(%x,%y)" - set x {} - event gen .b.f <Motion> -serial 100 -x 100 -y 200 -when tail - update - event gen .b.f <Motion> -serial 101 -x 200 -y 300 -when tail - event gen .b.f <Motion> -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 <Key> "lappend x %K%#" - bind .b.f <KeyRelease> "lappend x %K%#" - event gen .b.f <Key-Shift_L> -serial 100 -when tail - event gen .b.f <KeyRelease-Shift_L> -serial 101 -when tail - event gen .b.f <Key-Shift_L> -serial 102 -when tail - event gen .b.f <KeyRelease-Shift_L> -serial 103 -when tail - update -} {} -test bind-13.12 {Tk_BindEvent procedure: valid key detail} { - setup - bind .b.f <Key> "lappend x Key%K" - bind .b.f <KeyRelease> "lappend x Release%K" - set x {} - event gen .b.f <Key> -keysym a - event gen .b.f <KeyRelease> -keysym a - set x -} {Keya Releasea} -test bind-13.13 {Tk_BindEvent procedure: invalid key detail} { - setup - bind .b.f <Key> "lappend x Key%K" - bind .b.f <KeyRelease> "lappend x Release%K" - set x {} - event gen .b.f <Key> -keycode 0 - event gen .b.f <KeyRelease> -keycode 0 - set x -} {Key?? Release??} -test bind-13.14 {Tk_BindEvent procedure: button detail} { - setup - bind .b.f <Button> "lappend x Button%b" - bind .b.f <ButtonRelease> "lappend x Release%b" - set x {} - event gen .b.f <Button> -button 1 - event gen .b.f <ButtonRelease> -button 3 - set x -} {Button1 Release3} -test bind-13.15 {Tk_BindEvent procedure: virtual detail} { - setup - bind .b.f <<Paste>> "lappend x Paste" - set x {} - event gen .b.f <<Paste>> - set x -} {Paste} -test bind-13.16 {Tk_BindEvent procedure: virtual event in event stream} { - setup - bind .b.f <<Paste>> "lappend x Paste" - set x {} - event gen .b.f <<Paste>> - set x -} {Paste} -test bind-13.17 {Tk_BindEvent procedure: match detail physical} { - setup - bind .b.f <Button-2> {set x Button-2} - event add <<Paste>> <Button-2> - bind .b.f <<Paste>> {set x Paste} + 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 <Key-colon> + 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 <Key-colon> + 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 <ButtonPress> {lappend x "%W z (.t.f <ButtonPress> 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 <1> binding)} {.t.f z (.t.f <ButtonPress> 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 <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 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 <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 <Key-Shift_L> -serial 100 -when tail + event generate .t.f <KeyRelease-Shift_L> -serial 101 -when tail + event generate .t.f <Key-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 {} - event gen .b.f <Button-2> +} -body { + bind .t.f <Key> "lappend x Key%K" + bind .t.f <KeyRelease> "lappend x Release%K" + event generate .t.f <Key> -keysym colon + event generate .t.f <KeyRelease> -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 <Key> "lappend x Key%K" + bind .t.f <KeyRelease> "lappend x Release%K" + event generate .t.f <Key> -keycode 0 + event generate .t.f <KeyRelease> -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 <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 -} {Button-2} -test bind-13.18 {Tk_BindEvent procedure: no match detail physical} { - setup +} -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 .b.f <<Paste>> {set x Paste} + 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 {} - event gen .b.f <Button-2> - set x -} {Paste} -test bind-13.19 {Tk_BindEvent procedure: match detail virtual} { - setup +} -body { event add <<Paste>> <Button-2> - bind .b.f <<Paste>> "lappend x Paste" + 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 {} - event gen .b.f <Button-2> - set x -} {Paste} -test bind-13.20 {Tk_BindEvent procedure: no match detail virtual} { - setup +} -body { event add <<Paste>> <Button-2> - bind .b.f <<Paste>> "lappend x Paste" + 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 {} - event gen .b.f <Button> - set x -} {} -test bind-13.21 {Tk_BindEvent procedure: match no-detail physical} { - setup - bind .b.f <Button> {set x Button} +} -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 .b.f <<Paste>> {set x Paste} + 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 {} - event gen .b.f <Button-2> - set x -} {Button} -test bind-13.22 {Tk_BindEvent procedure: no match no-detail physical} { - setup +} -body { event add <<Paste>> <Button> - bind .b.f <<Paste>> {set x Paste} + 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 {} - event gen .b.f <Button-2> - set x -} {Paste} -test bind-13.23 {Tk_BindEvent procedure: match no-detail virtual} { - setup +} -body { event add <<Paste>> <Button> - bind .b.f <<Paste>> "lappend x Paste" + 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 {} - event gen .b.f <Button-2> - set x -} {Paste} -test bind-13.24 {Tk_BindEvent procedure: no match no-detail virtual} { - setup +} -body { event add <<Paste>> <Key> - bind .b.f <<Paste>> "lappend x Paste" + 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 {} - event gen .b.f <Button> - set x -} {} -test bind-13.25 {Tk_BindEvent procedure: precedence} { - setup +} -body { event add <<Paste>> <Button-2> event add <<Copy>> <Button> - bind .b.f <Button-2> "lappend x Button-2" - bind .b.f <<Paste>> "lappend x Paste" - bind .b.f <Button> "lappend x Button" - bind .b.f <<Copy>> "lappend x Copy" - - set x {} - event gen .b.f <Button-2> - bind .b.f <Button-2> {} - event gen .b.f <Button-2> - bind .b.f <<Paste>> {} - event gen .b.f <Button-2> - bind .b.f <Button> {} - event gen .b.f <Button-2> - bind .b.f <<Copy>> {} - event gen .b.f <Button-2> - set x -} {Button-2 Paste Button Copy} -test bind-13.26 {Tk_BindEvent procedure: no detail virtual pattern list} { - setup - bind .b.f <Button-2> {set x Button-2} - set x {} - event gen .b.f <Button-2> - set x -} {Button-2} -test bind-13.27 {Tk_BindEvent procedure: detail virtual pattern list} { - setup + 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 .b.f <<Paste>> {set x Paste} + 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 {} - event gen .b.f <Button-2> - set x -} {Paste} -test bind-13.28 {Tk_BindEvent procedure: no no-detail virtual pattern list} { - setup - bind .b.f <Button> {set x Button} +} -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 {} - event gen .b.f <Button-2> - set x -} {Button} -test bind-13.29 {Tk_BindEvent procedure: no-detail virtual pattern list} { - setup +} -body { event add <<Paste>> <Button> - bind .b.f <<Paste>> {set x Paste} - set x {} - event gen .b.f <Button-2> - set x -} {Paste} -test bind-13.30 {Tk_BindEvent procedure: no match} { - setup - event gen .b.f <Button-2> -} {} -test bind-13.31 {Tk_BindEvent procedure: match} { - setup - bind .b.f <Button-2> {set x Button-2} - set x {} - event gen .b.f <Button-2> - set x -} {Button-2} -test bind-13.32 {Tk_BindEvent procedure: many C bindings cause realloc} testcbind { - setup - bindtags .b.f {a b c d e f g h i j k l m n o p} - foreach p [bindtags .b.f] { - testcbind $p <1> "lappend x $p" - } + 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 { + destroy .t.f +} -result {Button-2} +test bind-13.33 {Tk_BindEvent procedure: many C bindings cause realloc} -setup { + # this test might not be useful anymore [#3009998] + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <1> - foreach p [bindtags .b.f] { - bind $p <1> {} +} -body { + bindtags .t.f {a b c d e f g h i j k l m n o p} + foreach p [bindtags .t.f] { + bind $p <1> "lappend x $p" } - set x -} {a b c d e f g h i j k l m n o p} -test bind-13.33 {Tk_BindEvent procedure: multiple tags} { - setup - bind .b.f <Button-2> {lappend x .b.f} - bind Test <Button-2> {lappend x Button} + event generate .t.f <1> + return $x +} -cleanup { + foreach p [bindtags .t.f] {bind $p <1> {}} + destroy .t.f +} -result {a b c d e f g h i j k l m n o p} +test bind-13.34 {Tk_BindEvent procedure: multiple tags} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-2> +} -body { + bind .t.f <Button-2> {lappend x .t.f} + bind Test <Button-2> {lappend x Button} + event generate .t.f <Button-2> + return $x +} -cleanup { + destroy .t.f bind Test <Button-2> {} - set x -} {.b.f Button} -test bind-13.34 {Tk_BindEvent procedure: execute C binding} testcbind { - setup - testcbind .b.f <1> {lappend x 1} +} -result {.t.f Button} +test bind-13.35 {Tk_BindEvent procedure: execute binding} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <1> - set x -} {1} -test bind-13.35 {Tk_BindEvent procedure: pending list marked deleted} testcbind { - setup - testcbind Test <1> {lappend x Test} {lappend x Deleted} - bind .b.f <1> {lappend x .b.f; destroy .b.f} +} -body { + bind .t.f <1> {lappend x 1} + event generate .t.f <1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-13.38 {Tk_BindEvent procedure: binding gets to run} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <1> - set y [list $x [bind Test]] - bind Test <1> {} - set y -} {.b.f <Button-1>} -test bind-13.36 {Tk_BindEvent procedure: C binding marked deleted} testcbind { - setup - testcbind Test <1> {lappend x Test} {lappend x Deleted} - bind .b.f <1> {lappend x .b.f; bind Test <1> {}; lappend x after} - set x {} - event gen .b.f <1> - set x -} {.b.f after Deleted} -test bind-13.37 {Tk_BindEvent procedure: C binding gets to run} testcbind { - setup - testcbind Test <1> {lappend x Test} - bind .b.f <1> {lappend x .b.f} - set x {} - event gen .b.f <1> +} -body { + bind Test <1> {lappend x Test} + bind .t.f <1> {lappend x .t.f} + event generate .t.f <1> + return $x +} -cleanup { + destroy .t.f bind Test <1> {} - set x -} {.b.f Test} -test bind-13.38 {Tk_BindEvent procedure: C binding deleted, refcount == 0} testcbind { - setup - testcbind .b.f <1> {lappend x hi; bind .b.f <1> {}} {lappend x bye} - set x {} - event gen .b.f <1> - set x -} {hi bye} -test bind-13.39 {Tk_BindEvent procedure: C binding deleted, refcount != 0} testcbind { - setup - testcbind .b.f <1> { - lappend x before$n - if {$n==0} { - bind .b.f <1> {} - } else { - set n [expr $n-1] - event gen .b.f <1> - } - lappend x after$n - } {lappend x Deleted} - set n 3 - set x {} - event gen .b.f <1> - set x -} {before3 before2 before1 before0 after0 after0 after0 after0 Deleted} -test bind-13.40 {Tk_BindEvent procedure: continue in script} { - setup - bind .b.f <Button-2> {lappend x b1; continue; lappend x b2} - bind Test <Button-2> {lappend x B1; continue; lappend x B2} +} -result {.t.f Test} +test bind-13.41 {Tk_BindEvent procedure: continue in script} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-2> +} -body { + bind .t.f <Button-2> {lappend x b1; continue; lappend x b2} + bind Test <Button-2> {lappend x B1; continue; lappend x B2} + event generate .t.f <Button-2> + return $x +} -cleanup { + destroy .t.f bind Test <Button-2> {} - set x -} {b1 B1} -test bind-13.41 {Tk_BindEvent procedure: continue in script} testcbind { - setup - testcbind .b.f <Button-2> {lappend x b1; continue; lappend x b2} - testcbind Test <Button-2> {lappend x B1; continue; lappend x B2} +} -result {b1 B1} +test bind-13.43 {Tk_BindEvent procedure: break in script} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-2> - bind Test <Button-2> {} - set x -} {b1 B1} -test bind-13.42 {Tk_BindEvent procedure: break in script} { - setup - bind .b.f <Button-2> {lappend x b1; break; lappend x b2} +} -body { + bind .t.f <Button-2> {lappend x b1; break; lappend x b2} bind Test <Button-2> {lappend x B1; break; lappend x B2} - set x {} - event gen .b.f <Button-2> + event generate .t.f <Button-2> + return $x +} -cleanup { + destroy .t.f bind Test <Button-2> {} - set x -} {b1} -test bind-13.43 {Tk_BindEvent procedure: break in script} testcbind { - setup - testcbind .b.f <Button-2> {lappend x b1; break; lappend x b2} - testcbind Test <Button-2> {lappend x B1; break; lappend x B2} +} -result {b1} +test bind-13.45 {Tk_BindEvent procedure: error in script} -setup { + proc bgerror msg { + global x + lappend x $msg + } + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-2> - bind Test <Button-2> {} - set x -} {b1} - -proc bgerror msg { - global x - lappend x $msg -} -test bind-13.44 {Tk_BindEvent procedure: error in script} { - setup - bind .b.f <Button-2> {lappend x b1; blap} +} -body { + bind .t.f <Button-2> {lappend x b1; blap} bind Test <Button-2> {lappend x B1} - set x {} - event gen .b.f <Button-2> + event generate .t.f <Button-2> update + return $x +} -cleanup { + destroy .t.f bind Test <Button-2> {} - set x -} {b1 {invalid command name "blap"}} -test bind-13.45 {Tk_BindEvent procedure: error in script} testcbind { - setup - testcbind .b.f <Button-2> {lappend x b1; blap} - testcbind Test <Button-2> {lappend x B1} - set x {} - event gen .b.f <Button-2> + proc bgerror args {} +} -result {b1 {invalid command name "blap"}} + +test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f update - bind Test <Button-2> {} - set x -} {b1 {invalid command name "blap"}} - -test bind-14.1 {TkBindDeadWindow: no C bindings pending} testcbind { - setup - bind .b.f <1> x - testcbind .b.f <2> y - destroy .b.f -} {} -test bind-14.2 {TkBindDeadWindow: is called after <Destroy>} testcbind { - setup - testcbind .b.f <Destroy> "lappend x .b.f" - testcbind Test <Destroy> "lappend x Test" - set x {} - destroy .b.f - bind Test <Destroy> {} - set x -} {.b.f Test} -test bind-14.3 {TkBindDeadWindow: pending C bindings} testcbind { - setup - bindtags .b.f {a b c d} - testcbind a <1> "lappend x a1" "lappend x bye.a1" - testcbind b <1> "destroy .b.f; lappend x b1" "lappend x bye.b1" - testcbind c <1> "lappend x c1" "lappend x bye.c1" - testcbind d <1> "lappend x d1" "lappend x bye.d1" - bind a <2> "event gen .b.f <1>" - testcbind b <2> "lappend x b2" "lappend x bye.b2" - testcbind c <2> "lappend x c2" "lappend x bye.d2" - bind d <2> "lappend x d2" - testcbind a <3> "event gen .b.f <2>" - set x {} - event gen .b.f <3> - set y $x - foreach tag {a b c d} { - foreach event {<1> <2> <3>} { - bind $tag $event {} - } - } - set y -} {a1 b1 d2} - -test bind-15.1 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f ab {set x 1} +} -body { + bind .t.f 12 {set x 1} set x 0 - event gen .b.f <Key-a> - event gen .b.f <KeyRelease-a> - event gen .b.f <Key-b> - event gen .b.f <KeyRelease-b> - set x -} 1 -test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f ab {set x 1} + event generate .t.f <Key-1> + event generate .t.f <KeyRelease-1> + event generate .t.f <Key-2> + event generate .t.f <KeyRelease-2> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.2 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f 12 {set x 1} set x 0 - event gen .b.f <Key-a> - event gen .b.f <Enter> - event gen .b.f <KeyRelease-a> - event gen .b.f <Leave> - event gen .b.f <Key-b> - event gen .b.f <KeyRelease-b> - set x -} 1 -test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f ab {set x 1} + event generate .t.f <Key-1> + event generate .t.f <Enter> + event generate .t.f <KeyRelease-1> + event generate .t.f <Leave> + event generate .t.f <Key-2> + event generate .t.f <KeyRelease-2> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.3 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f 12 {set x 1} set x 0 - event gen .b.f <Key-a> - event gen .b.f <Button-1> - event gen .b.f <Key-b> - set x -} 0 -test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Key-1> + event generate .t.f <Button-1> + event generate .t.f <Key-2> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.4 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f <Double-ButtonRelease> {set x 1} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.5 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-ButtonRelease> {set x 1} set x 0 - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - set x -} 1 -test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.6 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-1> - event gen .b.f <Key-a> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - set x -} 0 -test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-1> + event generate .t.f <Key-a> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.7 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-1> - event gen .b.f <Key-Shift_L> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} { - setup - bind .b.f ab {set x 1} + event generate .t.f <Button-1> + event generate .t.f <Key-Shift_L> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.8 {MatchPatterns procedure, ignoring type mismatches} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f ab {set x 1} set x 0 - event gen .b.f <Key-a> - event gen .b.f <Key-c> - event gen .b.f <Key-b> - set x -} 0 -test bind-15.9 {MatchPatterns procedure, modifier checks} { - setup - bind .b.f <M1-M2-Key> {set x 1} + event generate .t.f <Key-a> + event generate .t.f <Key-c> + event generate .t.f <Key-b> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.9 {MatchPatterns procedure, modifier checks} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <M1-M2-Key> {set x 1} set x 0 - event gen .b.f <Key-a> -state 0x18 - set x -} 1 -test bind-15.10 {MatchPatterns procedure, modifier checks} { - setup - bind .b.f <M1-M2-Key> {set x 1} + event generate .t.f <Key-a> -state 0x18 + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.10 {MatchPatterns procedure, modifier checks} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <M1-M2-Key> {set x 1} set x 0 - event gen .b.f <Key-a> -state 0xfc - set x -} 1 -test bind-15.11 {MatchPatterns procedure, modifier checks} { - setup - bind .b.f <M1-M2-Key> {set x 1} + event generate .t.f <Key-a> -state 0xfc + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.11 {MatchPatterns procedure, modifier checks} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <M1-M2-Key> {set x 1} set x 0 - event gen .b.f <Key-a> -state 0x8 - set x -} 0 -test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} {nonPortable} { + event generate .t.f <Key-a> -state 0x8 + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.12 {MatchPatterns procedure, ignore modifier presses and releases} -constraints { + nonPortable +} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { # This test is non-portable because the Shift_L keysym may behave # differently on some platforms. - setup - bind .b.f aB {set x 1} + bind .t.f aB {set x 1} set x 0 - event gen .b.f <Key-a> - event gen .b.f <Key-Shift_L> - event gen .b.f <Key-b> -state 1 - set x -} 1 -test bind-15.13 {MatchPatterns procedure, checking detail} { - setup - bind .b.f ab {set x 1} + event generate .t.f <Key-a> + event generate .t.f <Key-Shift_L> + event generate .t.f <Key-b> -state 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.13 {MatchPatterns procedure, checking detail} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f ab {set x 1} set x 0 - event gen .b.f <Key-a> - event gen .b.f <Key-c> - set x -} 0 -test bind-15.14 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Key-a> + event generate .t.f <Key-c> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.14 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -x 30 -y 40 - event gen .b.f <Button-1> -x 31 -y 39 - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.15 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -x 30 -y 40 + event generate .t.f <Button-1> -x 31 -y 39 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.15 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -x 30 -y 40 - event gen .b.f <Button-1> -x 29 -y 41 - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.16 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -x 30 -y 40 + event generate .t.f <Button-1> -x 29 -y 41 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.16 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -x 30 -y 40 - event gen .b.f <Button-1> -x 40 -y 40 - event gen .b.f <ButtonRelease-2> - set x -} 0 -test bind-15.17 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -x 30 -y 40 + event generate .t.f <Button-1> -x 40 -y 40 + event generate .t.f <ButtonRelease-2> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.17 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -x 30 -y 40 - event gen .b.f <Button-1> -x 20 -y 40 - event gen .b.f <ButtonRelease-1> - set x -} 0 -test bind-15.18 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -x 30 -y 40 + event generate .t.f <Button-1> -x 20 -y 40 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.18 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -x 30 -y 40 - event gen .b.f <Button-1> -x 30 -y 30 - event gen .b.f <ButtonRelease-1> - set x -} 0 -test bind-15.19 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -x 30 -y 40 + event generate .t.f <Button-1> -x 30 -y 30 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.19 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -x 30 -y 40 - event gen .b.f <Button-1> -x 30 -y 50 - event gen .b.f <ButtonRelease-1> - set x -} 0 -test bind-15.20 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -x 30 -y 40 + event generate .t.f <Button-1> -x 30 -y 50 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.20 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -time 300 - event gen .b.f <Button-1> -time 700 - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.21 {MatchPatterns procedure, checking "nearby"} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -time 300 + event generate .t.f <Button-1> -time 700 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.21 {MatchPatterns procedure, checking "nearby"} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> -time 300 - event gen .b.f <Button-1> -time 900 - event gen .b.f <ButtonRelease-1> - set x -} 0 -test bind-15.22 {MatchPatterns procedure, time wrap-around} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> -time 300 + event generate .t.f <Button-1> -time 900 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.22 {MatchPatterns procedure, time wrap-around} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-1> -time [expr -100] - event gen .b.f <Button-1> -time 200 - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.23 {MatchPatterns procedure, time wrap-around} { - setup - bind .b.f <Double-1> {set x 1} + event generate .t.f <Button-1> -time [expr -100] + event generate .t.f <Button-1> -time 200 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.23 {MatchPatterns procedure, time wrap-around} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Double-1> {set x 1} set x 0 - event gen .b.f <Button-1> -time -100 - event gen .b.f <Button-1> -time 500 - event gen .b.f <ButtonRelease-1> - set x -} 0 -test bind-15.24 {MatchPatterns procedure, virtual event} { - setup - event add <<Paste>> <Button-1> - bind .b.f <<Paste>> {lappend x paste} + event generate .t.f <Button-1> -time -100 + event generate .t.f <Button-1> -time 500 + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {0} + +test bind-15.24 {MatchPatterns procedure, virtual event} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> +} -body { + event add <<Paste>> <Button-1> + bind .t.f <<Paste>> {lappend x paste} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> set x -} {paste} -test bind-15.25 {MatchPatterns procedure, reject a virtual event} { - setup - event add <<Paste>> <Shift-Button-1> - bind .b.f <<Paste>> {lappend x paste} +} -cleanup { + destroy .t.f + event delete <<Paste>> <Button-1> +} -result {paste} +test bind-15.25 {MatchPatterns procedure, reject a virtual event} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> +} -body { + event add <<Paste>> <Shift-Button-1> + bind .t.f <<Paste>> {lappend x paste} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> set x -} {} -test bind-15.26 {MatchPatterns procedure, reject a virtual event} { - setup +} -cleanup { + destroy .t.f + event delete <<Paste>> <Shift-Button-1> +} -result {} +test bind-15.26 {MatchPatterns procedure, reject a virtual event} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { event add <<V1>> <Button> event add <<V2>> <Button-1> event add <<V3>> <Shift-Button-1> - bind .b.f <<V2>> "lappend x V2%#" - set x {} - event gen .b.f <Button> -serial 101 - event gen .b.f <Button-1> -serial 102 - event gen .b.f <Shift-Button-1> -serial 103 - event gen .b.f <ButtonRelease-1> - bind .b.f <Shift-Button-1> "lappend x Shift-Button-1" - event gen .b.f <Button> -serial 104 - event gen .b.f <Button-1> -serial 105 - event gen .b.f <Shift-Button-1> -serial 106 - event gen .b.f <ButtonRelease-1> - set x -} {V2102 V2103 V2105 Shift-Button-1} -test bind-15.27 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <KeyPress> {set x 0} - bind .b.f a {set x 1} - set x none - event gen .b.f <Key-a> + bind .t.f <<V2>> "lappend x V2%#" + event generate .t.f <Button> -serial 101 + event generate .t.f <Button-1> -serial 102 + event generate .t.f <Shift-Button-1> -serial 103 + event generate .t.f <ButtonRelease-1> + bind .t.f <Shift-Button-1> "lappend x Shift-Button-1" + event generate .t.f <Button> -serial 104 + event generate .t.f <Button-1> -serial 105 + event generate .t.f <Shift-Button-1> -serial 106 + event generate .t.f <ButtonRelease-1> set x -} 1 -test bind-15.28 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <KeyPress> {set x 0} - bind .b.f a {set x 1} - set x none - event gen .b.f <Key-b> - set x -} 0 -test bind-15.29 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <KeyPress> {lappend x 0} - bind .b.f a {lappend x 1} - bind .b.f ba {lappend x 2} +} -cleanup { + destroy .t.f + event delete <<V1>> <Button> + event delete <<V2>> <Button-1> + event delete <<V3>> <Shift-Button-1> +} -result {V2102 V2103 V2105 Shift-Button-1} +test bind-15.27 {MatchPatterns procedure, conflict resolution} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <KeyPress> {set x 0} + bind .t.f 1 {set x 1} set x none - event gen .b.f <Key-b> - event gen .b.f <KeyRelease-b> - event gen .b.f <Key-a> - set x -} {none 0 2} -test bind-15.30 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <ButtonPress> {set x 0} - bind .b.f <1> {set x 1} + event generate .t.f <Key-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.28 {MatchPatterns procedure, conflict resolution} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <KeyPress> {set x 0} + bind .t.f 1 {set x 1} set x none - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - set x -} 1 -test bind-15.31 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <M1-Key> {set x 0} - bind .b.f <M2-Key> {set x 1} + event generate .t.f <Key-2> + return $x +} -cleanup { + destroy .t.f +} -result {0} +test bind-15.29 {MatchPatterns procedure, conflict resolution} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <KeyPress> {lappend x 0} + bind .t.f 1 {lappend x 1} + bind .t.f 21 {lappend x 2} set x none - event gen .b.f <Key-a> -state 0x18 + event generate .t.f <Key-2> + event generate .t.f <KeyRelease-2> + event generate .t.f <Key-1> set x -} 1 -test bind-15.32 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <M2-Key> {set x 0} - bind .b.f <M1-Key> {set x 1} +} -cleanup { + destroy .t.f +} -result {none 0 2} +test bind-15.30 {MatchPatterns procedure, conflict resolution} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <ButtonPress> {set x 0} + bind .t.f <1> {set x 1} set x none - event gen .b.f <Key-a> -state 0x18 - set x -} 1 -test bind-15.33 {MatchPatterns procedure, conflict resolution} { - setup - bind .b.f <1> {lappend x single} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.31 {MatchPatterns procedure, conflict resolution} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <M1-Key> {set x 0} + bind .t.f <M2-Key> {set x 1} + event generate .t.f <Key-a> -state 0x18 + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.32 {MatchPatterns procedure, conflict resolution} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <M2-Key> {set x 0} + bind .t.f <M1-Key> {set x 1} + set x none + event generate .t.f <Key-a> -state 0x18 + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-15.33 {MatchPatterns procedure, conflict resolution} -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 single} bind Test <1> {lappend x single(Test)} bind Test <Double-1> {lappend x double(Test)} - set x {} - event gen .b.f <Button-1> - event gen .b.f <Button-1> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> set x -} {single single(Test) single double(Test) single double(Test)} -foreach i [bind Test] { - bind Test $i {} -} -test bind-16.1 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x abcd} +} -cleanup { + destroy .t.f + bind Test <1> {} + bind Test <Double-1> {} +} -result {single single(Test) single double(Test) single double(Test)} + + +test bind-16.1 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x abcd} set x none - event gen .b.f <Enter> + event generate .t.f <Enter> set x -} abcd -test bind-16.2 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %#} +} -cleanup { + destroy .t.f +} -result {abcd} +test bind-16.2 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %#} set x none - event gen .b.f <Enter> -serial 1234 + event generate .t.f <Enter> -serial 1234 set x -} 1234 -test bind-16.3 {ExpandPercents procedure} { - setup - bind .b.f <Configure> {set x %a} +} -cleanup { + destroy .t.f +} -result {1234} +test bind-16.3 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Configure> {set x %a} set x none - event gen .b.f <Configure> -above .b -window .b.f + event generate .t.f <Configure> -above .t -window .t.f set x -} [winfo id .b] -test bind-16.4 {ExpandPercents procedure} { - setup - bind .b.f <Button> {set x %b} +} -cleanup { + destroy .t.f +} -result [winfo id .t] +test bind-16.4 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> {set x %b} set x none - event gen .b.f <Button-3> - event gen .b.f <ButtonRelease-3> + event generate .t.f <Button-3> + event generate .t.f <ButtonRelease-3> set x -} 3 -test bind-16.5 {ExpandPercents procedure} { - setup - bind .b.f <Expose> {set x %c} +} -cleanup { + destroy .t.f +} -result {3} +test bind-16.5 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Expose> {set x %c} set x none - event gen .b.f <Expose> -count 47 + event generate .t.f <Expose> -count 47 set x -} 47 -test bind-16.6 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {47} +test bind-16.6 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyAncestor + event generate .t.f <Enter> -detail NotifyAncestor set x -} NotifyAncestor -test bind-16.7 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {NotifyAncestor} +test bind-16.7 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyVirtual + event generate .t.f <Enter> -detail NotifyVirtual set x -} NotifyVirtual -test bind-16.8 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {NotifyVirtual} +test bind-16.8 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyNonlinear + event generate .t.f <Enter> -detail NotifyNonlinear set x -} NotifyNonlinear -test bind-16.9 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {NotifyNonlinear} +test bind-16.9 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyNonlinearVirtual + event generate .t.f <Enter> -detail NotifyNonlinearVirtual set x -} NotifyNonlinearVirtual -test bind-16.10 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {NotifyNonlinearVirtual} +test bind-16.10 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyPointer + event generate .t.f <Enter> -detail NotifyPointer set x -} NotifyPointer -test bind-16.11 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {NotifyPointer} +test bind-16.11 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyPointerRoot + event generate .t.f <Enter> -detail NotifyPointerRoot set x -} NotifyPointerRoot -test bind-16.12 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %d} +} -cleanup { + destroy .t.f +} -result {NotifyPointerRoot} +test bind-16.12 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %d} set x none - event gen .b.f <Enter> -detail NotifyDetailNone + event generate .t.f <Enter> -detail NotifyDetailNone set x -} NotifyDetailNone -test bind-16.13 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x %f} +} -cleanup { + destroy .t.f +} -result {NotifyDetailNone} +test bind-16.13 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x %f} set x none - event gen .b.f <Enter> -focus 1 - set x -} 1 -test bind-16.14 {ExpandPercents procedure} { - setup - bind .b.f <Expose> {set x "%x %y %w %h"} + event generate .t.f <Enter> -focus 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-16.14 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Expose> {set x "%x %y %w %h"} set x none - event gen .b.f <Expose> -x 24 -y 18 -width 147 -height 61 + event generate .t.f <Expose> -x 24 -y 18 -width 147 -height 61 set x -} {24 18 147 61} -test bind-16.15 {ExpandPercents procedure} { - setup - bind .b.f <Configure> {set x "%x %y %w %h"} +} -cleanup { + destroy .t.f +} -result {24 18 147 61} +test bind-16.15 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Configure> {set x "%x %y %w %h"} set x none - event gen .b.f <Configure> -x 24 -y 18 -width 147 -height 61 -window .b.f + event generate .t.f <Configure> -x 24 -y 18 -width 147 -height 61 -window .t.f set x -} {24 18 147 61} -test bind-16.16 {ExpandPercents procedure} { - setup - bind .b.f <Key> {set x "%k"} +} -cleanup { + destroy .t.f +} -result {24 18 147 61} +test bind-16.16 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key> {set x "%k"} set x none - event gen .b.f <Key> -keycode 146 + event generate .t.f <Key> -keycode 146 set x -} 146 -test bind-16.17 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%m"} +} -cleanup { + destroy .t.f +} -result {146} +test bind-16.17 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x "%m"} set x none - event gen .b.f <Enter> -mode NotifyNormal + event generate .t.f <Enter> -mode NotifyNormal set x -} NotifyNormal -test bind-16.18 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%m"} +} -cleanup { + destroy .t.f +} -result {NotifyNormal} +test bind-16.18 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x "%m"} set x none - event gen .b.f <Enter> -mode NotifyGrab + event generate .t.f <Enter> -mode NotifyGrab set x -} NotifyGrab -test bind-16.19 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%m"} +} -cleanup { + destroy .t.f +} -result {NotifyGrab} +test bind-16.19 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x "%m"} set x none - event gen .b.f <Enter> -mode NotifyUngrab + event generate .t.f <Enter> -mode NotifyUngrab set x -} NotifyUngrab -test bind-16.20 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%m"} +} -cleanup { + destroy .t.f +} -result {NotifyUngrab} +test bind-16.20 {ExpandPercents 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 <Enter> {set x "%m"} set x none - event gen .b.f <Enter> -mode NotifyWhileGrabbed + event generate .t.f <Enter> -mode NotifyWhileGrabbed set x -} NotifyWhileGrabbed -test bind-16.21 {ExpandPercents procedure} { - setup - bind .b.f <Map> {set x "%o"} +} -cleanup { + destroy .t.f +} -result {NotifyWhileGrabbed} +test bind-16.21 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Map> {set x "%o"} set x none - event gen .b.f <Map> -override 1 -window .b.f - set x -} 1 -test bind-16.22 {ExpandPercents procedure} { - setup - bind .b.f <Reparent> {set x "%o"} + event generate .t.f <Map> -override 1 -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-16.22 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Reparent> {set x "%o"} set x none - event gen .b.f <Reparent> -override true -window .b.f - set x -} 1 -test bind-16.23 {ExpandPercents procedure} { - setup - bind .b.f <Configure> {set x "%o"} + event generate .t.f <Reparent> -override true -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-16.23 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Configure> {set x "%o"} set x none - event gen .b.f <Configure> -override 1 -window .b.f - set x -} 1 -test bind-16.24 {ExpandPercents procedure} { - setup - bind .b.f <Circulate> {set x "%p"} + event generate .t.f <Configure> -override 1 -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-16.24 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Circulate> {set x "%p"} set x none - event gen .b.f <Circulate> -place PlaceOnTop -window .b.f + event generate .t.f <Circulate> -place PlaceOnTop -window .t.f set x -} PlaceOnTop -test bind-16.25 {ExpandPercents procedure} { - setup - bind .b.f <Circulate> {set x "%p"} +} -cleanup { + destroy .t.f +} -result {PlaceOnTop} +test bind-16.25 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Circulate> {set x "%p"} set x none - event gen .b.f <Circulate> -place PlaceOnBottom -window .b.f + event generate .t.f <Circulate> -place PlaceOnBottom -window .t.f set x -} PlaceOnBottom -test bind-16.26 {ExpandPercents procedure} { - setup - bind .b.f <1> {set x "%s"} +} -cleanup { + destroy .t.f +} -result {PlaceOnBottom} +test bind-16.26 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <1> {set x "%s"} set x none - event gen .b.f <Button-1> -state 1402 - event gen .b.f <ButtonRelease-1> + event generate .t.f <Button-1> -state 1402 + event generate .t.f <ButtonRelease-1> set x -} 1402 -test bind-16.27 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%s"} +} -cleanup { + destroy .t.f +} -result {1402} +test bind-16.27 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x "%s"} set x none - event gen .b.f <Enter> -state 0x3ff + event generate .t.f <Enter> -state 0x3ff set x -} 1023 -test bind-16.28 {ExpandPercents procedure} { - setup - bind .b.f <Visibility> {set x "%s"} +} -cleanup { + destroy .t.f +} -result {1023} +test bind-16.28 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Visibility> {set x "%s"} set x none - event gen .b.f <Visibility> -state VisibilityPartiallyObscured + event generate .t.f <Visibility> -state VisibilityPartiallyObscured set x -} VisibilityPartiallyObscured -test bind-16.29 {ExpandPercents procedure} { - setup - bind .b.f <Visibility> {set x "%s"} +} -cleanup { + destroy .t.f +} -result {VisibilityPartiallyObscured} +test bind-16.29 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Visibility> {set x "%s"} set x none - event gen .b.f <Visibility> -state VisibilityUnobscured + event generate .t.f <Visibility> -state VisibilityUnobscured set x -} VisibilityUnobscured -test bind-16.30 {ExpandPercents procedure} { - setup - bind .b.f <Visibility> {set x "%s"} +} -cleanup { + destroy .t.f +} -result {VisibilityUnobscured} +test bind-16.30 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Visibility> {set x "%s"} set x none - event gen .b.f <Visibility> -state VisibilityFullyObscured + event generate .t.f <Visibility> -state VisibilityFullyObscured set x -} VisibilityFullyObscured -test bind-16.31 {ExpandPercents procedure} { - setup - bind .b.f <Button> {set x "%t"} +} -cleanup { + destroy .t.f +} -result {VisibilityFullyObscured} +test bind-16.31 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> {set x "%t"} set x none - event gen .b.f <Button> -time 4294 - event gen .b.f <ButtonRelease> + event generate .t.f <Button> -time 4294 + event generate .t.f <ButtonRelease> set x -} 4294 -test bind-16.32 {ExpandPercents procedure} { - setup - bind .b.f <Button> {set x "%x %y"} +} -cleanup { + destroy .t.f +} -result {4294} +test bind-16.32 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> {set x "%x %y"} set x none - event gen .b.f <Button> -x 881 -y 432 - event gen .b.f <ButtonRelease> + event generate .t.f <Button> -x 881 -y 432 + event generate .t.f <ButtonRelease> set x -} {881 432} -test bind-16.33 {ExpandPercents procedure} { - setup - bind .b.f <Reparent> {set x "%x %y"} +} -cleanup { + destroy .t.f +} -result {881 432} +test bind-16.33 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Reparent> {set x "%x %y"} set x none - event gen .b.f <Reparent> -x 882 -y 431 -window .b.f + event generate .t.f <Reparent> -x 882 -y 431 -window .t.f set x -} {882 431} -test bind-16.34 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%x %y"} +} -cleanup { + destroy .t.f +} -result {882 431} +test bind-16.34 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x "%x %y"} set x none - event gen .b.f <Enter> -x 781 -y 632 - set x -} {781 632} -test bind-16.35 {ExpandPercents procedure} {nonPortable} { - setup - bind .b.f <Key> {lappend x "%A"} - set x {} - event gen .b.f <Key-a> - event gen .b.f <Key-A> -state 1 - event gen .b.f <Key-Tab> - event gen .b.f <Key-Return> - event gen .b.f <Key-F1> - event gen .b.f <Key-Shift_L> - event gen .b.f <Key-space> - event gen .b.f <Key-dollar> -state 1 - event gen .b.f <Key-braceleft> -state 1 - event gen .b.f <Key-Multi_key> - event gen .b.f <Key-e> - event gen .b.f <Key-apostrophe> - set x -} "a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9" -test bind-16.36 {ExpandPercents procedure} { - setup - bind .b.f <Configure> {set x "%B"} + event generate .t.f <Enter> -x 781 -y 632 + set x +} -cleanup { + destroy .t.f +} -result {781 632} +test bind-16.35 {ExpandPercents procedure} -constraints { + nonPortable +} -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 "%A"} + event generate .t.f <Key-a> + event generate .t.f <Key-A> -state 1 + event generate .t.f <Key-Tab> + event generate .t.f <Key-Return> + event generate .t.f <Key-F1> + event generate .t.f <Key-Shift_L> + event generate .t.f <Key-space> + event generate .t.f <Key-dollar> -state 1 + event generate .t.f <Key-braceleft> -state 1 + event generate .t.f <Key-Multi_key> + event generate .t.f <Key-e> + event generate .t.f <Key-apostrophe> + set x +} -cleanup { + destroy .t.f +} -result {a A { } {\r} {{}} {{}} { } {\$} \\\{ {{}} {{}} \u00e9} +test bind-16.36 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Configure> {set x "%B"} set x none - event gen .b.f <Configure> -borderwidth 24 -window .b.f + event generate .t.f <Configure> -borderwidth 24 -window .t.f set x -} 24 -test bind-16.37 {ExpandPercents procedure} { - setup - bind .b.f <Enter> {set x "%E"} +} -cleanup { + destroy .t.f +} -result {24} +test bind-16.37 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> {set x "%E"} set x none - event gen .b.f <Enter> -sendevent 1 - set x -} 1 -test bind-16.38 {ExpandPercents procedure} {nonPortable} { - setup - bind .b.f <Key> {lappend x %K} - set x {} - event gen .b.f <Key-a> - event gen .b.f <Key-A> -state 1 - event gen .b.f <Key-Tab> - event gen .b.f <Key-F1> - event gen .b.f <Key-Shift_L> - event gen .b.f <Key-space> - event gen .b.f <Key-dollar> -state 1 - event gen .b.f <Key-braceleft> -state 1 - set x -} {a A Tab F1 Shift_L space dollar braceleft} -test bind-16.39 {ExpandPercents procedure} { - setup - bind .b.f <Key> {set x "%N"} + event generate .t.f <Enter> -sendevent 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} +test bind-16.38 {ExpandPercents procedure} -constraints { + nonPortable +} -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 %K} + event generate .t.f <Key-a> + event generate .t.f <Key-A> -state 1 + event generate .t.f <Key-Tab> + event generate .t.f <Key-F1> + event generate .t.f <Key-Shift_L> + event generate .t.f <Key-space> + event generate .t.f <Key-dollar> -state 1 + event generate .t.f <Key-braceleft> -state 1 + set x +} -cleanup { + destroy .t.f +} -result {a A Tab F1 Shift_L space dollar braceleft} +test bind-16.39 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key> {set x "%N"} set x none - event gen .b.f <Key-a> + event generate .t.f <Key-space> set x -} 97 -test bind-16.40 {ExpandPercents procedure} { - setup - bind .b.f <Key> {set x "%S"} +} -cleanup { + destroy .t.f +} -result {32} +test bind-16.40 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key> {set x "%S"} set x none - event gen .b.f <Key-a> -subwindow .b + event generate .t.f <Key-space> -subwindow .t set x -} [winfo id .b] -test bind-16.41 {ExpandPercents procedure} { - setup - bind .b.f <Key> {set x "%T"} +} -cleanup { + destroy .t.f +} -result [winfo id .t] +test bind-16.41 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key> {set x "%T"} set x none - event gen .b.f <Key> + event generate .t.f <Key> set x -} 2 -test bind-16.42 {ExpandPercents procedure} { - setup - bind .b.f <Key> {set x "%W"} +} -cleanup { + destroy .t.f +} -result {2} +test bind-16.42 {ExpandPercents 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 <Key> {set x "%W"} set x none - event gen .b.f <Key> + event generate .t.f <Key> set x -} .b.f -test bind-16.43 {ExpandPercents procedure} { - setup - bind .b.f <Button> {set x "%X %Y"} +} -cleanup { + destroy .t.f +} -result {.t.f} +test bind-16.43 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> {set x "%X %Y"} set x none - event gen .b.f <Button> -rootx 422 -rooty 13 - event gen .b.f <ButtonRelease> + event generate .t.f <Button> -rootx 422 -rooty 13 + event generate .t.f <ButtonRelease> set x -} {422 13} -test bind-16.44 {ExpandPercents procedure} { - setup - bind .b.f <Gravity> {set x "%R %S"} +} -cleanup { + destroy .t.f +} -result {422 13} +test bind-16.44 {ExpandPercents procedure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Gravity> {set x "%R %S"} set x none - event gen .b.f <Gravity> - set x -} {?? ??} - - -test bind-17.1 {event command} { - list [catch {event} msg] $msg -} {1 {wrong # args: should be "event option ?arg?"}} -test bind-17.2 {event command} { - list [catch {event xyz} msg] $msg -} {1 {bad option "xyz": must be add, delete, generate, or info}} -test bind-17.3 {event command: add} { - list [catch {event add} msg] $msg -} {1 {wrong # args: should be "event add virtual sequence ?sequence ...?"}} -test bind-17.4 {event command: add 1} { - setup + event generate .t.f <Gravity> + set x +} -cleanup { + destroy .t.f +} -result {?? ??} + + +test bind-17.1 {event command} -body { + event +} -returnCodes error -result {wrong # args: should be "event option ?arg?"} +test bind-17.2 {event command} -body { + event xyz +} -returnCodes error -result {bad option "xyz": must be add, delete, generate, or info} +test bind-17.3 {event command: add} -body { + event add +} -returnCodes error -result {wrong # args: should be "event add virtual sequence ?sequence ...?"} +test bind-17.4 {event command: add 1} -body { + event delete <<Paste>> event add <<Paste>> <Control-v> event info <<Paste>> -} {<Control-Key-v>} -test bind-17.5 {event command: add 2} { - setup +} -cleanup { + event delete <<Paste>> <Control-v> +} -result {<Control-Key-v>} +test bind-17.5 {event command: add 2} -body { + event delete <<Paste>> event add <<Paste>> <Control-v> <Button-2> lsort [event info <<Paste>>] -} {<Button-2> <Control-Key-v>} -test bind-17.6 {event command: add with error} { - setup - list [catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>} \ - msg] $msg [lsort [event info <<Paste>>]] -} {1 {bad event type or keysym "xyz"} {<Button-2> <Control-Key-v> abc}} -test bind-17.7 {event command: delete} { - list [catch {event delete} msg] $msg -} {1 {wrong # args: should be "event delete virtual ?sequence sequence ...?"}} -test bind-17.8 {event command: delete many} { - setup +} -cleanup { + event delete <<Paste>> <Control-v> <Button-2> +} -result {<Button-2> <Control-Key-v>} + +test bind-17.6 {event command: add with error} -body { + event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1> +} -cleanup { + event delete <<Paste>> +} -returnCodes error -result {bad event type or keysym "xyz"} +test bind-17.7 {event command: add with error} -body { + event delete <<Paste>> + catch {event add <<Paste>> <Control-v> <Button-2> abc <xyz> <1>} + lsort [event info <<Paste>>] +} -cleanup { + event delete <<Paste>> +} -result {<Button-2> <Control-Key-v> abc} + +test bind-17.8 {event command: delete} -body { + event delete +} -returnCodes error -result {wrong # args: should be "event delete virtual ?sequence ...?"} +test bind-17.9 {event command: delete many} -body { + event delete <<Paste>> event add <<Paste>> <3> <1> <2> t event delete <<Paste>> <1> <2> lsort [event info <<Paste>>] -} {<Button-3> t} -test bind-17.9 {event command: delete all} { - setup +} -cleanup { + event delete <<Paste>> <3> t +} -result {<Button-3> t} +test bind-17.10 {event command: delete all} -body { event add <<Paste>> a b event delete <<Paste>> event info <<Paste>> -} {} -test bind-17.10 {event command: delete 1} { - setup +} -cleanup { + event delete <<Paste>> a b +} -result {} +test bind-17.11 {event command: delete 1} -body { + event delete <<Paste>> event add <<Paste>> a b c event delete <<Paste>> b lsort [event info <<Paste>>] -} {a c} -test bind-17.11 {event command: info name} { - setup +} -cleanup { + event delete <<Paste>> +} -result {a c} +test bind-17.12 {event command: info name} -body { + event delete <<Paste>> event add <<Paste>> a b c lsort [event info <<Paste>>] -} {a b c} -test bind-17.12 {event command: info all} { - setup +} -cleanup { + event delete <<Paste>> +} -result {a b c} +test bind-17.13 {event command: info all} -body { + foreach p [event info] {event delete $p} event add <<Paste>> a event add <<Alive>> b lsort [event info] -} {<<Alive>> <<Paste>>} -test bind-17.13 {event command: info error} { - list [catch {event info <<Paste>> <Control-v>} msg] $msg -} {1 {wrong # args: should be "event info ?virtual?"}} -test bind-17.14 {event command: generate} { - list [catch {event generate} msg] $msg -} {1 {wrong # args: should be "event generate window event ?options?"}} -test bind-17.15 {event command: generate} { - setup - bind .b.f <1> "lappend x 1" - set x {} - event generate .b.f <1> - set x -} {1} -test bind-17.16 {event command: generate} { - list [catch {event generate .b.f <xyz>} msg] $msg -} {1 {bad event type or keysym "xyz"}} -test bind-17.17 {event command} { - list [catch {event foo} msg] $msg -} {1 {bad option "foo": must be add, delete, generate, or info}} - -test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} { - list [catch {event add asd <Ctrl-v>} msg] $msg -} {1 {virtual event "asd" is badly formed}} -test bind-18.2 {CreateVirtualEvent procedure: FindSequence} { - list [catch {event add <<asd>> <Ctrl-v>} msg] $msg -} {1 {bad event type or keysym "Ctrl"}} -test bind-18.3 {CreateVirtualEvent procedure: new physical} { - setup +} -cleanup { + event delete <<Paste>> + event delete <<Alive>> +} -result {<<Alive>> <<Paste>>} + +test bind-17.14 {event command: info error} -body { + event info <<Paste>> <Control-v> +} -returnCodes error -result {wrong # args: should be "event info ?virtual?"} +test bind-17.15 {event command: generate} -body { + event generate +} -returnCodes error -result {wrong # args: should be "event generate window event ?-option value ...?"} + +test bind-17.16 {event command: generate} -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 1" + event generate .t.f <1> + set x +} -cleanup { + destroy .t.f +} -result {1} +test bind-17.17 {event command: generate} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + event generate .t.f <xyz> +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad event type or keysym "xyz"} +test bind-17.18 {event command} -body { + event foo +} -returnCodes error -result {bad option "foo": must be add, delete, generate, or info} + + +test bind-18.1 {CreateVirtualEvent procedure: GetVirtualEventUid} -body { + event add asd <Ctrl-v> +} -returnCodes error -result {virtual event "asd" is badly formed} +test bind-18.2 {CreateVirtualEvent procedure: FindSequence} -body { + event add <<asd>> <Ctrl-v> +} -returnCodes error -result {bad event type or keysym "Ctrl"} +test bind-18.3 {CreateVirtualEvent procedure: new physical} -body { + event delete <<xyz>> event add <<xyz>> <Control-v> event info <<xyz>> -} {<Control-Key-v>} -test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} { - setup +} -cleanup { + event delete <<xyz>> +} -result {<Control-Key-v>} +test bind-18.4 {CreateVirtualEvent procedure: duplicate physical} -body { + event delete <<xyz>> event add <<xyz>> <Control-v> event add <<xyz>> <Control-v> event info <<xyz>> -} {<Control-Key-v>} -test bind-18.5 {CreateVirtualEvent procedure: existing physical} { - setup +} -cleanup { + event delete <<xyz>> +} -result {<Control-Key-v>} +test bind-18.5 {CreateVirtualEvent procedure: existing physical} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> event add <<abc>> <Control-v> list [lsort [event info]] [event info <<xyz>>] [event info <<abc>>] -} {{<<abc>> <<xyz>>} <Control-Key-v> <Control-Key-v>} -test bind-18.6 {CreateVirtualEvent procedure: new virtual} { - setup +} -cleanup { + event delete <<xyz>> + event delete <<abc>> +} -result {{<<abc>> <<xyz>>} <Control-Key-v> <Control-Key-v>} +test bind-18.6 {CreateVirtualEvent procedure: new virtual} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> list [event info] [event info <<xyz>>] -} {<<xyz>> <Control-Key-v>} -test bind-18.7 {CreateVirtualEvent procedure: existing virtual} { - setup +} -cleanup { + event delete <<abc>> +} -result {<<xyz>> <Control-Key-v>} +test bind-18.7 {CreateVirtualEvent procedure: existing virtual} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> event add <<xyz>> <Button-2> list [event info] [lsort [event info <<xyz>>]] -} {<<xyz>> {<Button-2> <Control-Key-v>}} +} -cleanup { + event delete <<xyz>> +} -result {<<xyz>> {<Button-2> <Control-Key-v>}} -test bind-19.1 {DeleteVirtualEvent procedure: GetVirtualEventUid} { - list [catch {event add xyz {}} msg] $msg -} {1 {virtual event "xyz" is badly formed}} -test bind-19.2 {DeleteVirtualEvent procedure: non-existent virtual} { - setup +test bind-19.1 {DeleteVirtualEvent procedure: GetVirtualEventUid} -body { + event add xyz {} +} -returnCodes error -result {virtual event "xyz" is badly formed} +test bind-19.2 {DeleteVirtualEvent procedure: non-existent virtual} -setup { + foreach p [event info] {event delete $p} +} -body { event delete <<xyz>> event info -} {} -test bind-19.3 {DeleteVirtualEvent procedure: delete 1} { - setup +} -result {} +test bind-19.3 {DeleteVirtualEvent procedure: delete 1} -setup { + event delete <<xyz>> +} -body { event add <<xyz>> <Control-v> event delete <<xyz>> <Control-v> event info <<xyz>> -} {} -test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} { - setup +} -result {} +test bind-19.4 {DeleteVirtualEvent procedure: delete 1, not owned} -setup { + event delete <<xyz>> +} -body { event add <<xyz>> <Control-v> event delete <<xyz>> <Button-1> event info <<xyz>> -} {<Control-Key-v>} -test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} { - setup +} -result {<Control-Key-v>} +test bind-19.5 {DeleteVirtualEvent procedure: delete 1, badly formed} -body { event add <<xyz>> <Control-v> - list [catch {event delete <<xyz>> <xyz>} msg] $msg -} {1 {bad event type or keysym "xyz"}} -test bind-19.6 {DeleteVirtualEvent procedure: delete 1, badly formed} { - setup + event delete <<xyz>> <xyz> +} -cleanup { + event delete <<xyz>> +} -returnCodes error -result {bad event type or keysym "xyz"} +test bind-19.6 {DeleteVirtualEvent procedure: delete 1, badly formed} -body { event add <<xyz>> <Control-v> - list [catch {event delete <<xyz>> <<Paste>>} msg] $msg -} {1 {virtual event not allowed in definition of another virtual event}} -test bind-19.7 {DeleteVirtualEvent procedure: owns 1, delete all} { - setup + event delete <<xyz>> <<Paste>> +} -cleanup { + event delete <<xyz>> +} -returnCodes error -result {virtual event not allowed in definition of another virtual event} +test bind-19.7 {DeleteVirtualEvent procedure: owns 1, delete all} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> event delete <<xyz>> event info -} {} -test bind-19.8 {DeleteVirtualEvent procedure: owns 1, delete 1} { - setup +} -result {} +test bind-19.8 {DeleteVirtualEvent procedure: owns 1, delete 1} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> event delete <<xyz>> <Control-v> event info -} {} -test bind-19.9 {DeleteVirtualEvent procedure: owns many, delete all} { - setup +} -result {} +test bind-19.9 {DeleteVirtualEvent procedure: owns many, delete all} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> <Control-w> <Control-x> event delete <<xyz>> event info -} {} -test bind-19.10 {DeleteVirtualEvent procedure: owns many, delete 1} { - setup +} -result {} +test bind-19.10 {DeleteVirtualEvent procedure: owns many, delete 1} -body { + event delete <<xyz>> event add <<xyz>> <Control-v> <Control-w> <Control-x> event delete <<xyz>> <Control-w> lsort [event info <<xyz>>] -} {<Control-Key-v> <Control-Key-x>} -test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} { - setup - event add <<xyz>> <Button-2> - bind .b.f <<xyz>> {lappend x %#} +} -cleanup { + event delete <<xyz>> +} -result {<Control-Key-v> <Control-Key-x>} +test bind-19.11 {DeleteVirtualEvent procedure: owned by 1, only} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button-2> -serial 101 - event gen .b.f <ButtonRelease-2> event delete <<xyz>> - event gen .b.f <Button-2> -serial 102 - event gen .b.f <ButtonRelease-2> +} -body { + event add <<xyz>> <Button-2> + bind .t.f <<xyz>> {lappend x %#} + event generate .t.f <Button-2> -serial 101 + event generate .t.f <ButtonRelease-2> + event delete <<xyz>> + event generate .t.f <Button-2> -serial 102 + event generate .t.f <ButtonRelease-2> set x -} {101} -test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} { - setup +} -cleanup { + destroy .t.f +} -result {101} +test bind-19.12 {DeleteVirtualEvent procedure: owned by 1, first in chain} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} + event delete <<xyz>> + event delete <<abc>> +} -body { event add <<abc>> <Control-Button-2> event add <<xyz>> <Button-2> - bind .b.f <<xyz>> {lappend x xyz} - bind .b.f <<abc>> {lappend x abc} - set x {} - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Control-Button-2> - event gen .b.f <Control-ButtonRelease-2> + bind .t.f <<xyz>> {lappend x xyz} + bind .t.f <<abc>> {lappend x abc} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Control-Button-2> + event generate .t.f <Control-ButtonRelease-2> event delete <<xyz>> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Control-Button-2> - event gen .b.f <Control-ButtonRelease-2> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Control-Button-2> + event generate .t.f <Control-ButtonRelease-2> list $x [event info <<abc>>] -} {{xyz abc abc} <Control-Button-2>} -test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} { - setup +} -cleanup { + destroy .t.f + event delete <<abc>> +} -result {{xyz abc abc} <Control-Button-2>} +test bind-19.13 {DeleteVirtualEvent procedure: owned by 1, second in chain} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} + event delete <<def>> + event delete <<xyz>> + event delete <<abc>> +} -body { event add <<def>> <Shift-Button-2> event add <<xyz>> <Button-2> event add <<abc>> <Control-Button-2> - bind .b.f <<xyz>> {lappend x xyz} - bind .b.f <<abc>> {lappend x abc} - bind .b.f <<def>> {lappend x def} - set x {} - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Control-Button-2> - event gen .b.f <Control-ButtonRelease-2> - event gen .b.f <Shift-Button-2> - event gen .b.f <Shift-ButtonRelease-2> + bind .t.f <<xyz>> {lappend x xyz} + bind .t.f <<abc>> {lappend x abc} + bind .t.f <<def>> {lappend x def} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Control-Button-2> + event generate .t.f <Control-ButtonRelease-2> + event generate .t.f <Shift-Button-2> + event generate .t.f <Shift-ButtonRelease-2> event delete <<xyz>> - event gen .b.f <Button-2> - event gen .b.f <Control-Button-2> - event gen .b.f <Shift-Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Control-ButtonRelease-2> - event gen .b.f <Shift-ButtonRelease-2> + event generate .t.f <Button-2> + event generate .t.f <Control-Button-2> + event generate .t.f <Shift-Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Control-ButtonRelease-2> + event generate .t.f <Shift-ButtonRelease-2> list $x [event info <<def>>] [event info <<xyz>>] [event info <<abc>>] -} {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>} -test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} { - setup +} -cleanup { + destroy .t.f + event delete <<abc>> + event delete <<def>> +} -result {{xyz abc def abc def} <Shift-Button-2> {} <Control-Button-2>} +test bind-19.14 {DeleteVirtualEvent procedure: owned by 1, last in chain} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} + event delete <<def>> + event delete <<xyz>> + event delete <<abc>> +} -body { event add <<xyz>> <Button-2> event add <<abc>> <Control-Button-2> event add <<def>> <Shift-Button-2> - bind .b.f <<xyz>> {lappend x xyz} - bind .b.f <<abc>> {lappend x abc} - bind .b.f <<def>> {lappend x def} - set x {} - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Control-Button-2> - event gen .b.f <Control-ButtonRelease-2> - event gen .b.f <Shift-Button-2> - event gen .b.f <Shift-ButtonRelease-2> + bind .t.f <<xyz>> {lappend x xyz} + bind .t.f <<abc>> {lappend x abc} + bind .t.f <<def>> {lappend x def} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Control-Button-2> + event generate .t.f <Control-ButtonRelease-2> + event generate .t.f <Shift-Button-2> + event generate .t.f <Shift-ButtonRelease-2> event delete <<xyz>> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Control-Button-2> - event gen .b.f <Control-ButtonRelease-2> - event gen .b.f <Shift-Button-2> - event gen .b.f <Shift-ButtonRelease-2> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Control-Button-2> + event generate .t.f <Control-ButtonRelease-2> + event generate .t.f <Shift-Button-2> + event generate .t.f <Shift-ButtonRelease-2> list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] -} {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>} -test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} { - setup - pack [frame .b.g -class Test -width 150 -height 100] - pack [frame .b.h -class Test -width 150 -height 100] +} -cleanup { + destroy .t.f + event delete <<def>> + event delete <<abc>> +} -result {{xyz abc def abc def} {} <Control-Button-2> <Shift-Button-2>} +test bind-19.15 {DeleteVirtualEvent procedure: owned by many, first} -setup { + pack [frame .t.f -class Test -width 150 -height 100] + pack [frame .t.g -class Test -width 150 -height 100] + pack [frame .t.h -class Test -width 150 -height 100] + focus -force .t.f update + set x {} + event delete <<def>> + event delete <<xyz>> + event delete <<abc>> +} -body { event add <<xyz>> <Button-2> event add <<abc>> <Button-2> event add <<def>> <Button-2> - bind .b.f <<xyz>> {lappend x xyz} - bind .b.g <<abc>> {lappend x abc} - bind .b.h <<def>> {lappend x def} - set x {} - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.g <Button-2> - event gen .b.g <ButtonRelease-2> - event gen .b.h <Button-2> - event gen .b.h <ButtonRelease-2> + bind .t.f <<xyz>> {lappend x xyz} + bind .t.g <<abc>> {lappend x abc} + bind .t.h <<def>> {lappend x def} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.g <Button-2> + event generate .t.g <ButtonRelease-2> + event generate .t.h <Button-2> + event generate .t.h <ButtonRelease-2> event delete <<xyz>> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.g <Button-2> - event gen .b.g <ButtonRelease-2> - event gen .b.h <Button-2> - event gen .b.h <ButtonRelease-2> - destroy .b.g - destroy .b.h + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.g <Button-2> + event generate .t.g <ButtonRelease-2> + event generate .t.h <Button-2> + event generate .t.h <ButtonRelease-2> list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] -} {{xyz abc def abc def} {} <Button-2> <Button-2>} -test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} { - setup - pack [frame .b.g -class Test -width 150 -height 100] - pack [frame .b.h -class Test -width 150 -height 100] +} -cleanup { + destroy .t.f .t.g .t.h + event delete <<def>> + event delete <<abc>> +} -result {{xyz abc def abc def} {} <Button-2> <Button-2>} +test bind-19.16 {DeleteVirtualEvent procedure: owned by many, middle} -setup { + pack [frame .t.f -class Test -width 150 -height 100] + pack [frame .t.g -class Test -width 150 -height 100] + pack [frame .t.h -class Test -width 150 -height 100] + focus -force .t.f update + set x {} + event delete <<def>> + event delete <<xyz>> + event delete <<abc>> +} -body { event add <<xyz>> <Button-2> event add <<abc>> <Button-2> event add <<def>> <Button-2> - bind .b.f <<xyz>> {lappend x xyz} - bind .b.g <<abc>> {lappend x abc} - bind .b.h <<def>> {lappend x def} - set x {} - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.g <Button-2> - event gen .b.g <ButtonRelease-2> - event gen .b.h <Button-2> - event gen .b.h <ButtonRelease-2> + bind .t.f <<xyz>> {lappend x xyz} + bind .t.g <<abc>> {lappend x abc} + bind .t.h <<def>> {lappend x def} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.g <Button-2> + event generate .t.g <ButtonRelease-2> + event generate .t.h <Button-2> + event generate .t.h <ButtonRelease-2> event delete <<abc>> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.g <Button-2> - event gen .b.g <ButtonRelease-2> - event gen .b.h <Button-2> - event gen .b.h <ButtonRelease-2> - destroy .b.g - destroy .b.h + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.g <Button-2> + event generate .t.g <ButtonRelease-2> + event generate .t.h <Button-2> + event generate .t.h <ButtonRelease-2> list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] -} {{xyz abc def xyz def} <Button-2> {} <Button-2>} -test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} { - setup - pack [frame .b.g -class Test -width 150 -height 100] - pack [frame .b.h -class Test -width 150 -height 100] +} -cleanup { + destroy .t.f .t.g .t.h + event delete <<def>> + event delete <<xyz>> +} -result {{xyz abc def xyz def} <Button-2> {} <Button-2>} +test bind-19.17 {DeleteVirtualEvent procedure: owned by many, last} -setup { + pack [frame .t.f -class Test -width 150 -height 100] + pack [frame .t.g -class Test -width 150 -height 100] + pack [frame .t.h -class Test -width 150 -height 100] + focus -force .t.f update + set x {} + event delete <<def>> + event delete <<xyz>> + event delete <<abc>> +} -body { event add <<xyz>> <Button-2> event add <<abc>> <Button-2> event add <<def>> <Button-2> - bind .b.f <<xyz>> {lappend x xyz} - bind .b.g <<abc>> {lappend x abc} - bind .b.h <<def>> {lappend x def} - set x {} - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.g <Button-2> - event gen .b.g <ButtonRelease-2> - event gen .b.h <Button-2> - event gen .b.h <ButtonRelease-2> + bind .t.f <<xyz>> {lappend x xyz} + bind .t.g <<abc>> {lappend x abc} + bind .t.h <<def>> {lappend x def} + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.g <Button-2> + event generate .t.g <ButtonRelease-2> + event generate .t.h <Button-2> + event generate .t.h <ButtonRelease-2> event delete <<def>> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.g <Button-2> - event gen .b.g <ButtonRelease-2> - event gen .b.h <Button-2> - event gen .b.h <ButtonRelease-2> - destroy .b.g - destroy .b.h + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.g <Button-2> + event generate .t.g <ButtonRelease-2> + event generate .t.h <Button-2> + event generate .t.h <ButtonRelease-2> list $x [event info <<xyz>>] [event info <<abc>>] [event info <<def>>] -} {{xyz abc def xyz abc} <Button-2> <Button-2> {}} +} -cleanup { + destroy .t.f .t.g .t.h + event delete <<xyz>> + event delete <<abc>> +} -result {{xyz abc def xyz abc} <Button-2> <Button-2> {}} -test bind-20.1 {GetVirtualEvent procedure: GetVirtualEventUid} { - list [catch {event info asd} msg] $msg -} {1 {virtual event "asd" is badly formed}} -test bind-20.2 {GetVirtualEvent procedure: non-existent event} { +test bind-20.1 {GetVirtualEvent procedure: GetVirtualEventUid} -body { + event info asd +} -returnCodes error -result {virtual event "asd" is badly formed} +test bind-20.2 {GetVirtualEvent procedure: non-existent event} -body { + event delete <<asd>> event info <<asd>> -} {} -test bind-20.3 {GetVirtualEvent procedure: owns 1} { - setup +} -result {} +test bind-20.3 {GetVirtualEvent procedure: owns 1} -setup { + event delete <<xyz>> +} -body { event add <<xyz>> <Control-Key-v> event info <<xyz>> -} {<Control-Key-v>} -test bind-20.4 {GetVirtualEvent procedure: owns many} { - setup +} -cleanup { + event delete <<xyz>> +} -result {<Control-Key-v>} +test bind-20.4 {GetVirtualEvent procedure: owns many} -setup { + event delete <<xyz>> +} -body { event add <<xyz>> <Control-v> <Button-2> spack event info <<xyz>> -} {<Control-Key-v> <Button-2> spack} +} -cleanup { + event delete <<xyz>> +} -result {<Control-Key-v> <Button-2> spack} -test bind-21.1 {GetAllVirtualEvents procedure: no events} { - setup +test bind-21.1 {GetAllVirtualEvents procedure: no events} -body { + foreach p [event info] {event delete $p} event info -} {} -test bind-21.2 {GetAllVirtualEvents procedure: 1 event} { - setup +} -result {} +test bind-21.2 {GetAllVirtualEvents procedure: 1 event} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> event info -} {<<xyz>>} -test bind-21.3 {GetAllVirtualEvents procedure: many events} { - setup +} -cleanup { + event delete <<xyz>> +} -result {<<xyz>>} +test bind-21.3 {GetAllVirtualEvents procedure: many events} -body { + foreach p [event info] {event delete $p} event add <<xyz>> <Control-v> event add <<xyz>> <Button-2> event add <<abc>> <Control-v> event add <<def>> <Key-F6> lsort [event info] -} {<<abc>> <<def>> <<xyz>>} - -test bind-22.1 {HandleEventGenerate} { - list [catch {event gen .xyz <Control-v>} msg] $msg -} {1 {bad window path name ".xyz"}} -test bind-22.2 {HandleEventGenerate} { - list [catch {event gen zzz <Control-v>} msg] $msg -} {1 {bad window name/identifier "zzz"}} -test bind-22.3 {HandleEventGenerate} { - list [catch {event gen 47 <Control-v>} msg] $msg -} {1 {bad window name/identifier "47"}} -test bind-22.4 {HandleEventGenerate} { - setup - bind .b.f <Button> {set x "%s %b"} - set x {} - event gen [winfo id .b.f] <Control-Button-1> -state 260 - set x -} {260 1} -test bind-22.5 {HandleEventGenerate} { - list [catch {event gen . <xyz>} msg] $msg -} {1 {bad event type or keysym "xyz"}} -test bind-22.6 {HandleEventGenerate} { - list [catch {event gen . <Double-Button-1>} msg] $msg -} {1 {Double or Triple modifier not allowed}} -test bind-22.7 {HandleEventGenerate} { - list [catch {event gen . xyz} msg] $msg -} {1 {only one event specification allowed}} -test bind-22.8 {HandleEventGenerate} { - list [catch {event gen . <Button> -button} msg] $msg -} {1 {value for "-button" missing}} -test bind-22.9 {HandleEventGenerate} { - setup - bind .b.f <Button> {set x "%s %b"} - set x {} - event gen .b.f <ButtonRelease-1> - event gen .b.f <ButtonRelease-2> - event gen .b.f <ButtonRelease-3> - event gen .b.f <Control-Button-1> - event gen .b.f <Control-ButtonRelease-1> - set x -} {4 1} -test bind-22.10 {HandleEventGenerate} { - setup - bind .b.f <Key> {set x "%s %K"} - set x {} - event gen .b.f <Control-Key-1> - set x -} {4 1} -test bind-22.11 {HandleEventGenerate} { - setup - bind .b.f <<Paste>> {set x "%s"} - set x {} - event gen .b.f <<Paste>> -state 1 - set x -} {1} -test bind-22.12 {HandleEventGenerate} { - setup - bind .b.f <Motion> {set x "%s"} - set x {} - event gen .b.f <Control-Motion> - set x -} {4} -test bind-22.13 {HandleEventGenerate} { - setup - bind .b.f <Button> {lappend x %#} - set x {} - event gen .b.f <Button> -when now -serial 100 - event gen .b.f <ButtonRelease> -when now - set x -} {100} -test bind-22.14 {HandleEventGenerate} { - setup - bind .b.f <Button> {lappend x %#} - set x {} - event gen .b.f <Button> -when head -serial 100 - event gen .b.f <Button> -when head -serial 101 - event gen .b.f <Button> -when head -serial 102 - event gen .b.f <ButtonRelease> -when tail +} -cleanup { + event delete <<xyz>> + event delete <<abc>> + event delete <<def>> +} -result {<<abc>> <<def>> <<xyz>>} + +test bind-22.1 {HandleEventGenerate} -setup { + destroy .xyz +} -body { + event generate .xyz <Control-v> +} -returnCodes error -result {bad window path name ".xyz"} +test bind-22.2 {HandleEventGenerate} -body { + event generate zzz <Control-v> +} -returnCodes error -result {bad window name/identifier "zzz"} +test bind-22.3 {HandleEventGenerate} -body { + event generate 47 <Control-v> +} -returnCodes error -result {bad window name/identifier "47"} +test bind-22.4 {HandleEventGenerate} -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 "%s %b"} + event generate [winfo id .t.f] <Control-Button-1> -state 260 + set x +} -cleanup { + destroy .t.f +} -result {260 1} +test bind-22.5 {HandleEventGenerate} -body { + event generate . <xyz> +} -returnCodes error -result {bad event type or keysym "xyz"} +test bind-22.6 {HandleEventGenerate} -body { + event generate . <Double-Button-1> +} -returnCodes error -result {Double or Triple modifier not allowed} +test bind-22.7 {HandleEventGenerate} -body { + event generate . xyz +} -returnCodes error -result {only one event specification allowed} +test bind-22.8 {HandleEventGenerate} -body { + event generate . <Button> -button +} -returnCodes error -result {value for "-button" missing} +test bind-22.9 {HandleEventGenerate} -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 "%s %b"} + event generate .t.f <ButtonRelease-1> + event generate .t.f <ButtonRelease-2> + event generate .t.f <ButtonRelease-3> + event generate .t.f <Control-Button-1> + event generate .t.f <Control-ButtonRelease-1> + set x +} -cleanup { + destroy .t.f +} -result {4 1} +test bind-22.10 {HandleEventGenerate} -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> {set x "%s %K"} + event generate .t.f <Control-Key-space> + set x +} -cleanup { + destroy .t.f +} -result {4 space} +test bind-22.11 {HandleEventGenerate} -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>> {set x "%s"} + event generate .t.f <<Paste>> -state 1 + set x +} -cleanup { + destroy .t.f +} -result {1} +test bind-22.12 {HandleEventGenerate} -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> {set x "%s"} + event generate .t.f <Control-Motion> + set x +} -cleanup { + destroy .t.f +} -result {4} +test bind-22.13 {HandleEventGenerate} -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 %#} + event generate .t.f <Button> -when now -serial 100 + event generate .t.f <ButtonRelease> -when now + set x +} -cleanup { + destroy .t.f +} -result {100} +test bind-22.14 {HandleEventGenerate} -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 %#} + event generate .t.f <Button> -when head -serial 100 + event generate .t.f <Button> -when head -serial 101 + event generate .t.f <Button> -when head -serial 102 + event generate .t.f <ButtonRelease> -when tail lappend x foo update set x -} {foo 102 101 100} -test bind-22.15 {HandleEventGenerate} { - setup - bind .b.f <Button> {lappend x %#} +} -cleanup { + destroy .t.f +} -result {foo 102 101 100} +test bind-22.15 {HandleEventGenerate} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button> -when head -serial 99 - event gen .b.f <Button> -when mark -serial 100 - event gen .b.f <Button> -when mark -serial 101 - event gen .b.f <Button> -when mark -serial 102 - event gen .b.f <ButtonRelease> -when tail +} -body { + bind .t.f <Button> {lappend x %#} + event generate .t.f <Button> -when head -serial 99 + event generate .t.f <Button> -when mark -serial 100 + event generate .t.f <Button> -when mark -serial 101 + event generate .t.f <Button> -when mark -serial 102 + event generate .t.f <ButtonRelease> -when tail lappend x foo update set x -} {foo 100 101 102 99} -test bind-22.16 {HandleEventGenerate} { - setup - bind .b.f <Button> {lappend x %#} +} -cleanup { + destroy .t.f +} -result {foo 100 101 102 99} +test bind-22.16 {HandleEventGenerate} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - event gen .b.f <Button> -when head -serial 99 - event gen .b.f <Button> -when tail -serial 100 - event gen .b.f <Button> -when tail -serial 101 - event gen .b.f <Button> -when tail -serial 102 - event gen .b.f <ButtonRelease> -when tail +} -body { + bind .t.f <Button> {lappend x %#} + event generate .t.f <Button> -when head -serial 99 + event generate .t.f <Button> -when tail -serial 100 + event generate .t.f <Button> -when tail -serial 101 + event generate .t.f <Button> -when tail -serial 102 + event generate .t.f <ButtonRelease> -when tail lappend x foo update set x -} {foo 99 100 101 102} -test bind-22.17 {HandleEventGenerate} { - list [catch {event gen . <Button> -when xyz} msg] $msg -} {1 {bad -when value "xyz": must be now, head, mark, or tail}} -test bind-22.18 {HandleEventGenerate} { +} -cleanup { + destroy .t.f +} -result {foo 99 100 101 102} +test bind-22.17 {HandleEventGenerate} -body { + event generate . <Button> -when xyz +} -returnCodes error -result {bad -when value "xyz": must be now, head, mark, or tail} +test bind-22.18 {HandleEventGenerate} -body { # Bug 411307 - list [catch {event gen . <a> -root 98765} msg] $msg -} {1 {bad window name/identifier "98765"}} -foreach check { - {bind-22.19 <Configure> %a {-above .xyz} {{1 {bad window path name ".xyz"}}}} - {bind-22.20 <Configure> %a {-above .b} {[winfo id .b]}} - {bind-22.21 <Configure> %a {-above xyz} {{1 {bad window name/identifier "xyz"}}}} - {bind-22.22 <Configure> %a {-above [winfo id .b]} {[winfo id .b]}} - {bind-22.23 <Key> %b {-above .} {{1 {<Key> event doesn't accept "-above" option}}}} - - {bind-22.24 <Configure> %B {-borderwidth xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.25 <Configure> %B {-borderwidth 2i} {[winfo pixels .b.f 2i]}} - {bind-22.26 <Key> %k {-borderwidth 2i} {{1 {<Key> event doesn't accept "-borderwidth" option}}}} - - {bind-22.27 <Button> %b {-button xyz} {{1 {expected integer but got "xyz"}}}} - {bind-22.28 <Button> %b {-button 1} 1} - {bind-22.29 <ButtonRelease> %b {-button 1} 1} - {bind-22.30 <Key> %k {-button 1} {{1 {<Key> event doesn't accept "-button" option}}}} - - {bind-22.31 <Expose> %c {-count xyz} {{1 {expected integer but got "xyz"}}}} - {bind-22.32 <Expose> %c {-count 20} 20} - {bind-22.33 <Key> %b {-count 20} {{1 {<Key> event doesn't accept "-count" option}}}} - - {bind-22.34 <Enter> %d {-detail xyz} {{1 {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone}}}} - {bind-22.35 <FocusIn> %d {-detail NotifyVirtual} {{}}} - {bind-22.36 <Enter> %d {-detail NotifyVirtual} NotifyVirtual} - {bind-22.37 <Key> %k {-detail NotifyVirtual} {{1 {<Key> event doesn't accept "-detail" option}}}} - - {bind-22.38 <Enter> %f {-focus xyz} {{1 {expected boolean value but got "xyz"}}}} - {bind-22.39 <Enter> %f {-focus 1} 1} - {bind-22.40 <Key> %k {-focus 1} {{1 {<Key> event doesn't accept "-focus" option}}}} - - {bind-22.41 <Expose> %h {-height xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.42 <Expose> %h {-height 2i} {[winfo pixels .b.f 2i]}} - {bind-22.43 <Configure> %h {-height 2i} {[winfo pixels .b.f 2i]}} - {bind-22.44 <Key> %k {-height 2i} {{1 {<Key> event doesn't accept "-height" option}}}} - - {bind-22.45 <Key> %k {-keycode xyz} {{1 {expected integer but got "xyz"}}}} - {bind-22.46 <Key> %k {-keycode 20} 20} - {bind-22.47 <Button> %b {-keycode 20} {{1 {<Button> event doesn't accept "-keycode" option}}}} - - {bind-22.48 <Key> %K {-keysym xyz} {{1 {unknown keysym "xyz"}}}} - {bind-22.49 <Key> %K {-keysym a} a} - {bind-22.50 <Button> %b {-keysym a} {{1 {<Button> event doesn't accept "-keysym" option}}}} - - {bind-22.51 <Enter> %m {-mode xyz} {{1 {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed}}}} - {bind-22.52 <Enter> %m {-mode NotifyNormal} NotifyNormal} - {bind-22.53 <FocusIn> %m {-mode NotifyNormal} {{}}} - {bind-22.54 <Key> %k {-mode NotifyNormal} {{1 {<Key> event doesn't accept "-mode" option}}}} - - {bind-22.55 <Map> %o {-override xyz} {{1 {expected boolean value but got "xyz"}}}} - {bind-22.56 <Map> %o {-override 1} 1} - {bind-22.57 <Reparent> %o {-override 1} 1} - {bind-22.58 <Configure> %o {-override 1} 1} - {bind-22.59 <Key> %k {-override 1} {{1 {<Key> event doesn't accept "-override" option}}}} - - {bind-22.60 <Circulate> %p {-place xyz} {{1 {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom}}}} - {bind-22.61 <Circulate> %p {-place PlaceOnTop} PlaceOnTop} - {bind-22.62 <Key> %k {-place PlaceOnTop} {{1 {<Key> event doesn't accept "-place" option}}}} - - {bind-22.63 <Key> %R {-root .xyz} {{1 {bad window path name ".xyz"}}}} - {bind-22.64 <Key> %R {-root .b} {[winfo id .b]}} - {bind-22.65 <Key> %R {-root xyz} {{1 {bad window name/identifier "xyz"}}}} - {bind-22.66 <Key> %R {-root [winfo id .b]} {[winfo id .b]}} - {bind-22.67 <Button> %R {-root .b} {[winfo id .b]}} - {bind-22.68 <ButtonRelease> %R {-root .b} {[winfo id .b]}} - {bind-22.69 <Motion> %R {-root .b} {[winfo id .b]}} - {bind-22.70 <<Paste>> %R {-root .b} {[winfo id .b]}} - {bind-22.71 <Enter> %R {-root .b} {[winfo id .b]}} - {bind-22.72 <Configure> %R {-root .b} {{1 {<Configure> event doesn't accept "-root" option}}}} - - {bind-22.73 <Key> %X {-rootx xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.74 <Key> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {bind-22.75 <Button> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {bind-22.76 <ButtonRelease> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {bind-22.77 <Motion> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {bind-22.78 <<Paste>> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {bind-22.79 <Enter> %X {-rootx 2i} {[winfo pixels .b.f 2i]}} - {bind-22.80 <Configure> %X {-rootx 2i} {{1 {<Configure> event doesn't accept "-rootx" option}}}} - - {bind-22.81 <Key> %Y {-rooty xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.82 <Key> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {bind-22.83 <Button> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {bind-22.84 <ButtonRelease> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {bind-22.85 <Motion> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {bind-22.86 <<Paste>> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {bind-22.87 <Enter> %Y {-rooty 2i} {[winfo pixels .b.f 2i]}} - {bind-22.88 <Configure> %Y {-rooty 2i} {{1 {<Configure> event doesn't accept "-rooty" option}}}} - - {bind-22.89 <Key> %E {-sendevent xyz} {{1 {expected boolean value but got "xyz"}}}} - {bind-22.90 <Key> %E {-sendevent 1} 1} - {bind-22.91 <Key> %E {-sendevent yes} 1} - {bind-22.92 <Key> %E {-sendevent 43} 43} - - {bind-22.93 <Key> %# {-serial xyz} {{1 {expected integer but got "xyz"}}}} - {bind-22.94 <Key> %# {-serial 100} 100} - - {bind-22.95 <Key> %s {-state xyz} {{1 {expected integer but got "xyz"}}}} - {bind-22.96 <Key> %s {-state 1} 1} - {bind-22.97 <Button> %s {-state 1025} 1025} - {bind-22.98 <ButtonRelease> %s {-state 1025} 1025} - {bind-22.99 <Motion> %s {-state 1} 1} - {bind-22.100 <<Paste>> %s {-state 1} 1} - {bind-22.101 <Enter> %s {-state 1} 1} - {bind-22.102 <Visibility> %s {-state xyz} {{1 {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured}}}} - {bind-22.103 <Visibility> %s {-state VisibilityUnobscured} VisibilityUnobscured} - {bind-22.104 <Configure> %s {-state xyz} {{1 {<Configure> event doesn't accept "-state" option}}}} - - {bind-22.105 <Key> %S {-subwindow .xyz} {{1 {bad window path name ".xyz"}}}} - {bind-22.106 <Key> %S {-subwindow .b} {[winfo id .b]}} - {bind-22.107 <Key> %S {-subwindow xyz} {{1 {bad window name/identifier "xyz"}}}} - {bind-22.108 <Key> %S {-subwindow [winfo id .b]} {[winfo id .b]}} - {bind-22.109 <Button> %S {-subwindow .b} {[winfo id .b]}} - {bind-22.110 <ButtonRelease> %S {-subwindow .b} {[winfo id .b]}} - {bind-22.111 <Motion> %S {-subwindow .b} {[winfo id .b]}} - {bind-22.112 <<Paste>> %S {-subwindow .b} {[winfo id .b]}} - {bind-22.113 <Enter> %S {-subwindow .b} {[winfo id .b]}} - {bind-22.114 <Configure> %S {-subwindow .b} {{1 {<Configure> event doesn't accept "-subwindow" option}}}} - - {bind-22.115 <Key> %t {-time xyz} {{1 {expected integer but got "xyz"}}}} - {bind-22.116 <Key> %t {-time 100} 100} - {bind-22.117 <Button> %t {-time 100} 100} - {bind-22.118 <ButtonRelease> %t {-time 100} 100} - {bind-22.119 <Motion> %t {-time 100} 100} - {bind-22.120 <<Paste>> %t {-time 100} 100} - {bind-22.121 <Enter> %t {-time 100} 100} - {bind-22.122 <Property> %t {-time 100} 100} - {bind-22.123 <Configure> %t {-time 100} {{1 {<Configure> event doesn't accept "-time" option}}}} - - {bind-22.124 <Expose> %w {-width xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.125 <Expose> %w {-width 2i} {[winfo pixels .b.f 2i]}} - {bind-22.126 <Configure> %w {-width 2i} {[winfo pixels .b.f 2i]}} - {bind-22.127 <Key> %k {-width 2i} {{1 {<Key> event doesn't accept "-width" option}}}} - - {bind-22.128 <Unmap> %W {-window .xyz} {{1 {bad window path name ".xyz"}}}} - {bind-22.129 <Unmap> %W {-window .b.f} .b.f} - {bind-22.130 <Unmap> %W {-window xyz} {{1 {bad window name/identifier "xyz"}}}} - {bind-22.131 <Unmap> %W {-window [winfo id .b.f]} .b.f} - {bind-22.132 <Unmap> %W {-window .b.f} .b.f} - {bind-22.133 <Map> %W {-window .b.f} .b.f} - {bind-22.134 <Reparent> %W {-window .b.f} .b.f} - {bind-22.135 <Configure> %W {-window .b.f} .b.f} - {bind-22.136 <Gravity> %W {-window .b.f} .b.f} - {bind-22.137 <Circulate> %W {-window .b.f} .b.f} - {bind-22.138 <Key> %W {-window .b.f} {{1 {<Key> event doesn't accept "-window" option}}}} - - {bind-22.139 <Key> %x {-x xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.140 <Key> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.141 <Button> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.142 <ButtonRelease> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.143 <Motion> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.144 <<Paste>> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.145 <Enter> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.146 <Expose> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.147 <Configure> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.148 <Gravity> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.149 <Reparent> %x {-x 2i} {[winfo pixels .b.f 2i]}} - {bind-22.150 <Map> %x {-x 2i} {{1 {<Map> event doesn't accept "-x" option}}}} - - {bind-22.151 <Key> %y {-y xyz} {{1 {bad screen distance "xyz"}}}} - {bind-22.152 <Key> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.153 <Button> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.154 <ButtonRelease> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.155 <Motion> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.156 <<Paste>> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.157 <Enter> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.158 <Expose> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.159 <Configure> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.160 <Gravity> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.161 <Reparent> %y {-y 2i} {[winfo pixels .b.f 2i]}} - {bind-22.162 <Map> %y {-y 2i} {{1 {<Map> event doesn't accept "-y" option}}}} - - {bind-22.163 <Key> %k {-xyz 1} {{1 {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -data, -delta, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -warp, -width, -window, -x, or -y}}}} -} { - lassign $check name event substitution generator result - test $name "HandleEventGenerate: options $event $generator" { - setup - bind .b.f $event "lappend x $substitution" - set x {} - if [catch {eval event gen .b.f $event $generator} msg] { - set x [list 1 $msg] - } - set x - } [eval set x $result] -} + event generate . <a> -root 98765 +} -returnCodes error -result {bad window name/identifier "98765"} + +test bind-22.19 {HandleEventGenerate: options <Configure> -above .xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %a" + event generate .t.f <Configure> -above .xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window path name ".xyz"} +test bind-22.20 {HandleEventGenerate: options <Configure> -above .t} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %a" + event generate .t.f <Configure> -above .t + return $x +} -cleanup { + destroy .t.f +} -result [winfo id .t] +test bind-22.21 {HandleEventGenerate: options <Configure> -above xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %a" + event generate .t.f <Configure> -above xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window name/identifier "xyz"} +test bind-22.22 {HandleEventGenerate: options <Configure> -above [winfo id .t]} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %a" + event generate .t.f <Configure> -above [winfo id .t] + return $x +} -cleanup { + destroy .t.f +} -result [winfo id .t] + +test bind-22.23 {HandleEventGenerate: options <Key> -above .} -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 %b" + event generate .t.f <Key> -above . + return $x +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-above" option} + +test bind-22.24 {HandleEventGenerate: options <Configure> -borderwidth xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %B" + event generate .t.f <Configure> -borderwidth xyz + return $x +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.25 {HandleEventGenerate: options <Configure> -borderwidth 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %B" + event generate .t.f <Configure> -borderwidth 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.26 {HandleEventGenerate: options <Key> -borderwidth 2i} -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 %k" + event generate .t.f <Key> -borderwidth 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-borderwidth" option} + +test bind-22.27 {HandleEventGenerate: options <Button> -button xyz} -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 %b" + event generate .t.f <Button> -button xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "xyz"} + +test bind-22.28 {HandleEventGenerate: options <Button> -button 1} -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 %b" + event generate .t.f <Button> -button 1 + return $x +} -cleanup { + destroy .t.f +} -result 1 + +test bind-22.29 {HandleEventGenerate: options <ButtonRelease> -button 1} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %b" + event generate .t.f <ButtonRelease> -button 1 + return $x +} -cleanup { + destroy .t.f +} -result 1 + +test bind-22.30 {HandleEventGenerate: options <Key> -button 1} -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 %k" + event generate .t.f <Key> -button 1 +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-button" option} + +test bind-22.31 {HandleEventGenerate: options <Expose> -count xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %c" + event generate .t.f <Expose> -count xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "xyz"} + +test bind-22.32 {HandleEventGenerate: options <Expose> -count 20} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %c" + event generate .t.f <Expose> -count 20 + return $x +} -cleanup { + destroy .t.f +} -result {20} + +test bind-22.33 {HandleEventGenerate: options <Key> -count 20} -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 %b" + event generate .t.f <Key> -count 20 +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-count" option} + +test bind-22.34 {HandleEventGenerate: options <Enter> -detail xyz} -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 %d" + event generate .t.f <Enter> -detail xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad -detail value "xyz": must be NotifyAncestor, NotifyVirtual, NotifyInferior, NotifyNonlinear, NotifyNonlinearVirtual, NotifyPointer, NotifyPointerRoot, or NotifyDetailNone} + +test bind-22.35 {HandleEventGenerate: options <FocusIn> -detail NotifyVirtual} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <FocusIn> "lappend x FocusIn %d" + event generate .t.f <FocusIn> -detail NotifyVirtual + return $x +} -cleanup { + destroy .t.f +} -result {FocusIn NotifyVirtual} + +test bind-22.35.1 {HandleEventGenerate: options <FocusOut> -detail NotifyVirtual} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <FocusOut> "lappend x FocusOut %d" + event generate .t.f <FocusOut> -detail NotifyVirtual + return $x +} -cleanup { + destroy .t.f +} -result {FocusOut NotifyVirtual} + +test bind-22.36 {HandleEventGenerate: options <Enter> -detail NotifyVirtual} -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 %d" + event generate .t.f <Enter> -detail NotifyVirtual + return $x +} -cleanup { + destroy .t.f +} -result {NotifyVirtual} + +test bind-22.37 {HandleEventGenerate: options <Key> -detail NotifyVirtual} -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 %k" + event generate .t.f <Key> -detail NotifyVirtual +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-detail" option} + +test bind-22.38 {HandleEventGenerate: options <Enter> -focus xyz} -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 %f" + event generate .t.f <Enter> -focus xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected boolean value but got "xyz"} + +test bind-22.39 {HandleEventGenerate: options <Enter> -focus 1} -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 %f" + event generate .t.f <Enter> -focus 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.40 {HandleEventGenerate: options <Key> -focus 1} -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 %k" + event generate .t.f <Key> -focus 1 +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-focus" option} + +test bind-22.41 {HandleEventGenerate: options <Expose> -height xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %h" + event generate .t.f <Expose> -height xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.42 {HandleEventGenerate: options <Expose> -height 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %h" + event generate .t.f <Expose> -height 2i + expr {$x eq [winfo pixels .t.f 2i]} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.43 {HandleEventGenerate: options <Configure> -height 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %h" + event generate .t.f <Configure> -height 2i + expr {$x eq [winfo pixels .t.f 2i]} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.44 {HandleEventGenerate: options <Key> -height 2i} -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 %k" + event generate .t.f <Key> -height 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-height" option} + +test bind-22.45 {HandleEventGenerate: options <Key> -keycode xyz} -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 %k" + event generate .t.f <Key> -keycode xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "xyz"} + +test bind-22.46 {HandleEventGenerate: options <Key> -keycode 20} -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 %k" + event generate .t.f <Key> -keycode 20 + return $x +} -cleanup { + destroy .t.f +} -result {20} + +test bind-22.47 {HandleEventGenerate: options <Button> -keycode 20} -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 %b" + event generate .t.f <Button> -keycode 20 +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Button> event doesn't accept "-keycode" option} + +test bind-22.48 {HandleEventGenerate: options <Key> -keysym xyz} -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 %K" + event generate .t.f <Key> -keysym xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {unknown keysym "xyz"} + +test bind-22.49 {HandleEventGenerate: options <Key> -keysym space} -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 %K" + event generate .t.f <Key> -keysym space + return $x +} -cleanup { + destroy .t.f +} -result {space} + +test bind-22.50 {HandleEventGenerate: options <Button> -keysym space} -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 %b" + event generate .t.f <Button> -keysym space +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Button> event doesn't accept "-keysym" option} + +test bind-22.51 {HandleEventGenerate: options <Enter> -mode xyz} -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 %m" + event generate .t.f <Enter> -mode xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad -mode value "xyz": must be NotifyNormal, NotifyGrab, NotifyUngrab, or NotifyWhileGrabbed} + +test bind-22.52 {HandleEventGenerate: options <Enter> -mode NotifyNormal} -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 %m" + event generate .t.f <Enter> -mode NotifyNormal + return $x +} -cleanup { + destroy .t.f +} -result {NotifyNormal} + +test bind-22.53 {HandleEventGenerate: options <FocusIn> -mode NotifyNormal} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <FocusIn> "lappend x %m" + event generate .t.f <FocusIn> -mode NotifyNormal + return $x +} -cleanup { + destroy .t.f +} -result {NotifyNormal} + +test bind-22.54 {HandleEventGenerate: options <Key> -mode NotifyNormal} -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 %k" + event generate .t.f <Key> -mode NotifyNormal +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-mode" option} +test bind-22.55 {HandleEventGenerate: options <Map> -override xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Map> "lappend x %o" + event generate .t.f <Map> -override xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected boolean value but got "xyz"} + +test bind-22.56 {HandleEventGenerate: options <Map> -override 1} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Map> "lappend x %o" + event generate .t.f <Map> -override 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.57 {HandleEventGenerate: options <Reparent> -override 1} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Reparent> "lappend x %o" + event generate .t.f <Reparent> -override 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.58 {HandleEventGenerate: options <Configure> -override 1} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %o" + event generate .t.f <Configure> -override 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.59 {HandleEventGenerate: options <Key> -override 1} -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 %k" + event generate .t.f <Key> -override 1 +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-override" option} + +test bind-22.60 {HandleEventGenerate: options <Circulate> -place xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Circulate> "lappend x %p" + event generate .t.f <Circulate> -place xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad -place value "xyz": must be PlaceOnTop, or PlaceOnBottom} + +test bind-22.61 {HandleEventGenerate: options <Circulate> -place PlaceOnTop} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Circulate> "lappend x %p" + event generate .t.f <Circulate> -place PlaceOnTop + return $x +} -cleanup { + destroy .t.f +} -result {PlaceOnTop} + +test bind-22.62 {HandleEventGenerate: options <Key> -place PlaceOnTop} -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 %k" + event generate .t.f <Key> -place PlaceOnTop +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-place" option} + +test bind-22.63 {HandleEventGenerate: options <Key> -root .xyz} -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 %R" + event generate .t.f <Key> -root .xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window path name ".xyz"} + +test bind-22.64 {HandleEventGenerate: options <Key> -root .t} -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 %R" + event generate .t.f <Key> -root .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.65 {HandleEventGenerate: options <Key> -root xyz} -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 %R" + event generate .t.f <Key> -root xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window name/identifier "xyz"} + +test bind-22.66 {HandleEventGenerate: options <Key> -root [winfo id .t]} -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 %R" + event generate .t.f <Key> -root [winfo id .t] + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.67 {HandleEventGenerate: options <Button> -root .t} -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 %R" + event generate .t.f <Button> -root .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.68 {HandleEventGenerate: options <ButtonRelease> -root .t} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %R" + event generate .t.f <ButtonRelease> -root .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.69 {HandleEventGenerate: options <Motion> -root .t} -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 %R" + event generate .t.f <Motion> -root .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.70 {HandleEventGenerate: options <<Paste>> -root .t} -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 %R" + event generate .t.f <<Paste>> -root .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.71 {HandleEventGenerate: options <Enter> -root .t} -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 %R" + event generate .t.f <Enter> -root .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.72 {HandleEventGenerate: options <Configure> -root .t} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %R" + event generate .t.f <Configure> -root .t +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Configure> event doesn't accept "-root" option} + +test bind-22.73 {HandleEventGenerate: options <Key> -rootx xyz} -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 %X" + event generate .t.f <Key> -rootx xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.74 {HandleEventGenerate: options <Key> -rootx 2i} -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 %X" + event generate .t.f <Key> -rootx 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.75 {HandleEventGenerate: options <Button> -rootx 2i} -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 %X" + event generate .t.f <Button> -rootx 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.76 {HandleEventGenerate: options <ButtonRelease> -rootx 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %X" + event generate .t.f <ButtonRelease> -rootx 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.77 {HandleEventGenerate: options <Motion> -rootx 2i} -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 %X" + event generate .t.f <Motion> -rootx 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.78 {HandleEventGenerate: options <<Paste>> -rootx 2i} -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 %X" + event generate .t.f <<Paste>> -rootx 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.79 {HandleEventGenerate: options <Enter> -rootx 2i} -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 %X" + event generate .t.f <Enter> -rootx 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.80 {HandleEventGenerate: options <Configure> -rootx 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %X" + event generate .t.f <Configure> -rootx 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Configure> event doesn't accept "-rootx" option} + +test bind-22.81 {HandleEventGenerate: options <Key> -rooty xyz} -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 %Y" + event generate .t.f <Key> -rooty xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.82 {HandleEventGenerate: options <Key> -rooty 2i} -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 %Y" + event generate .t.f <Key> -rooty 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.83 {HandleEventGenerate: options <Button> -rooty 2i} -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 %Y" + event generate .t.f <Button> -rooty 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.84 {HandleEventGenerate: options <ButtonRelease> -rooty 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %Y" + event generate .t.f <ButtonRelease> -rooty 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.85 {HandleEventGenerate: options <Motion> -rooty 2i} -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 %Y" + event generate .t.f <Motion> -rooty 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.86 {HandleEventGenerate: options <<Paste>> -rooty 2i} -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 %Y" + event generate .t.f <<Paste>> -rooty 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.87 {HandleEventGenerate: options <Enter> -rooty 2i} -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 %Y" + event generate .t.f <Enter> -rooty 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.88 {HandleEventGenerate: options <Configure> -rooty 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %Y" + event generate .t.f <Configure> -rooty 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Configure> event doesn't accept "-rooty" option} + +test bind-22.89 {HandleEventGenerate: options <Key> -sendevent xyz} -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 %E" + event generate .t.f <Key> -sendevent xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected boolean value but got "xyz"} + +test bind-22.90 {HandleEventGenerate: options <Key> -sendevent 1} -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 %E" + event generate .t.f <Key> -sendevent 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.91 {HandleEventGenerate: options <Key> -sendevent yes} -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 %E" + event generate .t.f <Key> -sendevent yes + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.92 {HandleEventGenerate: options <Key> -sendevent 43} -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 %E" + event generate .t.f <Key> -sendevent 43 + return $x +} -cleanup { + destroy .t.f +} -result {43} + +test bind-22.93 {HandleEventGenerate: options <Key> -serial xyz} -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 %#" + event generate .t.f <Key> -serial xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "xyz"} + +test bind-22.94 {HandleEventGenerate: options <Key> -serial 100} -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 %#" + event generate .t.f <Key> -serial 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.95 {HandleEventGenerate: options <Key> -state xyz} -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 %s" + event generate .t.f <Key> -state xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "xyz"} + +test bind-22.96 {HandleEventGenerate: options <Key> -state 1} -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 %s" + event generate .t.f <Key> -state 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.97 {HandleEventGenerate: options <Button> -state 1025} -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 %s" + event generate .t.f <Button> -state 1025 + return $x +} -cleanup { + destroy .t.f +} -result {1025} + +test bind-22.98 {HandleEventGenerate: options <ButtonRelease> -state 1025} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %s" + event generate .t.f <ButtonRelease> -state 1025 + return $x +} -cleanup { + destroy .t.f +} -result {1025} + +test bind-22.99 {HandleEventGenerate: options <Motion> -state 1} -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 %s" + event generate .t.f <Motion> -state 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.100 {HandleEventGenerate: options <<Paste>> -state 1} -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 %s" + event generate .t.f <<Paste>> -state 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.101 {HandleEventGenerate: options <Enter> -state 1} -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 %s" + event generate .t.f <Enter> -state 1 + return $x +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.102 {HandleEventGenerate: options <Visibility> -state xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Visibility> "lappend x %s" + event generate .t.f <Visibility> -state xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad -state value "xyz": must be VisibilityUnobscured, VisibilityPartiallyObscured, or VisibilityFullyObscured} + +test bind-22.103 {HandleEventGenerate: options <Visibility> -state VisibilityUnobscured} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Visibility> "lappend x %s" + event generate .t.f <Visibility> -state VisibilityUnobscured + return $x +} -cleanup { + destroy .t.f +} -result {VisibilityUnobscured} + +test bind-22.104 {HandleEventGenerate: options <Configure> -state xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %s" + event generate .t.f <Configure> -state xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Configure> event doesn't accept "-state" option} + +test bind-22.105 {HandleEventGenerate: options <Key> -subwindow .xyz} -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 %S" + event generate .t.f <Key> -subwindow .xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window path name ".xyz"} + +test bind-22.106 {HandleEventGenerate: options <Key> -subwindow .t} -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 %S" + event generate .t.f <Key> -subwindow .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.107 {HandleEventGenerate: options <Key> -subwindow xyz} -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 %S" + event generate .t.f <Key> -subwindow xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window name/identifier "xyz"} + +test bind-22.108 {HandleEventGenerate: options <Key> -subwindow [winfo id .t]} -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 %S" + event generate .t.f <Key> -subwindow [winfo id .t] + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.109 {HandleEventGenerate: options <Button> -subwindow .t} -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 %S" + event generate .t.f <Button> -subwindow .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.110 {HandleEventGenerate: options <ButtonRelease> -subwindow .t} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %S" + event generate .t.f <ButtonRelease> -subwindow .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.111 {HandleEventGenerate: options <Motion> -subwindow .t} -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 %S" + event generate .t.f <Motion> -subwindow .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.112 {HandleEventGenerate: options <<Paste>> -subwindow .t} -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 %S" + event generate .t.f <<Paste>> -subwindow .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.113 {HandleEventGenerate: options <Enter> -subwindow .t} -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 %S" + event generate .t.f <Enter> -subwindow .t + expr {[winfo id .t] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.114 {HandleEventGenerate: options <Configure> -subwindow .t} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %S" + event generate .t.f <Configure> -subwindow .t +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Configure> event doesn't accept "-subwindow" option} + +test bind-22.115 {HandleEventGenerate: options <Key> -time xyz} -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 %t" + event generate .t.f <Key> -time xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "xyz"} + +test bind-22.116 {HandleEventGenerate: options <Key> -time 100} -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 %t" + event generate .t.f <Key> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.117 {HandleEventGenerate: options <Button> -time 100} -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 %t" + event generate .t.f <Button> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.118 {HandleEventGenerate: options <ButtonRelease> -time 100} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %t" + event generate .t.f <ButtonRelease> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.119 {HandleEventGenerate: options <Motion> -time 100} -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 %t" + event generate .t.f <Motion> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.120 {HandleEventGenerate: options <<Paste>> -time 100} -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 %t" + event generate .t.f <<Paste>> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.121 {HandleEventGenerate: options <Enter> -time 100} -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 %t" + event generate .t.f <Enter> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.122 {HandleEventGenerate: options <Property> -time 100} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Property> "lappend x %t" + event generate .t.f <Property> -time 100 + return $x +} -cleanup { + destroy .t.f +} -result {100} + +test bind-22.123 {HandleEventGenerate: options <Configure> -time 100} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %t" + event generate .t.f <Configure> -time 100 +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Configure> event doesn't accept "-time" option} + +test bind-22.124 {HandleEventGenerate: options <Expose> -width xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %w" + event generate .t.f <Expose> -width xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.125 {HandleEventGenerate: options <Expose> -width 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %w" + event generate .t.f <Expose> -width 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.126 {HandleEventGenerate: options <Configure> -width 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %w" + event generate .t.f <Configure> -width 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.127 {HandleEventGenerate: options <Key> -width 2i} -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 %k" + event generate .t.f <Key> -width 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-width" option} + +test bind-22.128 {HandleEventGenerate: options <Unmap> -window .xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Unmap> "lappend x %W" + event generate .t.f <Unmap> -window .xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window path name ".xyz"} + +test bind-22.129 {HandleEventGenerate: options <Unmap> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Unmap> "lappend x %W" + event generate .t.f <Unmap> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.130 {HandleEventGenerate: options <Unmap> -window xyz} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Unmap> "lappend x %W" + event generate .t.f <Unmap> -window xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad window name/identifier "xyz"} + +test bind-22.131 {HandleEventGenerate: options <Unmap> -window [winfo id .t.f]} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Unmap> "lappend x %W" + event generate .t.f <Unmap> -window [winfo id .t.f] + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.132 {HandleEventGenerate: options <Unmap> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Unmap> "lappend x %W" + event generate .t.f <Unmap> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.133 {HandleEventGenerate: options <Map> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Map> "lappend x %W" + event generate .t.f <Map> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.134 {HandleEventGenerate: options <Reparent> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Reparent> "lappend x %W" + event generate .t.f <Reparent> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.135 {HandleEventGenerate: options <Configure> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %W" + event generate .t.f <Configure> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.136 {HandleEventGenerate: options <Gravity> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Gravity> "lappend x %W" + event generate .t.f <Gravity> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.137 {HandleEventGenerate: options <Circulate> -window .t.f} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Circulate> "lappend x %W" + event generate .t.f <Circulate> -window .t.f + return $x +} -cleanup { + destroy .t.f +} -result {.t.f} + +test bind-22.138 {HandleEventGenerate: options <Key> -window .t.f} -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 %W" + event generate .t.f <Key> -window .t.f +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Key> event doesn't accept "-window" option} + +test bind-22.139 {HandleEventGenerate: options <Key> -x xyz} -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 %x" + event generate .t.f <Key> -x xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.140 {HandleEventGenerate: options <Key> -x 2i} -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 %x" + event generate .t.f <Key> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.141 {HandleEventGenerate: options <Button> -x 2i} -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 %x" + event generate .t.f <Button> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.142 {HandleEventGenerate: options <ButtonRelease> -x 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %x" + event generate .t.f <ButtonRelease> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.143 {HandleEventGenerate: options <Motion> -x 2i} -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 %x" + event generate .t.f <Motion> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.144 {HandleEventGenerate: options <<Paste>> -x 2i} -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 %x" + event generate .t.f <<Paste>> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.145 {HandleEventGenerate: options <Enter> -x 2i} -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 %x" + event generate .t.f <Enter> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.146 {HandleEventGenerate: options <Expose> -x 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %x" + event generate .t.f <Expose> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.147 {HandleEventGenerate: options <Configure> -x 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %x" + event generate .t.f <Configure> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.148 {HandleEventGenerate: options <Gravity> -x 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Gravity> "lappend x %x" + event generate .t.f <Gravity> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.149 {HandleEventGenerate: options <Reparent> -x 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Reparent> "lappend x %x" + event generate .t.f <Reparent> -x 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.150 {HandleEventGenerate: options <Map> -x 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Map> "lappend x %x" + event generate .t.f <Map> -x 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Map> event doesn't accept "-x" option} + +test bind-22.151 {HandleEventGenerate: options <Key> -y xyz} -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 %y" + event generate .t.f <Key> -y xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad screen distance "xyz"} + +test bind-22.152 {HandleEventGenerate: options <Key> -y 2i} -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 %y" + event generate .t.f <Key> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.153 {HandleEventGenerate: options <Button> -y 2i} -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 %y" + event generate .t.f <Button> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.154 {HandleEventGenerate: options <ButtonRelease> -y 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <ButtonRelease> "lappend x %y" + event generate .t.f <ButtonRelease> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.155 {HandleEventGenerate: options <Motion> -y 2i} -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 %y" + event generate .t.f <Motion> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.156 {HandleEventGenerate: options <<Paste>> -y 2i} -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 %y" + event generate .t.f <<Paste>> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.157 {HandleEventGenerate: options <Enter> -y 2i} -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 %y" + event generate .t.f <Enter> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.158 {HandleEventGenerate: options <Expose> -y 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Expose> "lappend x %y" + event generate .t.f <Expose> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.159 {HandleEventGenerate: options <Configure> -y 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Configure> "lappend x %y" + event generate .t.f <Configure> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.160 {HandleEventGenerate: options <Gravity> -y 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Gravity> "lappend x %y" + event generate .t.f <Gravity> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.161 {HandleEventGenerate: options <Reparent> -y 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Reparent> "lappend x %y" + event generate .t.f <Reparent> -y 2i + expr {[winfo pixels .t.f 2i] eq $x} +} -cleanup { + destroy .t.f +} -result {1} + +test bind-22.162 {HandleEventGenerate: options <Map> -y 2i} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update + set x {} +} -body { + bind .t.f <Map> "lappend x %y" + event generate .t.f <Map> -y 2i +} -cleanup { + destroy .t.f +} -returnCodes error -result {<Map> event doesn't accept "-y" option} + +test bind-22.163 {HandleEventGenerate: options <Key> -xyz 1} -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 %k" + event generate .t.f <Key> -xyz 1 +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad option "-xyz": must be -when, -above, -borderwidth, -button, -count, -data, -delta, -detail, -focus, -height, -keycode, -keysym, -mode, -override, -place, -root, -rootx, -rooty, -sendevent, -serial, -state, -subwindow, -time, -warp, -width, -window, -x, or -y} # Note that the -data option is tested in bind-32.* because it has # more demanding requirements in memory handling -test bind-23.1 {GetVirtualEventUid procedure} { - list [catch {event info <<asd} msg] $msg -} {1 {virtual event "<<asd" is badly formed}} -test bind-23.2 {GetVirtualEventUid procedure} { - list [catch {event info <<>>} msg] $msg -} {1 {virtual event "<<>>" is badly formed}} -test bind-23.3 {GetVirtualEventUid procedure} { - list [catch {event info <<asd>} msg] $msg -} {1 {virtual event "<<asd>" is badly formed}} -test bind-23.4 {GetVirtualEventUid procedure} { + +test bind-23.1 {GetVirtualEventUid procedure} -body { + event info <<asd +} -returnCodes error -result {virtual event "<<asd" is badly formed} +test bind-23.2 {GetVirtualEventUid procedure} -body { + event info <<>> +} -returnCodes error -result {virtual event "<<>>" is badly formed} +test bind-23.3 {GetVirtualEventUid procedure} -body { + event info <<asd> +} -returnCodes error -result {virtual event "<<asd>" is badly formed} +test bind-23.4 {GetVirtualEventUid procedure} -setup { + event delete <<asd>> +} -body { event info <<asd>> -} {} - - -test bind-24.1 {FindSequence procedure: no event} { - list [catch {bind .b {} test} msg] $msg -} {1 {no events specified in binding}} -test bind-24.2 {FindSequence procedure: bad event} { - list [catch {bind .b <xyz> test} msg] $msg -} {1 {bad event type or keysym "xyz"}} -test bind-24.3 {FindSequence procedure: virtual allowed} { - bind .b.f <<Paste>> test -} {} -test bind-24.4 {FindSequence procedure: virtual not allowed} { - list [catch {event add <<Paste>> <<Alive>>} msg] $msg -} {1 {virtual event not allowed in definition of another virtual event}} -test bind-24.5 {FindSequence procedure, multiple bindings} { - setup - bind .b.f <1> {lappend x single} - bind .b.f <Double-1> {lappend x double} - bind .b.f <Triple-1> {lappend x triple} - bind .b.f <Quadruple-1> {lappend x quadruple} +} -result {} + + +test bind-24.1 {FindSequence procedure: no event} -body { + bind .t {} test +} -returnCodes error -result {no events specified in binding} +test bind-24.2 {FindSequence procedure: bad event} -body { + bind .t <xyz> test +} -returnCodes error -result {bad event type or keysym "xyz"} +test bind-24.3 {FindSequence procedure: virtual allowed} -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>> test +} -cleanup { + destroy .t.f +} -result {} +test bind-24.4 {FindSequence procedure: virtual not allowed} -body { + event add <<Paste>> <<Alive>> +} -returnCodes error -result {virtual event not allowed in definition of another virtual event} +test bind-24.5 {FindSequence procedure, multiple bindings} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <1> {lappend x single} + bind .t.f <Double-1> {lappend x double} + bind .t.f <Triple-1> {lappend x triple} + bind .t.f <Quadruple-1> {lappend x quadruple} set x press - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> lappend x press - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> lappend x press - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> lappend x press - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> lappend x press - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - set x -} {press single press double press triple press quadruple press quadruple} -test bind-24.6 {FindSequence procedure: virtual composed} { - list [catch {bind .b <Control-b><<Paste>> "puts hi"} msg] $msg -} {1 {virtual events may not be composed}} -test bind-24.7 {FindSequence procedure: new pattern sequence} { - setup - bind .b.f <Button-1><Button-2> {lappend x 1-2} - set x {} - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - set x -} {1-2} -test bind-24.8 {FindSequence procedure: similar pattern sequence} { - setup - bind .b.f <Button-1><Button-2> {lappend x 1-2} - bind .b.f <Button-2> {lappend x 2} - set x {} - event gen .b.f <Button-3> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - set x -} {2 1-2} -test bind-24.9 {FindSequence procedure: similar pattern sequence} { - setup - bind .b.f <Button-1><Button-2> {lappend x 1-2} - bind .b.f <Button-2><Button-2> {lappend x 2-2} - set x {} - event gen .b.f <Button-3> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - set x -} {2-2 1-2} -test bind-24.10 {FindSequence procedure: similar pattern sequence} { - setup - bind .b.f <Button-2><Button-2> {lappend x 2-2} - bind .b.f <Double-Button-2> {lappend x d-2} - set x {} - event gen .b.f <Button-3> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - event gen .b.f <Button-2> -x 100 - event gen .b.f <ButtonRelease-2> - event gen .b.f <Button-2> -x 200 - event gen .b.f <ButtonRelease-2> - set x -} {d-2 2-2} -test bind-24.11 {FindSequence procedure: new sequence, don't create} { - setup - bind .b.f <Button-2> -} {} -test bind-24.12 {FindSequence procedure: not new sequence, don't create} { - setup - bind .b.f <Control-Button-2> "foo" - bind .b.f <Button-2> -} {} -test bind-24.13 {FindSequence procedure: no binding} { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 - list [catch {bind .b.f <a>} msg] $msg -} {0 {}} -test bind-24.14 {FindSequence procedure: no binding} { - catch {destroy .b.f} - canvas .b.f - set i [.b.f create rect 10 10 100 100] - list [catch {.b.f bind $i <a>} msg] $msg -} {0 {}} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + set x +} -cleanup { + destroy .t.f +} -result {press single press double press triple press quadruple press quadruple} +test bind-24.6 {FindSequence procedure: virtual composed} -body { + bind .t <Control-b><<Paste>> "puts hi" +} -returnCodes error -result {virtual events may not be composed} +test bind-24.7 {FindSequence procedure: new pattern sequence} -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><Button-2> {lappend x 1-2} + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + set x +} -cleanup { + destroy .t.f +} -result {1-2} +test bind-24.8 {FindSequence procedure: similar pattern sequence} -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><Button-2> {lappend x 1-2} + bind .t.f <Button-2> {lappend x 2} + event generate .t.f <Button-3> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + set x +} -cleanup { + destroy .t.f +} -result {2 1-2} +test bind-24.9 {FindSequence procedure: similar pattern sequence} -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><Button-2> {lappend x 1-2} + bind .t.f <Button-2><Button-2> {lappend x 2-2} + event generate .t.f <Button-3> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + set x +} -cleanup { + destroy .t.f +} -result {2-2 1-2} +test bind-24.10 {FindSequence procedure: similar pattern sequence} -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><Button-2> {lappend x 2-2} + bind .t.f <Double-Button-2> {lappend x d-2} + event generate .t.f <Button-3> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + event generate .t.f <Button-2> -x 100 + event generate .t.f <ButtonRelease-2> + event generate .t.f <Button-2> -x 200 + event generate .t.f <ButtonRelease-2> + set x +} -cleanup { + destroy .t.f +} -result {d-2 2-2} +test bind-24.11 {FindSequence procedure: new sequence, don't create} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-2> +} -cleanup { + destroy .t.f +} -result {} +test bind-24.12 {FindSequence procedure: not new sequence, don't create} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Control-Button-2> "foo" + bind .t.f <Button-2> +} -cleanup { + destroy .t.f +} -result {} +test bind-24.13 {FindSequence procedure: no binding} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <a> +} -cleanup { + destroy .t.f +} -returnCodes ok +test bind-24.14 {FindSequence procedure: no binding} -body { + canvas .t.c + set i [.t.c create rect 10 10 100 100] + .t.c bind $i <a> +} -cleanup { + destroy .t.c +} -returnCodes ok test bind-25.1 {ParseEventDescription procedure} -setup { - setup + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update } -body { - bind .b.f a test - bind .b.f a + bind .t.f a test + bind .t.f a +} -cleanup { + destroy .t.f } -result test test bind-25.2 {ParseEventDescription procedure: misinterpreted modifier} -setup { - button .x + button .b } -body { - bind .x <Control-M> a - bind .x <M-M> b - lsort [bind .x] + bind .b <Control-M> a + bind .b <M-M> b + lsort [bind .b] } -cleanup { - destroy .x + destroy .b } -result {<Control-Key-M> <Meta-Key-M>} test bind-25.3 {ParseEventDescription procedure} -setup { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 + frame .t.f -class Test -width 150 -height 100 } -body { - bind .b.f <a---> {nothing} - bind .b.f + bind .t.f <a---> {nothing} + bind .t.f +} -cleanup { + destroy .t.f } -result a -test bind-25.4 {ParseEventDescription} -setup { - setup -} -body { - bind .b <<Shift-Paste>> {puts hi} - bind .b +test bind-25.4 {ParseEventDescription} -body { + bind .t <<Shift-Paste>> {puts hi} + bind .t } -result {<<Shift-Paste>>} + # Assorted error cases in event sequence parsing -foreach {testname testinfo} { - bind-25.5 {\x7 {bad ASCII character 0x7}} - bind-25.6 {\x7f {bad ASCII character 0x7f}} - bind-25.7 {\x4 {bad ASCII character 0x4}} - bind-25.8 {<<>> {virtual event "<<>>" is badly formed}} - bind-25.9 {<<Paste {missing ">" in virtual binding}} - bind-25.10 {<<Paste> {missing ">" in virtual binding}} - bind-25.11 {<<Paste>>h {virtual events may not be composed}} - bind-25.12 {<> "no event type or button # or keysym"} - bind-25.13 {<a-- {missing ">" in binding}} - bind-25.14 {<a-b> {extra characters after detail in binding}} - bind-25.15 {<<abc {missing ">" in virtual binding}} - bind-25.16 {<<abc> {missing ">" in virtual binding}} -} { - lassign $testinfo sequence errorMessage - test $testname {ParseEventDescription procedure error cases} \ - -setup { setup } \ - -body [list bind .b $sequence {puts hi}] \ - -returnCodes error -result $errorMessage -} -test bind-25.17 {ParseEventDescription} -setup { - setup -} -returnCodes error -body { +test bind-25.5 {ParseEventDescription procedure error cases} -body { + bind .t \x7 {puts hi} +} -returnCodes error -result {bad ASCII character 0x7} +test bind-25.6 {ParseEventDescription procedure error cases} -body { + bind .t \x7f {puts hi} +} -returnCodes error -result {bad ASCII character 0x7f} +test bind-25.7 {ParseEventDescription procedure error cases} -body { + bind .t \x4 {puts hi} +} -returnCodes error -result {bad ASCII character 0x4} +test bind-25.8 {ParseEventDescription procedure error cases} -body { + bind .t <<>> {puts hi} +} -returnCodes error -result {virtual event "<<>>" is badly formed} +test bind-25.9 {ParseEventDescription procedure error cases} -body { + bind .t <<Paste {puts hi} +} -returnCodes error -result {missing ">" in virtual binding} +test bind-25.10 {ParseEventDescription procedure error cases} -body { + bind .t <<Paste> {puts hi} +} -returnCodes error -result {missing ">" in virtual binding} +test bind-25.11 {ParseEventDescription procedure error cases} -body { + bind .t <<Paste>>h {puts hi} +} -returnCodes error -result {virtual events may not be composed} +test bind-25.12 {ParseEventDescription procedure error cases} -body { + bind .t <> {puts hi} +} -returnCodes error -result {no event type or button # or keysym} +test bind-25.13 {ParseEventDescription procedure error cases} -body { + bind .t <a-- {puts hi} +} -returnCodes error -result {missing ">" in binding} +test bind-25.14 {ParseEventDescription procedure error cases} -body { + bind .t <a-b> {puts hi} +} -returnCodes error -result {extra characters after detail in binding} +test bind-25.15 {ParseEventDescription procedure error cases} -body { + bind .t <<abc {puts hi} +} -returnCodes error -result {missing ">" in virtual binding} +test bind-25.16 {ParseEventDescription procedure error cases} -body { + bind .t <<abc> {puts hi} +} -returnCodes error -result {missing ">" in virtual binding} +test bind-25.17 {ParseEventDescription} -body { event add <<xyz>> <<abc>> -} -result {virtual event not allowed in definition of another virtual event} +} -returnCodes error -result {virtual event not allowed in definition of another virtual event} + # Modifier canonicalization tests -foreach {name check} { - bind-25.18 {{<Control- a>} <Control-Key-a>} - bind-25.19 {<Shift-a> <Shift-Key-a>} - bind-25.20 {<Lock-a> <Lock-Key-a>} - bind-25.21 {<Meta---a> <Meta-Key-a>} - bind-25.22 {<M-a> <Meta-Key-a>} - bind-25.23 {<Alt-a> <Alt-Key-a>} - bind-25.24 {<B1-a> <B1-Key-a>} - bind-25.25 {<B2-a> <B2-Key-a>} - bind-25.26 {<B3-a> <B3-Key-a>} - bind-25.27 {<B4-a> <B4-Key-a>} - bind-25.28 {<B5-a> <B5-Key-a>} - bind-25.29 {<Button1-a> <B1-Key-a>} - bind-25.30 {<Button2-a> <B2-Key-a>} - bind-25.31 {<Button3-a> <B3-Key-a>} - bind-25.32 {<Button4-a> <B4-Key-a>} - bind-25.33 {<Button5-a> <B5-Key-a>} - bind-25.34 {<M1-a> <Mod1-Key-a>} - bind-25.35 {<M2-a> <Mod2-Key-a>} - bind-25.36 {<M3-a> <Mod3-Key-a>} - bind-25.37 {<M4-a> <Mod4-Key-a>} - bind-25.38 {<M5-a> <Mod5-Key-a>} - bind-25.39 {<Mod1-a> <Mod1-Key-a>} - bind-25.40 {<Mod2-a> <Mod2-Key-a>} - bind-25.41 {<Mod3-a> <Mod3-Key-a>} - bind-25.42 {<Mod4-a> <Mod4-Key-a>} - bind-25.43 {<Mod5-a> <Mod5-Key-a>} - bind-25.44 {<Double-a> <Double-Key-a>} - bind-25.45 {<Triple-a> <Triple-Key-a>} - bind-25.46 {{<Double 1>} <Double-Button-1>} - bind-25.47 {<Triple-1> <Triple-Button-1>} - bind-25.48 {{<M1-M2 M3-M4 B1-Control-a>} - <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a>} - bind-25.49 {<Extended-Return> <Extended-Key-Return>} -} { - lassign $check shortBind longBind - test $name {modifier names} -setup { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 - } -body { - bind .b.f $shortBind foo - bind .b.f - } -result $longBind -cleanup { - bind .b.f [lindex $check 1] {} - } -} -foreach event [bind Test] { - bind Test $event {} -} -foreach event [bind all] { - bind all $event {} -} -test bind-26.1 {event names} { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 - bind .b.f <FocusIn> {nothing} - bind .b.f -} <FocusIn> -test bind-26.2 {event names} { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 - bind .b.f <FocusOut> {nothing} - bind .b.f -} <FocusOut> -test bind-26.3 {event names} { - setup - bind .b.f <Destroy> {lappend x "destroyed"} - set x [bind .b.f] - destroy .b.f - set x -} {<Destroy> destroyed} -foreach check { - {bind-26.4 Motion Motion} - {bind-26.5 Button Button} - {bind-26.6 ButtonPress Button} - {bind-26.7 ButtonRelease ButtonRelease} - {bind-26.8 Colormap Colormap} - {bind-26.9 Enter Enter} - {bind-26.10 Leave Leave} - {bind-26.11 Expose Expose} - {bind-26.12 Key Key} - {bind-26.13 KeyPress Key} - {bind-26.14 KeyRelease KeyRelease} - {bind-26.15 Property Property} - {bind-26.16 Visibility Visibility} - {bind-26.17 Activate Activate} - {bind-26.18 Deactivate Deactivate} -} { - lassign $check name event canonicalEvent - test $name "event names: $event" { - setup - bind .b.f <$event> "set x {event $event}" +test bind-25.18 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f {<Control- a>} foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Control-Key-a> + +test bind-25.19 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Shift-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Shift-Key-a> + +test bind-25.20 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Lock-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Lock-Key-a> + +test bind-25.21 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Meta---a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Meta-Key-a> + +test bind-25.22 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <M-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Meta-Key-a> + +test bind-25.23 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Alt-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Alt-Key-a> + +test bind-25.24 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <B1-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B1-Key-a> + +test bind-25.25 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <B2-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B2-Key-a> + +test bind-25.26 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <B3-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B3-Key-a> + +test bind-25.27 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <B4-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B4-Key-a> + +test bind-25.28 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <B5-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B5-Key-a> + +test bind-25.29 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button1-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B1-Key-a> + +test bind-25.30 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button2-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B2-Key-a> + +test bind-25.31 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button3-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B3-Key-a> + +test bind-25.32 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button4-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B4-Key-a> + +test bind-25.33 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Button5-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <B5-Key-a> + +test bind-25.34 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <M1-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod1-Key-a> + +test bind-25.35 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <M2-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod2-Key-a> + +test bind-25.36 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <M3-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod3-Key-a> + +test bind-25.37 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <M4-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod4-Key-a> + +test bind-25.38 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <M5-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod5-Key-a> + +test bind-25.39 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Mod1-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod1-Key-a> + +test bind-25.40 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Mod2-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod2-Key-a> + +test bind-25.41 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Mod3-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod3-Key-a> + +test bind-25.42 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Mod4-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod4-Key-a> + +test bind-25.43 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Mod5-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Mod5-Key-a> + +test bind-25.44 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Double-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Double-Key-a> + +test bind-25.45 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Triple-a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Triple-Key-a> + +test bind-25.46 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f {<Double 1>} foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Double-Button-1> + +test bind-25.47 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Triple-1> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Triple-Button-1> + +test bind-25.48 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f {<M1-M2 M3-M4 B1-Control-a>} foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Control-B1-Mod1-Mod2-Mod3-Mod4-Key-a> + +test bind-25.49 {modifier names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <Extended-Return> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result <Extended-Key-Return> + + + +test bind-26.1 {event names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <FocusIn> {nothing} + bind .t.f +} -cleanup { + destroy .t.f +} -result <FocusIn> +test bind-26.2 {event names} -setup { + frame .t.f -class Test -width 150 -height 100 +} -body { + bind .t.f <FocusOut> {nothing} + bind .t.f +} -cleanup { + destroy .t.f +} -result <FocusOut> +test bind-26.3 {event names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Destroy> {lappend x "destroyed"} + set x [bind .t.f] + destroy .t.f + set x +} -cleanup { + destroy .t.f +} -result {<Destroy> destroyed} + +test bind-26.4 {event names: Motion} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Motion> "set x {event Motion}" set x xyzzy - event gen .b.f <$event> - list $x [bind .b.f] - } [list "event $event" <$canonicalEvent>] -} + event generate .t.f <Motion> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Motion} <Motion>} + +test bind-26.5 {event names: Button} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> "set x {event Button}" + set x xyzzy + event generate .t.f <Button> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Button} <Button>} + +test bind-26.6 {event names: ButtonPress} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <ButtonPress> "set x {event ButtonPress}" + set x xyzzy + event generate .t.f <ButtonPress> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event ButtonPress} <Button>} + +test bind-26.7 {event names: ButtonRelease} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <ButtonRelease> "set x {event ButtonRelease}" + set x xyzzy + event generate .t.f <ButtonRelease> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event ButtonRelease} <ButtonRelease>} + +test bind-26.8 {event names: Colormap} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Colormap> "set x {event Colormap}" + set x xyzzy + event generate .t.f <Colormap> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Colormap} <Colormap>} + +test bind-26.9 {event names: Enter} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Enter> "set x {event Enter}" + set x xyzzy + event generate .t.f <Enter> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Enter} <Enter>} + +test bind-26.10 {event names: Leave} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Leave> "set x {event Leave}" + set x xyzzy + event generate .t.f <Leave> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Leave} <Leave>} + +test bind-26.11 {event names: Expose} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Expose> "set x {event Expose}" + set x xyzzy + event generate .t.f <Expose> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Expose} <Expose>} + +test bind-26.12 {event names: Key} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key> "set x {event Key}" + set x xyzzy + event generate .t.f <Key> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Key} <Key>} + +test bind-26.13 {event names: KeyPress} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <KeyPress> "set x {event KeyPress}" + set x xyzzy + event generate .t.f <KeyPress> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event KeyPress} <Key>} + +test bind-26.14 {event names: KeyRelease} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <KeyRelease> "set x {event KeyRelease}" + set x xyzzy + event generate .t.f <KeyRelease> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event KeyRelease} <KeyRelease>} + +test bind-26.15 {event names: Property} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Property> "set x {event Property}" + set x xyzzy + event generate .t.f <Property> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Property} <Property>} + +test bind-26.16 {event names: Visibility} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Visibility> "set x {event Visibility}" + set x xyzzy + event generate .t.f <Visibility> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Visibility} <Visibility>} + +test bind-26.17 {event names: Activate} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Activate> "set x {event Activate}" + set x xyzzy + event generate .t.f <Activate> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Activate} <Activate>} + +test bind-26.18 {event names: Deactivate} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Deactivate> "set x {event Deactivate}" + set x xyzzy + event generate .t.f <Deactivate> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Deactivate} <Deactivate>} + + # These events require an extra argument to [event generate] -foreach check { - {bind-26.19 Circulate Circulate} - {bind-26.20 Configure Configure} - {bind-26.21 Gravity Gravity} - {bind-26.22 Map Map} - {bind-26.23 Reparent Reparent} - {bind-26.24 Unmap Unmap} -} { - lassign $check name event canonicalEvent - test $name "event names: $event" { - setup - bind .b.f <$event> "set x {event $event}" +test bind-26.19 {event names: Circulate} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Circulate> "set x {event Circulate}" set x xyzzy - event gen .b.f <$event> -window .b.f - list $x [bind .b.f] - } [list "event $event" <$canonicalEvent>] -} + event generate .t.f <Circulate> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Circulate} <Circulate>} -test bind-27.1 {button names} { - list [catch {bind .b <Expose-1> foo} msg] $msg -} {1 {specified button "1" for non-button event}} -test bind-27.2 {button names} { - list [catch {bind .b <Button-6> foo} msg] $msg -} {1 {specified keysym "6" for non-key event}} -test bind-27.3 {button names} { - setup - bind .b.f <Button-1> {lappend x "button 1"} - set x [bind .b.f] - event gen .b.f <Button-1> - event gen .b.f <ButtonRelease-1> - set x -} {<Button-1> {button 1}} -test bind-27.4 {button names} { - setup - bind .b.f <Button-2> {lappend x "button 2"} - set x [bind .b.f] - event gen .b.f <Button-2> - event gen .b.f <ButtonRelease-2> - set x -} {<Button-2> {button 2}} -test bind-27.5 {button names} { - setup - bind .b.f <Button-3> {lappend x "button 3"} - set x [bind .b.f] - event gen .b.f <Button-3> - event gen .b.f <ButtonRelease-3> - set x -} {<Button-3> {button 3}} -test bind-27.6 {button names} { - setup - bind .b.f <Button-4> {lappend x "button 4"} - set x [bind .b.f] - event gen .b.f <Button-4> - event gen .b.f <ButtonRelease-4> - set x -} {<Button-4> {button 4}} -test bind-27.7 {button names} { - setup - bind .b.f <Button-5> {lappend x "button 5"} - set x [bind .b.f] - event gen .b.f <Button-5> - event gen .b.f <ButtonRelease-5> - set x -} {<Button-5> {button 5}} - -test bind-28.1 {keysym names} { - list [catch {bind .b <Expose-a> foo} msg] $msg -} {1 {specified keysym "a" for non-key event}} -test bind-28.2 {keysym names} { - list [catch {bind .b <Gorp> foo} msg] $msg -} {1 {bad event type or keysym "Gorp"}} -test bind-28.3 {keysym names} { - list [catch {bind .b <Key-Stupid> foo} msg] $msg -} {1 {bad event type or keysym "Stupid"}} -test bind-28.4 {keysym names} { - catch {destroy .b.f} - frame .b.f -class Test -width 150 -height 100 - bind .b.f <a> foo - bind .b.f -} a -foreach check { - {bind-28.5 a 0 a} - {bind-28.6 space 0 <Key-space>} - {bind-28.7 Return 0 <Key-Return>} - {bind-28.8 X 1 X} -} { - lassign $check name keysym state result - test $name {keysym names} { - setup - bind .b.f <Key-$keysym> "lappend x \"keysym $keysym\"" - bind .b.f <Key-x> "lappend x {bad binding match}" - set x [lsort [bind .b.f]] - event gen .b.f <Key-$keysym> -state $state - set x - } [concat [lsort "x $result"] "{keysym $keysym}"] -} +test bind-26.20 {event names: Configure} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Configure> "set x {event Configure}" + set x xyzzy + event generate .t.f <Configure> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Configure} <Configure>} -test bind-29.1 {dummy test to help ensure proper numbering} {} {} -setup -bind .b.f <KeyPress> {set x %K} -foreach check { - {bind-29.2 a 0 a} - {bind-29.3 x 1 X} - {bind-29.4 x 2 X} - {bind-29.5 space 0 space} - {bind-29.6 F1 1 F1} -} { - lassign $check name keysym state result - test $name {GetKeySym procedure} nonPortable { - set x nothing - event gen .b.f <KeyPress> -keysym $keysym -state $state - set x - } $result -} +test bind-26.21 {event names: Gravity} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Gravity> "set x {event Gravity}" + set x xyzzy + event generate .t.f <Gravity> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Gravity} <Gravity>} -proc bgerror msg { - global x errorInfo - set x [list $msg $errorInfo] -} -test bind-30.1 {Tk_BackgroundError procedure} { - setup - bind .b.f <Button> {error "This is a test"} +test bind-26.22 {event names: Map} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Map> "set x {event Map}" + set x xyzzy + event generate .t.f <Map> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Map} <Map>} + +test bind-26.23 {event names: Reparent} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Reparent> "set x {event Reparent}" + set x xyzzy + event generate .t.f <Reparent> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Reparent} <Reparent>} + +test bind-26.24 {event names: Unmap} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Unmap> "set x {event Unmap}" + set x xyzzy + event generate .t.f <Unmap> + list $x [bind .t.f] +} -cleanup { + destroy .t.f +} -result {{event Unmap} <Unmap>} + + +test bind-27.1 {button names} -body { + bind .t <Expose-1> foo +} -returnCodes error -result {specified button "1" for non-button event} +test bind-27.2 {button names} -body { + bind .t <Button-6> foo +} -returnCodes error -result {specified keysym "6" for non-key event} +test bind-27.3 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-1> {lappend x "button 1"} + set x [bind .t.f] + event generate .t.f <Button-1> + event generate .t.f <ButtonRelease-1> + set x +} -cleanup { + destroy .t.f +} -result {<Button-1> {button 1}} +test bind-27.4 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-2> {lappend x "button 2"} + set x [bind .t.f] + event generate .t.f <Button-2> + event generate .t.f <ButtonRelease-2> + set x +} -cleanup { + destroy .t.f +} -result {<Button-2> {button 2}} +test bind-27.5 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-3> {lappend x "button 3"} + set x [bind .t.f] + event generate .t.f <Button-3> + event generate .t.f <ButtonRelease-3> + set x +} -cleanup { + destroy .t.f +} -result {<Button-3> {button 3}} +test bind-27.6 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-4> {lappend x "button 4"} + set x [bind .t.f] + event generate .t.f <Button-4> + event generate .t.f <ButtonRelease-4> + set x +} -cleanup { + destroy .t.f +} -result {<Button-4> {button 4}} +test bind-27.7 {button names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button-5> {lappend x "button 5"} + set x [bind .t.f] + event generate .t.f <Button-5> + event generate .t.f <ButtonRelease-5> + set x +} -cleanup { + destroy .t.f +} -result {<Button-5> {button 5}} + +test bind-28.1 {keysym names} -body { + bind .t <Expose-a> foo +} -returnCodes error -result {specified keysym "a" for non-key event} +test bind-28.2 {keysym names} -body { + bind .t <Gorp> foo +} -returnCodes error -result {bad event type or keysym "Gorp"} +test bind-28.3 {keysym names} -body { + bind .t <Key-Stupid> foo +} -returnCodes error -result {bad event type or keysym "Stupid"} +test bind-28.4 {keysym names} -body { + frame .t.f -class Test -width 150 -height 100 + bind .t.f <a> foo + bind .t.f +} -cleanup { + destroy .t.f +} -result {a} + +test bind-28.5 {keysym names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key-colon> "lappend x \"keysym received\"" + bind .t.f <Key-underscore> "lappend x {bad binding match}" + set x [lsort [bind .t.f]] + event generate .t.f <Key-colon> ;# -state 0 + set x +} -cleanup { + destroy .t.f +} -result {: _ {keysym received}} +test bind-28.6 {keysym names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key-Return> "lappend x \"keysym Return\"" + bind .t.f <Key-x> "lappend x {bad binding match}" + set x [lsort [bind .t.f]] + event generate .t.f <Key-Return> -state 0 + set x +} -cleanup { + destroy .t.f +} -result {<Key-Return> x {keysym Return}} +test bind-28.7 {keysym names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key-X> "lappend x \"keysym X\"" + bind .t.f <Key-x> "lappend x {bad binding match}" + set x [lsort [bind .t.f]] + event generate .t.f <Key-X> -state 1 + set x +} -cleanup { + destroy .t.f +} -result {X x {keysym X}} +test bind-28.8 {keysym names} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Key-X> "lappend x \"keysym X\"" + bind .t.f <Key-x> "lappend x {bad binding match}" + set x [lsort [bind .t.f]] + event generate .t.f <Key-X> -state 1 + set x +} -cleanup { + destroy .t.f +} -result {X x {keysym X}} + + +test bind-29.1 {Tk_BackgroundError procedure} -setup { + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> {error "This is a test"} set x none - event gen .b.f <Button> - event gen .b.f <ButtonRelease> + event generate .t.f <Button> + event generate .t.f <ButtonRelease> update set x -} {{This is a test} {This is a test +} -cleanup { + destroy .t.f + rename bgerror {} +} -result {{This is a test} {This is a test while executing "error "This is a test"" (command bound to event)}} -test bind-30.2 {Tk_BackgroundError procedure} { + +test bind-29.2 {Tk_BackgroundError procedure} -setup { proc do {} { - event gen .b.f <Button> - event gen .b.f <ButtonRelease> + event generate .t.f <Button> + event generate .t.f <ButtonRelease> } - setup - bind .b.f <Button> {error Message2} + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] + } + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { + bind .t.f <Button> {error Message2} set x none do update set x -} {Message2 {Message2 +} -cleanup { + destroy .t.f + rename bgerror {} + rename do {} +} -result {Message2 {Message2 while executing "error Message2" (command bound to event)}} -rename bgerror {} -test bind-31.1 {MouseWheel events} { - setup + +test bind-30.1 {MouseWheel events} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <MouseWheel> {set x Wheel} - event gen .b.f <MouseWheel> +} -body { + bind .t.f <MouseWheel> {set x Wheel} + event generate .t.f <MouseWheel> set x -} {Wheel} -test bind-31.2 {MouseWheel events} { - setup +} -cleanup { + destroy .t.f +} -result {Wheel} +test bind-30.2 {MouseWheel events} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <MouseWheel> {set x %D} - event gen .b.f <MouseWheel> -delta 120 +} -body { + bind .t.f <MouseWheel> {set x %D} + event generate .t.f <MouseWheel> -delta 120 set x -} {120} -test bind-31.3 {MouseWheel events} { - setup +} -cleanup { + destroy .t.f +} -result {120} +test bind-30.3 {MouseWheel events} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <MouseWheel> {set x "%D %x %y"} - event gen .b.f <MouseWheel> -delta 240 -x 10 -y 30 +} -body { + bind .t.f <MouseWheel> {set x "%D %x %y"} + event generate .t.f <MouseWheel> -delta 240 -x 10 -y 30 set x -} {240 10 30} +} -cleanup { + destroy .t.f +} -result {240 10 30} + -test bind-32.1 {virtual event user_data field - bad generation} { - setup - # Check no confusion, since Focus events use %d for something else - list [catch {event gen .b.f <FocusIn> -data foo} msg] $msg -} {1 {<FocusIn> event doesn't accept "-data" option}} -test bind-32.2 {virtual event user_data field - NULL, synch} { - setup +test bind-31.1 {virtual event user_data field - bad generation} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update +} -body { +# Check no confusion, since Focus events use %d for something else + event generate .t.f <FocusIn> -data foo +} -cleanup { + destroy .t.f +} -returnCodes error -result {<FocusIn> event doesn't accept "-data" option} +test bind-31.2 {virtual event user_data field - NULL, synch} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} - event gen .b.f <<TestUserData>> +} -body { + bind .t.f <<TestUserData>> {set x "TestUserData >%d<"} + event generate .t.f <<TestUserData>> set x -} {TestUserData >{}<} -test bind-32.3 {virtual event user_data field - shared, synch} { - setup +} -cleanup { + destroy .t.f +} -result {TestUserData >{}<} +test bind-31.3 {virtual event user_data field - shared, synch} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} - event gen .b.f <<TestUserData>> -data "foo bar" +} -body { + bind .t.f <<TestUserData>> {set x "TestUserData >%d<"} + event generate .t.f <<TestUserData>> -data "foo bar" set x -} {TestUserData >foo bar<} -test bind-32.4 {virtual event user_data field - unshared, synch} { - setup +} -cleanup { + destroy .t.f +} -result {TestUserData >foo bar<} +test bind-31.4 {virtual event user_data field - unshared, synch} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} - event gen .b.f <<TestUserData>> -data [string index abc 1] +} -body { + bind .t.f <<TestUserData>> {set x "TestUserData >%d<"} + event generate .t.f <<TestUserData>> -data [string index abc 1] set x -} {TestUserData >b<} +} -cleanup { + destroy .t.f +} -result {TestUserData >b<} # Note that asynch event handling can only really catch any potential # extra errors when used in combination with a tool like Purify or # Valgrind. Such testing is rarely done, but at least any problem with # reference handling will eventually show up with these tests... -test bind-32.5 {virtual event user_data field - NULL, asynch} { - setup +test bind-31.5 {virtual event user_data field - NULL, asynch} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} - event gen .b.f <<TestUserData>> -when head +} -body { + bind .t.f <<TestUserData>> {set x "TestUserData >%d<"} + event generate .t.f <<TestUserData>> -when head list $x [update] $x -} {{} {} {TestUserData >{}<}} -test bind-32.6 {virtual event user_data field - shared, asynch} { - setup +} -cleanup { + destroy .t.f +} -result {{} {} {TestUserData >{}<}} +test bind-31.6 {virtual event user_data field - shared, asynch} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} - event gen .b.f <<TestUserData>> -data "foo bar" -when head +} -body { + bind .t.f <<TestUserData>> {set x "TestUserData >%d<"} + event generate .t.f <<TestUserData>> -data "foo bar" -when head list $x [update] $x -} {{} {} {TestUserData >foo bar<}} -test bind-32.7 {virtual event user_data field - unshared, asynch} { - setup +} -cleanup { + destroy .t.f +} -result {{} {} {TestUserData >foo bar<}} +test bind-31.7 {virtual event user_data field - unshared, asynch} -setup { + frame .t.f -class Test -width 150 -height 100 + pack .t.f + focus -force .t.f + update set x {} - bind .b.f <<TestUserData>> {set x "TestUserData >%d<"} - event gen .b.f <<TestUserData>> -data [string index abc 1] -when head +} -body { + bind .t.f <<TestUserData>> {set x "TestUserData >%d<"} + event generate .t.f <<TestUserData>> -data [string index abc 1] -when head list $x [update] $x -} {{} {} {TestUserData >b<}} +} -cleanup { + destroy .t.f +} -result {{} {} {TestUserData >b<}} -destroy .b # cleanup cleanupTests diff --git a/tests/bitmap.test b/tests/bitmap.test index 6e2255c..80bc114 100644 --- a/tests/bitmap.test +++ b/tests/bitmap.test @@ -6,55 +6,71 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} testbitmap { +test bitmap-1.1 {Tk_AllocBitmapFromObj - converting internal reps} -constraints { + testbitmap +} -body { set x gray25 - lindex $x 0 - destroy .b1 - button .b1 -bitmap $x + lindex $x 0 + button .b -bitmap $x lindex $x 0 testbitmap gray25 -} {{1 0}} -test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} testbitmap { +} -cleanup { + destroy .b +} -result {{1 0}} +test bitmap-1.2 {Tk_AllocBitmapFromObj - discard stale bitmap} -constraints { + testbitmap +} -setup { + set result {} +} -body { set x gray25 - destroy .b1 .b2 button .b1 -bitmap $x destroy .b1 - set result {} lappend result [testbitmap gray25] button .b2 -bitmap $x lappend result [testbitmap gray25] -} {{} {{1 1}}} -test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} testbitmap { - set x gray25 +} -cleanup { destroy .b1 .b2 - button .b1 -bitmap $x +} -result {{} {{1 1}}} +test bitmap-1.3 {Tk_AllocBitmapFromObj - reuse existing bitmap} -constraints { + testbitmap +} -setup { set result {} +} -body { + set x gray25 + button .b1 -bitmap $x lappend result [testbitmap gray25] button .b2 -bitmap $x pack .b1 .b2 -side top lappend result [testbitmap gray25] -} {{{1 1}} {{2 1}}} +} -cleanup { + destroy .b1 .b2 +} -result {{{1 1}} {{2 1}}} -test bitmap-2.1 {Tk_GetBitmap procedure} { - destroy .b1 - list [catch {button .b1 -bitmap bad_name} msg] $msg -} {1 {bitmap "bad_name" not defined}} -test bitmap-2.2 {Tk_GetBitmap procedure} { - destroy .b1 - list [catch {button .b1 -bitmap @xyzzy} msg] $msg -} {1 {error reading bitmap file "xyzzy"}} +test bitmap-2.1 {Tk_GetBitmap procedure} -body { + button .b1 -bitmap bad_name +} -cleanup { + destroy .b1 +} -returnCodes error -result {bitmap "bad_name" not defined} +test bitmap-2.2 {Tk_GetBitmap procedure} -body { + button .b1 -bitmap @xyzzy +} -cleanup { + destroy .b1 +} -returnCodes error -result {error reading bitmap file "xyzzy"} -test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap { +test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} -constraints { + testbitmap +} -setup { + set result {} +} -body { set x questhead - destroy .b1 .b2 .b3 button .b1 -bitmap $x button .b3 -bitmap $x button .b2 -bitmap $x - set result {} lappend result [testbitmap questhead] destroy .b1 lappend result [testbitmap questhead] @@ -62,10 +78,13 @@ test bitmap-3.1 {Tk_FreeBitmapFromObj - reference counts} testbitmap { lappend result [testbitmap questhead] destroy .b3 lappend result [testbitmap questhead] -} {{{3 1}} {{2 1}} {{1 1}} {}} +} -cleanup { + destroy .b1 .b2 .b3 ;# destroying just in case +} -result {{{3 1}} {{2 1}} {{1 1}} {}} -test bitmap-4.1 {FreeBitmapObjProc} testbitmap { - destroy .b +test bitmap-4.1 {FreeBitmapObjProc} -constraints { + testbitmap +} -body { set x [format questhead] button .b -bitmap $x set y [format questhead] @@ -81,10 +100,11 @@ test bitmap-4.1 {FreeBitmapObjProc} testbitmap { destroy .b lappend result [testbitmap questhead] set y bogus - set result -} {{{1 3}} {{1 2}} {{1 1}} {}} + return $result +} -cleanup { + destroy .b +} -result {{{1 3}} {{1 2}} {{1 1}} {}} -destroy .t # cleanup cleanupTests diff --git a/tests/border.test b/tests/border.test index 30aed91..78d0fcd 100644 --- a/tests/border.test +++ b/tests/border.test @@ -5,49 +5,60 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -if {[testConstraint pseudocolor8]} { - toplevel .t -visual {pseudocolor 8} -colormap new - wm geom .t +0+0 -} - -test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} testborder { +test border-1.1 {Tk_AllocBorderFromObj - converting internal reps} -constraints { + testborder +} -body { set x orange lindex $x 0 - destroy .b1 button .b1 -bg $x -text .b1 lindex $x 0 testborder orange -} {{1 0}} -test border-1.3 {Tk_AllocBorderFromObj - discard stale border} testborder { +} -cleanup { + destroy .b1 +} -result {{1 0}} +test border-1.2 {Tk_AllocBorderFromObj - discard stale border} -constraints { + testborder +} -setup { + set result {} +} -body { set x orange - destroy .b1 .b2 button .b1 -bg $x -text First destroy .b1 - set result {} lappend result [testborder orange] button .b2 -bg $x -text Second lappend result [testborder orange] -} {{} {{1 1}}} -test border-1.2 {Tk_AllocBorderFromObj - reuse existing border} testborder { - set x orange +} -cleanup { destroy .b1 .b2 - button .b1 -bg $x -text First +} -result {{} {{1 1}}} +test border-1.3 {Tk_AllocBorderFromObj - reuse existing border} -constraints { + testborder +} -setup { set result {} +} -body { + set x orange + button .b1 -bg $x -text First lappend result [testborder orange] button .b2 -bg $x -text Second pack .b1 .b2 -side top lappend result [testborder orange] -} {{{1 1}} {{2 1}}} -test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor8 testborder} { +} -cleanup { + destroy .b1 .b2 +} -result {{{1 1}} {{2 1}}} +test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} -constraints { + testborder pseudocolor8 +} -setup { + toplevel .t -visual {pseudocolor 8} -colormap new + wm geom .t +0+0 + set result {} +} -body { set x purple - destroy .b1 .b2 .t.b button .b1 -bg $x -text First pack .b1 -side top - set result {} lappend result [testborder purple] button .t.b -bg $x -text Second pack .t.b -side top @@ -55,18 +66,24 @@ test border-1.4 {Tk_AllocBorderFromObj - try other borders in list} {pseudocolor button .b2 -bg $x -text Third pack .b2 -side top lappend result [testborder purple] -} {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} +} -cleanup { + destroy .b1 .b2 .t +} -result {{{1 1}} {{1 1} {1 0}} {{1 0} {2 1}}} -test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} { +test border-2.1 {Tk_Free3DBorder - reference counts} -constraints { + testborder pseudocolor8 +} -setup { + toplevel .t -visual {pseudocolor 8} -colormap new + wm geom .t +0+0 + set result {} +} -body { set x purple - destroy .b1 .b2 .t.b button .b1 -bg $x -text First pack .b1 -side top button .t.b -bg $x -text Second pack .t.b -side top button .b2 -bg $x -text Third pack .b2 -side top - set result {} lappend result [testborder purple] destroy .b1 lappend result [testborder purple] @@ -74,11 +91,18 @@ test border-3.1 {Tk_Free3DBorder - reference counts} {pseudocolor8 testborder} { lappend result [testborder purple] destroy .t.b lappend result [testborder purple] -} {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} -test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder} { - destroy .b .t.b .t2 .t3 +} -cleanup { + destroy .b1 .b2 .t +} -result {{{1 0} {2 1}} {{1 0} {1 1}} {{1 0}} {}} +test border-2.2 {Tk_Free3DBorder - unlinking from list} -constraints { + testborder pseudocolor8 +} -setup { + toplevel .t -visual {pseudocolor 8} -colormap new + wm geom .t +0+0 toplevel .t2 -visual {pseudocolor 8} -colormap new toplevel .t3 -visual {pseudocolor 8} -colormap new + set result {} +} -body { set x purple button .b -bg $x -text .b1 button .t.b1 -bg $x -text .t.b1 @@ -90,7 +114,6 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder button .t3.b2 -bg $x -text .t3.b2 button .t3.b3 -bg $x -text .t3.b3 button .t3.b4 -bg $x -text .t3.b4 - set result {} lappend result [testborder purple] destroy .t2 lappend result [testborder purple] @@ -100,17 +123,21 @@ test border-3.4 {Tk_Free3DBorder - unlinking from list} {pseudocolor8 testborder lappend result [testborder purple] destroy .t lappend result [testborder purple] -} {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} +} -cleanup { + destroy .b .t2 .t3 .t +} -result {{{4 1} {3 0} {2 0} {1 0}} {{4 1} {2 0} {1 0}} {{4 1} {2 0}} {{2 0}} {}} -test border-4.1 {FreeBorderObjProc} testborder { - destroy .b +test border-3.1 {FreeBorderObjProc} -constraints { + testborder +} -setup { + set result {} +} -body { set x [format purple] button .b -bg $x -text .b1 set y [format purple] .b configure -bg $y set z [format purple] .b configure -bg $z - set result {} lappend result [testborder purple] set x red lappend result [testborder purple] @@ -119,42 +146,53 @@ test border-4.1 {FreeBorderObjProc} testborder { destroy .b lappend result [testborder purple] set y bogus - set result -} {{{1 3}} {{1 2}} {{1 1}} {}} + return $result +} -cleanup { + destroy .b +} -result {{{1 3}} {{1 2}} {{1 1}} {}} -catch {destroy .b} -button .b -test border-5.1 {Tk_GetReliefFromObj} { - .b configure -relief flat +test border-4.1 {Tk_GetReliefFromObj} -body { + button .b -relief flat .b cget -relief -} {flat} -test border-5.2 {Tk_GetReliefFromObj} { - .b configure -relief groove +} -cleanup { + destroy .b +} -result {flat} +test border-4.2 {Tk_GetReliefFromObj} -body { + button .b -relief groove .b cget -relief -} {groove} -test border-5.3 {Tk_GetReliefFromObj} { - .b configure -relief raised +} -cleanup { + destroy .b +} -result {groove} +test border-4.3 {Tk_GetReliefFromObj} -body { + button .b -relief raised .b cget -relief -} {raised} -test border-5.4 {Tk_GetReliefFromObj} { - .b configure -relief ridge +} -cleanup { + destroy .b +} -result {raised} +test border-4.4 {Tk_GetReliefFromObj} -body { + button .b -relief ridge .b cget -relief -} {ridge} -test border-5.5 {Tk_GetReliefFromObj} { - .b configure -relief solid +} -cleanup { + destroy .b +} -result {ridge} +test border-4.5 {Tk_GetReliefFromObj} -body { + button .b -relief solid .b cget -relief -} {solid} -test border-5.6 {Tk_GetReliefFromObj} { - .b configure -relief sunken +} -cleanup { + destroy .b +} -result {solid} +test border-4.6 {Tk_GetReliefFromObj} -body { + button .b -relief sunken .b cget -relief -} {sunken} -test border-5.7 {Tk_GetReliefFromObj - error} { - list [catch {.b configure -relief upanddown} msg] $msg -} {1 {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken}} +} -cleanup { + destroy .b +} -result {sunken} +test border-4.7 {Tk_GetReliefFromObj - error} -body { + button .b -relief upanddown +} -cleanup { + destroy .b +} -returnCodes error -result {bad relief "upanddown": must be flat, groove, raised, ridge, solid, or sunken} -if {[testConstraint pseudocolor8]} { - destroy .t -} # cleanup cleanupTests diff --git a/tests/busy.test b/tests/busy.test new file mode 100644 index 0000000..304c2eb --- /dev/null +++ b/tests/busy.test @@ -0,0 +1,477 @@ +# Tests for the tk busy command. +# +# This file contains a collection of tests for one or more of the Tk built-in +# commands. Sourcing this file runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 1998-2000 by Jos Decoster. All rights reserved. + +package require tcltest 2.1 +tcltest::configure {*}$argv +tcltest::loadTestedCommands +namespace import -force tcltest::test + +# There's currently no way to test the actual grab effect, per se, in an +# automated test. Therefore, this test suite only covers the interface to the +# grab command (ie, error messages, etc.) + +test busy-1.1 {Tk_BusyObjCmd} -returnCodes error -body { + tk busy +} -result {wrong # args: should be "tk busy options ?arg arg ...?"} + +test busy-2.1 {tk busy hold} -returnCodes error -body { + tk busy hold +} -result {wrong # args: should be "tk busy hold window ?option value ...?"} +test busy-2.2 {tk busy hold root window} -body { + tk busy hold . + update +} -cleanup { + tk busy forget . +} -result {} +test busy-2.3 {tk busy hold root window with shortcut} -body { + tk busy . + update +} -cleanup { + tk busy forget . +} -result {} +test busy-2.4 {tk busy hold nested window} -setup { + pack [frame .f] +} -body { + tk busy hold .f + update +} -cleanup { + tk busy forget .f + destroy .f +} -result {} +test busy-2.5 {tk busy hold nested window with shortcut} -setup { + pack [frame .f] +} -body { + tk busy .f + update +} -cleanup { + tk busy forget .f + destroy .f +} -result {} +test busy-2.6 {tk busy hold toplevel window} -setup { + toplevel .f +} -body { + tk busy hold .f + update +} -cleanup { + tk busy forget .f + destroy .f +} -result {} +test busy-2.7 {tk busy hold toplevel window with shortcut} -setup { + toplevel .f +} -body { + tk busy .f + update +} -cleanup { + tk busy forget .f + destroy .f +} -result {} +test busy-2.8 {tk busy hold non existing window} -body { + tk busy hold .f + update +} -returnCodes error -result {bad window path name ".f"} +test busy-2.9 {tk busy hold (shortcut) non existing window} -body { + tk busy .f + update +} -returnCodes {error} -result {bad window path name ".f"} +test busy-2.10 {tk busy hold root window with cursor} -body { + tk busy hold . -cursor arrow + update +} -cleanup { + tk busy forget . +} -result {} +test busy-2.11 {tk busy hold (shortcut) root window, cursor} -body { + tk busy . -cursor arrow + update +} -cleanup { + tk busy forget . +} -result {} +test busy-2.12 {tk busy hold root window, invalid cursor} -body { + tk busy hold . -cursor nonExistingCursor + update +} -constraints tempNotMac -returnCodes error -cleanup { + tk busy forget . +} -result {bad cursor spec "nonExistingCursor"} +test busy-2.13 {tk busy hold (shortcut) root window, invalid cursor} -body { + tk busy . -cursor nonExistingCursor + update +} -constraints tempNotMac -returnCodes error -cleanup { + tk busy forget . +} -result {bad cursor spec "nonExistingCursor"} +test busy-2.14 {tk busy hold root window, invalid option} -body { + tk busy hold . -invalidOption 1 + update +} -constraints tempNotMac -returnCodes error -cleanup { + tk busy forget . +} -result {unknown option "-invalidOption"} +test busy-2.15 {tk busy hold (shortcut) root window, invalid option} -body { + tk busy . -invalidOption 1 + update +} -constraints tempNotMac -returnCodes error -cleanup { + tk busy forget . +} -result {unknown option "-invalidOption"} + +test busy-3.1 {tk busy cget no window} -returnCodes error -body { + tk busy cget +} -result {wrong # args: should be "tk busy cget window option"} +test busy-3.2 {tk busy cget no option} -returnCodes error -body { + tk busy cget +} -result {wrong # args: should be "tk busy cget window option"} +test busy-3.3 {tk busy cget invalid window} -returnCodes error -body { + tk busy cget .f -cursor +} -result {bad window path name ".f"} +test busy-3.4 {tk busy cget non-busy window} -setup { + pack [frame .f] +} -body { + tk busy cget .f -cursor +} -cleanup { + destroy .f +} -returnCodes error -result {can't find busy window ".f"} +test busy-3.5 {tk busy cget invalid option} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy cget .f -invalidOption +} -cleanup { + tk busy forget .f + destroy .f +} -returnCodes error -result {unknown option "-invalidOption"} +test busy-3.6unix {tk busy cget unix} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy cget .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {watch} -constraints unix +test busy-3.6win {tk busy cget win} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy cget .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {wait} -constraints win +test busy-3.7 {tk busy cget unix} -setup { + pack [frame .f] + tk busy hold .f -cursor hand1 + update +} -body { + tk busy cget .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {hand1} -constraints tempNotMac + +test busy-4.1 {tk busy configure no window} -returnCodes error -body { + tk busy configure +} -result {wrong # args: should be "tk busy configure window ?option? ?value ...?"} + +test busy-4.2 {tk busy configure invalid window} -body { + tk busy configure .f +} -returnCodes error -result {bad window path name ".f"} + +test busy-4.3 {tk busy configure non-busy window} -setup { + pack [frame .f] +} -body { + tk busy configure .f +} -cleanup { + destroy .f +} -returnCodes error -result {can't find busy window ".f"} + +test busy-4.4 {tk busy configure} -constraints {nonwin} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {{-cursor cursor Cursor watch watch}} + +test busy-4.4-win {tk busy configure} -constraints {win} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {{-cursor cursor Cursor wait wait}} + +test busy-4.5 {tk busy configure} -constraints {nonwin tempNotMac} -setup { + pack [frame .f] + tk busy hold .f -cursor hand2 + update +} -body { + tk busy configure .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {{-cursor cursor Cursor watch hand2}} + +test busy-4.5-win {tk busy configure} -constraints win -setup { + pack [frame .f] + tk busy hold .f -cursor hand2 + update +} -body { + tk busy configure .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {{-cursor cursor Cursor wait hand2}} + +test busy-4.6 {tk busy configure invalid option} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f -invalidOption +} -cleanup { + tk busy forget .f + destroy .f +} -returnCodes error -result {unknown option "-invalidOption"} + +test busy-4.7 {tk busy configure valid option} -constraints {nonwin} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {-cursor cursor Cursor watch watch} + +test busy-4.7-win {tk busy configure valid option} -constraints {win} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {-cursor cursor Cursor wait wait} + +test busy-4.8 {tk busy configure valid option} -constraints { + nonwin tempNotMac +} -setup { + pack [frame .f] + tk busy hold .f -cursor circle + update +} -body { + tk busy configure .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {-cursor cursor Cursor watch circle} + +test busy-4.8-win {tk busy configure valid option} -constraints win -setup { + pack [frame .f] + tk busy hold .f -cursor circle + update +} -body { + tk busy configure .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {-cursor cursor Cursor wait circle} + +test busy-4.9 {tk busy configure valid option with value} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f -cursor pencil + tk busy cget .f -cursor +} -cleanup { + tk busy forget .f + destroy .f +} -result {pencil} -constraints tempNotMac + +test busy-4.10 {tk busy configure valid option with invalid value} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy configure .f -cursor nonExistingCursor +} -constraints tempNotMac -returnCodes error -cleanup { + tk busy forget .f + destroy .f +} -result {bad cursor spec "nonExistingCursor"} + +test busy-5.1 {tk busy forget} -returnCodes error -body { + tk busy forget +} -result {wrong # args: should be "tk busy forget window"} +test busy-5.2 {tk busy forget non existing window} -body { + tk busy forget .f +} -returnCodes error -result {bad window path name ".f"} +test busy-5.3 {tk busy forget non busy window} -setup { + pack [frame .f] +} -body { + tk busy forget .f +} -cleanup { + destroy .f +} -returnCodes error -result {can't find busy window ".f"} +test busy-5.4 {tk busy forget window} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + set r [tk busy status .f] + tk busy forget .f + lappend r [tk busy status .f] +} -cleanup { + destroy .f +} -result {1 0} + +test busy-6.1 {tk busy status} -returnCodes error -body { + tk busy status +} -result {wrong # args: should be "tk busy status window"} +test busy-6.2 {tk busy status non existing window} -body { + tk busy status .f +} -result {0} +test busy-6.3 {tk busy status non busy window} -setup { + pack [frame .f] +} -body { + tk busy status .f +} -cleanup { + destroy .f +} -result {0} +test busy-6.4 {tk busy status busy window} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy status .f +} -cleanup { + tk busy forget .f + destroy .f +} -result {1} +test busy-6.5 {tk busy status forgotten busy window} -setup { + pack [frame .f] + tk busy hold .f + update + tk busy forget .f +} -body { + tk busy status .f +} -cleanup { + destroy .f +} -result {0} + +test busy-7.1 {tk busy current no busy} -body { + tk busy current +} -result {} +test busy-7.2 {tk busy current 1 busy} -setup { + pack [frame .f] + tk busy hold .f + update +} -body { + tk busy current +} -cleanup { + tk busy forget .f + destroy .f +} -result {.f} +test busy-7.3 {tk busy current 2 busy} -setup { + pack [frame .f1] + pack [frame .f2] + tk busy hold .f1 + tk busy hold .f2 + update +} -body { + lsort [tk busy current] +} -cleanup { + tk busy forget .f1 + tk busy forget .f2 + destroy .f1 .f2 +} -result {.f1 .f2} +test busy-7.4 {tk busy current 2 busy with matching filter} -setup { + pack [frame .f1] + pack [frame .f2] + tk busy hold .f1 + tk busy hold .f2 + update +} -body { + lsort [tk busy current *2*] +} -cleanup { + tk busy forget .f1 + tk busy forget .f2 + destroy .f1 .f2 +} -result {.f2} +test busy-7.5 {tk busy current 2 busy with non matching filter} -setup { + pack [frame .f1] + pack [frame .f2] + tk busy hold .f1 + tk busy hold .f2 + update +} -body { + lsort [tk busy current *3*] +} -cleanup { + tk busy forget .f1 + tk busy forget .f2 + destroy .f1 .f2 +} -result {} +test busy-7.6 {tk busy current 1 busy after forget} -setup { + pack [frame .f] + tk busy hold .f + update + tk busy forget .f +} -body { + tk busy current +} -cleanup { + destroy .f +} -result {} +test busy-7.7 {tk busy current 2 busy after forget} -setup { + pack [frame .f1] + pack [frame .f2] + tk busy hold .f1 + tk busy hold .f2 + update + tk busy forget .f1 +} -body { + lsort [tk busy current] +} -cleanup { + tk busy forget .f2 + destroy .f1 .f2 +} -result {.f2} +test busy-7.8 {tk busy current 2 busy with matching filter after forget} -setup { + pack [frame .f1] + pack [frame .f2] + tk busy hold .f1 + tk busy hold .f2 + update + tk busy forget .f1 +} -body { + lsort [tk busy current *2*] +} -cleanup { + tk busy forget .f2 + destroy .f1 .f2 +} -result {.f2} +test busy-7.9 {tk busy current 2 busy with non matching filter after forget} -setup { + pack [frame .f1] + pack [frame .f2] + tk busy hold .f1 + tk busy hold .f2 + update + tk busy forget .f1 +} -body { + lsort [tk busy current *3*] +} -cleanup { + tk busy forget .f2 + destroy .f1 .f2 +} -result {} + +::tcltest::cleanupTests +return diff --git a/tests/button.test b/tests/button.test index 927aac0..984fd43 100644 --- a/tests/button.test +++ b/tests/button.test @@ -7,427 +7,3201 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit proc bogusTrace args { error "trace aborted" } -catch {unset value} -catch {unset value2} -# Create entries in the option database to be sure that geometry options -# like border width have predictable values. +test button-1.1 {configuration option: "activebackground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -activebackground #012345 + .l cget -activebackground +} -cleanup { + destroy .l +} -result {#012345} +test button-1.2 {configuration option: "activebackground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -activebackground non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.3 {configuration option: "activebackground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -activebackground #012345 + .b cget -activebackground +} -cleanup { + destroy .b +} -result {#012345} +test button-1.4 {configuration option: "activebackground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -activebackground non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.5 {configuration option: "activebackground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -activebackground #012345 + .c cget -activebackground +} -cleanup { + destroy .c +} -result {#012345} +test button-1.6 {configuration option: "activebackground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -activebackground non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.7 {configuration option: "activebackground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -activebackground #012345 + .r cget -activebackground +} -cleanup { + destroy .r +} -result {#012345} +test button-1.8 {configuration option: "activebackground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -activebackground non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.9 {configuration option: "activeforeground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -activeforeground #ff0000 + .l cget -activeforeground +} -cleanup { + destroy .l +} -result {#ff0000} +test button-1.10 {configuration option: "activeforeground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -activeforeground non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.11 {configuration option: "activeforeground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -activeforeground #ff0000 + .b cget -activeforeground +} -cleanup { + destroy .b +} -result {#ff0000} +test button-1.12 {configuration option: "activeforeground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -activeforeground non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.13 {configuration option: "activeforeground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -activeforeground #ff0000 + .c cget -activeforeground +} -cleanup { + destroy .c +} -result {#ff0000} +test button-1.14 {configuration option: "activeforeground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -activeforeground non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.15 {configuration option: "activeforeground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -activeforeground #ff0000 + .r cget -activeforeground +} -cleanup { + destroy .r +} -result {#ff0000} +test button-1.16 {configuration option: "activeforeground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -activeforeground non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.17 {configuration option: "anchor" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -anchor nw + .l cget -anchor +} -cleanup { + destroy .l +} -result {nw} +test button-1.18 {configuration option: "anchor" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -anchor bogus +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} +test button-1.19 {configuration option: "anchor" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -anchor nw + .b cget -anchor +} -cleanup { + destroy .b +} -result {nw} +test button-1.20 {configuration option: "anchor" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -anchor bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} +test button-1.21 {configuration option: "anchor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -anchor nw + .c cget -anchor +} -cleanup { + destroy .c +} -result {nw} +test button-1.22 {configuration option: "anchor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -anchor bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} +test button-1.23 {configuration option: "anchor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -anchor nw + .r cget -anchor +} -cleanup { + destroy .r +} -result {nw} +test button-1.24 {configuration option: "anchor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -anchor bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} + +test button-1.25 {configuration option: "background" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -background #ff0000 + .l cget -background +} -cleanup { + destroy .l +} -result {#ff0000} +test button-1.26 {configuration option: "background" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -background non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.27 {configuration option: "background" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -background #ff0000 + .b cget -background +} -cleanup { + destroy .b +} -result {#ff0000} +test button-1.28 {configuration option: "background" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -background non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.29 {configuration option: "background" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -background #ff0000 + .c cget -background +} -cleanup { + destroy .c +} -result {#ff0000} +test button-1.30 {configuration option: "background" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -background non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.31 {configuration option: "background" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -background #ff0000 + .r cget -background +} -cleanup { + destroy .r +} -result {#ff0000} +test button-1.32 {configuration option: "background" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -background non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.33 {configuration option: "bd" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -bd 4 + .l cget -bd +} -cleanup { + destroy .l +} -result {4} +test button-1.34 {configuration option: "bd" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -bd badValue +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.35 {configuration option: "bd" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -bd 4 + .b cget -bd +} -cleanup { + destroy .b +} -result {4} +test button-1.36 {configuration option: "bd" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -bd badValue +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.37 {configuration option: "bd" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -bd 4 + .c cget -bd +} -cleanup { + destroy .c +} -result {4} +test button-1.38 {configuration option: "bd" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -bd badValue +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.39 {configuration option: "bd" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -bd 4 + .r cget -bd +} -cleanup { + destroy .r +} -result {4} +test button-1.40 {configuration option: "bd" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -bd badValue +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad screen distance "badValue"} + +test button-1.41 {configuration option: "bg" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -bg #ff0000 + .l cget -bg +} -cleanup { + destroy .l +} -result {#ff0000} +test button-1.42 {configuration option: "bg" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -bg non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.43 {configuration option: "bg" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -bg #ff0000 + .b cget -bg +} -cleanup { + destroy .b +} -result {#ff0000} +test button-1.44 {configuration option: "bg" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -bg non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.45 {configuration option: "bg" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -bg #ff0000 + .c cget -bg +} -cleanup { + destroy .c +} -result {#ff0000} +test button-1.46 {configuration option: "bg" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -bg non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.47 {configuration option: "bg" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -bg #ff0000 + .r cget -bg +} -cleanup { + destroy .r +} -result {#ff0000} +test button-1.48 {configuration option: "bg" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -bg non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.49 {configuration option: "bitmap" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -bitmap questhead + .l cget -bitmap +} -cleanup { + destroy .l +} -result {questhead} +test button-1.50 {configuration option: "bitmap" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -bitmap badValue +} -cleanup { + destroy .l +} -returnCodes {error} -result {bitmap "badValue" not defined} +test button-1.51 {configuration option: "bitmap" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -bitmap questhead + .b cget -bitmap +} -cleanup { + destroy .b +} -result {questhead} +test button-1.52 {configuration option: "bitmap" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -bitmap badValue +} -cleanup { + destroy .b +} -returnCodes {error} -result {bitmap "badValue" not defined} +test button-1.53 {configuration option: "bitmap" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -bitmap questhead + .c cget -bitmap +} -cleanup { + destroy .c +} -result {questhead} +test button-1.54 {configuration option: "bitmap" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -bitmap badValue +} -cleanup { + destroy .c +} -returnCodes {error} -result {bitmap "badValue" not defined} +test button-1.55 {configuration option: "bitmap" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -bitmap questhead + .r cget -bitmap +} -cleanup { + destroy .r +} -result {questhead} +test button-1.56 {configuration option: "bitmap" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -bitmap badValue +} -cleanup { + destroy .r +} -returnCodes {error} -result {bitmap "badValue" not defined} + +test button-1.57 {configuration option: "borderwidth" for label} -setup { + label .l -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -borderwidth 1.3 + .l cget -borderwidth +} -cleanup { + destroy .l +} -result {1.3} +test button-1.58 {configuration option: "borderwidth" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -borderwidth badValue +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.59 {configuration option: "borderwidth" for button} -setup { + button .b -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -borderwidth 1.3 + .b cget -borderwidth +} -cleanup { + destroy .b +} -result {1.3} +test button-1.60 {configuration option: "borderwidth" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -borderwidth badValue +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.61 {configuration option: "borderwidth" for checkbutton} -setup { + checkbutton .c -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -borderwidth 1.3 + .c cget -borderwidth +} -cleanup { + destroy .c +} -result {1.3} +test button-1.62 {configuration option: "borderwidth" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -borderwidth badValue +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.63 {configuration option: "borderwidth" for radiobutton} -setup { + radiobutton .r -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -borderwidth 1.3 + .r cget -borderwidth +} -cleanup { + destroy .r +} -result {1.3} +test button-1.64 {configuration option: "borderwidth" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -borderwidth badValue +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad screen distance "badValue"} + +test button-1.65 {configuration option: "command" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -command {set x} + .b cget -command +} -cleanup { + destroy .b +} -result {set x} +test button-1.66 {configuration option: "command" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -command {set x} + .b cget -command +} -cleanup { + destroy .b +} -result {set x} +test button-1.67 {configuration option: "command" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -command {set x} + .c cget -command +} -cleanup { + destroy .c +} -result {set x} +test button-1.68 {configuration option: "command" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -command {set x} + .r cget -command +} -cleanup { + destroy .r +} -result {set x} + +test button-1.69 {configuration option: "compound" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -compound left + .l cget -compound +} -cleanup { + destroy .l +} -result {left} +test button-1.70 {configuration option: "compound" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -compound bogus +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top} +test button-1.71 {configuration option: "compound" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -compound left + .b cget -compound +} -cleanup { + destroy .b +} -result {left} +test button-1.72 {configuration option: "compound" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -compound bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top} +test button-1.73 {configuration option: "compound" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -compound left + .c cget -compound +} -cleanup { + destroy .c +} -result {left} +test button-1.74 {configuration option: "compound" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -compound bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top} +test button-1.75 {configuration option: "compound" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -compound left + .r cget -compound +} -cleanup { + destroy .r +} -result {left} +test button-1.76 {configuration option: "compound" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -compound bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad compound "bogus": must be bottom, center, left, none, right, or top} + +test button-1.77 {configuration option: "cursor" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -cursor arrow + .l cget -cursor +} -cleanup { + destroy .l +} -result {arrow} +test button-1.78 {configuration option: "cursor" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -cursor badValue +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad cursor spec "badValue"} +test button-1.79 {configuration option: "cursor" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -cursor arrow + .b cget -cursor +} -cleanup { + destroy .b +} -result {arrow} +test button-1.80 {configuration option: "cursor" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -cursor badValue +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad cursor spec "badValue"} +test button-1.81 {configuration option: "cursor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -cursor arrow + .c cget -cursor +} -cleanup { + destroy .c +} -result {arrow} +test button-1.82 {configuration option: "cursor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -cursor badValue +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad cursor spec "badValue"} +test button-1.83 {configuration option: "cursor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -cursor arrow + .r cget -cursor +} -cleanup { + destroy .r +} -result {arrow} +test button-1.84 {configuration option: "cursor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -cursor badValue +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad cursor spec "badValue"} + +test button-1.85 {configuration option: "default" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -default active + .b cget -default +} -cleanup { + destroy .b +} -result {active} +test button-1.86 {configuration option: "default" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -default huh? +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad default "huh?": must be active, disabled, or normal} + +test button-1.87 {configuration option: "disabledforeground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -disabledforeground #00ff00 + .l cget -disabledforeground +} -cleanup { + destroy .l +} -result {#00ff00} +test button-1.88 {configuration option: "disabledforeground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -disabledforeground non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.89 {configuration option: "disabledforeground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -disabledforeground #00ff00 + .b cget -disabledforeground +} -cleanup { + destroy .b +} -result {#00ff00} +test button-1.90 {configuration option: "disabledforeground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -disabledforeground non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.91 {configuration option: "disabledforeground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -disabledforeground #00ff00 + .c cget -disabledforeground +} -cleanup { + destroy .c +} -result {#00ff00} +test button-1.92 {configuration option: "disabledforeground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -disabledforeground non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.93 {configuration option: "disabledforeground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -disabledforeground #00ff00 + .r cget -disabledforeground +} -cleanup { + destroy .r +} -result {#00ff00} +test button-1.94 {configuration option: "disabledforeground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -disabledforeground non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.95 {configuration option: "fg" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -fg #110022 + .l cget -fg +} -cleanup { + destroy .l +} -result {#110022} +test button-1.96 {configuration option: "fg" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -fg non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.97 {configuration option: "fg" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -fg #110022 + .b cget -fg +} -cleanup { + destroy .b +} -result {#110022} +test button-1.98 {configuration option: "fg" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -fg non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.99 {configuration option: "fg" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -fg #110022 + .c cget -fg +} -cleanup { + destroy .c +} -result {#110022} +test button-1.100 {configuration option: "fg" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -fg non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.101 {configuration option: "fg" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -fg #110022 + .r cget -fg +} -cleanup { + destroy .r +} -result {#110022} +test button-1.102 {configuration option: "fg" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -fg non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.103 {configuration option: "font" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 + pack .l + update +} -body { + .l configure -font {Helvetica -12} + .l cget -font +} -cleanup { + destroy .l +} -result {Helvetica -12} +test button-1.104 {configuration option: "activebackground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 + pack .l + update +} -body { + .l configure -font {} +} -cleanup { + destroy .l +} -returnCodes {error} -result {font "" doesn't exist} +test button-1.105 {configuration option: "font" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 + pack .b + update +} -body { + .b configure -font {Helvetica -12} + .b cget -font +} -cleanup { + destroy .b +} -result {Helvetica -12} +test button-1.106 {configuration option: "activebackground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 + pack .b + update +} -body { + .b configure -font {} +} -cleanup { + destroy .b +} -returnCodes {error} -result {font "" doesn't exist} +test button-1.107 {configuration option: "font" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 + pack .c + update +} -body { + .c configure -font {Helvetica -12} + .c cget -font +} -cleanup { + destroy .c +} -result {Helvetica -12} +test button-1.108 {configuration option: "activebackground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 + pack .c + update +} -body { + .c configure -font {} +} -cleanup { + destroy .c +} -returnCodes {error} -result {font "" doesn't exist} +test button-1.109 {configuration option: "font" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 + pack .r + update +} -body { + .r configure -font {Helvetica -12} + .r cget -font +} -cleanup { + destroy .r +} -result {Helvetica -12} +test button-1.110 {configuration option: "activebackground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 + pack .r + update +} -body { + .r configure -font {} +} -cleanup { + destroy .r +} -returnCodes {error} -result {font "" doesn't exist} -option add *Button.borderWidth 2 -option add *Button.highlightThickness 2 -option add *Button.font {Helvetica -12 bold} +test button-1.111 {configuration option: "foreground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -foreground #110022 + .l cget -foreground +} -cleanup { + destroy .l +} -result {#110022} +test button-1.112 {configuration option: "foreground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -foreground non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.113 {configuration option: "foreground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -foreground #110022 + .b cget -foreground +} -cleanup { + destroy .b +} -result {#110022} +test button-1.114 {configuration option: "foreground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -foreground non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.115 {configuration option: "foreground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -foreground #110022 + .c cget -foreground +} -cleanup { + destroy .c +} -result {#110022} +test button-1.116 {configuration option: "foreground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -foreground non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.117 {configuration option: "foreground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -foreground #110022 + .r cget -foreground +} -cleanup { + destroy .r +} -result {#110022} +test button-1.118 {configuration option: "foreground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -foreground non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} -eval image delete [image names] -if {[testConstraint testImageType]} { +test button-1.119 {configuration option: "height" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -height 18 + .l cget -height +} -cleanup { + destroy .l +} -result {18} +test button-1.120 {configuration option: "height" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -height 20.0 +} -cleanup { + destroy .l +} -returnCodes {error} -result {expected integer but got "20.0"} +test button-1.121 {configuration option: "height" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -height 18 + .b cget -height +} -cleanup { + destroy .b +} -result {18} +test button-1.122 {configuration option: "height" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -height 20.0 +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "20.0"} +test button-1.123 {configuration option: "height" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -height 18 + .c cget -height +} -cleanup { + destroy .c +} -result {18} +test button-1.124 {configuration option: "height" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -height 20.0 +} -cleanup { + destroy .c +} -returnCodes {error} -result {expected integer but got "20.0"} +test button-1.125 {configuration option: "height" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -height 18 + .r cget -height +} -cleanup { + destroy .r +} -result {18} +test button-1.126 {configuration option: "height" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -height 20.0 +} -cleanup { + destroy .r +} -returnCodes {error} -result {expected integer but got "20.0"} + +test button-1.127 {configuration option: "highlightbackground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -highlightbackground #110022 + .l cget -highlightbackground +} -cleanup { + destroy .l +} -result {#110022} +test button-1.128 {configuration option: "highlightbackground" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -highlightbackground non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.129 {configuration option: "highlightbackground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -highlightbackground #110022 + .b cget -highlightbackground +} -cleanup { + destroy .b +} -result {#110022} +test button-1.130 {configuration option: "highlightbackground" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -highlightbackground non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.131 {configuration option: "highlightbackground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -highlightbackground #110022 + .c cget -highlightbackground +} -cleanup { + destroy .c +} -result {#110022} +test button-1.132 {configuration option: "highlightbackground" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -highlightbackground non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.133 {configuration option: "highlightbackground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -highlightbackground #110022 + .r cget -highlightbackground +} -cleanup { + destroy .r +} -result {#110022} +test button-1.134 {configuration option: "highlightbackground" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -highlightbackground non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.135 {configuration option: "highlightcolor" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -highlightcolor #110022 + .l cget -highlightcolor +} -cleanup { + destroy .l +} -result {#110022} +test button-1.136 {configuration option: "highlightcolor" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -highlightcolor non-existent +} -cleanup { + destroy .l +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.137 {configuration option: "highlightcolor" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -highlightcolor #110022 + .b cget -highlightcolor +} -cleanup { + destroy .b +} -result {#110022} +test button-1.138 {configuration option: "highlightcolor" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -highlightcolor non-existent +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.139 {configuration option: "highlightcolor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -highlightcolor #110022 + .c cget -highlightcolor +} -cleanup { + destroy .c +} -result {#110022} +test button-1.140 {configuration option: "highlightcolor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -highlightcolor non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.141 {configuration option: "highlightcolor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -highlightcolor #110022 + .r cget -highlightcolor +} -cleanup { + destroy .r +} -result {#110022} +test button-1.142 {configuration option: "highlightcolor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -highlightcolor non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.143 {configuration option: "highlightthickness" for label} -setup { + label .l -borderwidth 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -highlightthickness 6m + .l cget -highlightthickness +} -cleanup { + destroy .l +} -result {6m} +test button-1.144 {configuration option: "highlightthickness" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -highlightthickness badValue +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.145 {configuration option: "highlightthickness" for button} -setup { + button .b -borderwidth 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -highlightthickness 6m + .b cget -highlightthickness +} -cleanup { + destroy .b +} -result {6m} +test button-1.146 {configuration option: "highlightthickness" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -highlightthickness badValue +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.147 {configuration option: "highlightthickness" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -highlightthickness 6m + .c cget -highlightthickness +} -cleanup { + destroy .c +} -result {6m} +test button-1.148 {configuration option: "highlightthickness" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -highlightthickness badValue +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad screen distance "badValue"} +test button-1.149 {configuration option: "highlightthickness" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -highlightthickness 6m + .r cget -highlightthickness +} -cleanup { + destroy .r +} -result {6m} +test button-1.150 {configuration option: "highlightthickness" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -highlightthickness badValue +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad screen distance "badValue"} + +test button-1.151 {configuration option: "image" for label} -constraints { + testImageType +} -setup { image create test image1 -} -label .l -text Label -button .b -text Button -checkbutton .c -text Checkbutton -radiobutton .r -text Radiobutton -pack .l .b .c .r -update -set i 1 -foreach test { - {-activebackground #012345 #012345 non-existent - {unknown color name "non-existent"} {1 1 1 1}} - {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"} {1 1 1 1}} - {-anchor nw nw bogus - {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} - {1 1 1 1}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"} {1 1 1 1}} - {-bd 4 4 badValue {bad screen distance "badValue"} {1 1 1 1}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"} - {1 1 1 1}} - {-bitmap questhead questhead badValue {bitmap "badValue" not defined} - {1 1 1 1}} - {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"} {1 1 1 1}} - {-command "set x" {set x} {} {} {0 1 1 1}} - {-compound left left bogus - {bad compound "bogus": must be bottom, center, left, none, right, or top} - {1 1 1 1}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"} {1 1 1 1}} - {-default active active huh? - {bad default "huh?": must be active, disabled, or normal} - {0 1 0 0}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"} - {1 1 1 1}} - {-fg #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist} {1 1 1 1}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"} {1 1 1 1}} - {-height 18 18 20.0 {expected integer but got "20.0"} {1 1 1 1}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"} - {1 1 1 1}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"} - {1 1 1 1}} - {-highlightthickness 6m 6m badValue {bad screen distance "badValue"} - {1 1 1 1}} - {-image image1 image1 bogus {image "bogus" doesn't exist} {1 1 1 1}} - {-indicatoron yes 1 no_way {expected boolean value but got "no_way"} - {0 0 1 1}} - {-justify right right bogus - {bad justification "bogus": must be left, right, or center} - {1 1 1 1}} - {-offrelief flat flat 1.5 - {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} - {0 0 1 1}} - {-offvalue lousy lousy {} {} {0 0 1 0}} - {-onvalue fantastic fantastic {} {} {0 0 1 0}} - {-overrelief "" "" 1.5 - {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} - {0 1 1 1}} - {-padx 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} - {-pady 12m 12m 420x {bad screen distance "420x"} {1 1 1 1}} - {-repeatdelay 100 100 foo {expected integer but got "foo"} {0 1 0 0}} - {-repeatinterval 100 100 foo {expected integer but got "foo"} {0 1 0 0}} - {-relief flat flat 1.5 - {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} - {1 1 1 1}} - {-selectcolor #110022 #110022 bogus {unknown color name "bogus"} {0 0 1 1}} - {-selectimage image1 image1 bogus {image "bogus" doesn't exist} {0 0 1 1}} - {-state normal normal bogus - {bad state "bogus": must be active, disabled, or normal} - {1 1 1 1}} - {-takefocus "any string" "any string" {} {} {1 1 1 1}} - {-text "Sample text" {Sample text} {} {} {1 1 1 1}} - {-textvariable i i {} {} {1 1 1 1}} - {-tristateimage image1 image1 bogus {image "bogus" doesn't exist} - {0 0 1 1}} - {-tristatevalue unknowable unknowable {} {} {0 0 1 1}} - {-underline 5 5 3p {expected integer but got "3p"} {1 1 1 1}} - {-value anyString anyString {} {} {0 0 0 1}} - {-width 402 402 3p {expected integer but got "3p"} {1 1 1 1}} - {-wraplength 100 100 6x {bad screen distance "6x"} {1 1 1 1}} -} { - lassign $test name value okResult badValue badResult classes - foreach w {.l .b .c .r} hasOption $classes { - set classname [winfo class $w] - if {$hasOption} { - test button-1.$i "configuration option $name for $classname" \ - -constraints testImageType -body " - $w configure $name [list $value] - lindex \[$w configure $name] 4 - " -result $okResult - incr i - if {$badValue ne ""} { - test button-1.$i "configuration option $name for $classname" \ - -constraints testImageType \ - -body [list $w configure $name $badValue] \ - -returnCodes error -result $badResult - incr i - } - $w configure $name [lindex [$w configure $name] 3] - } else { - test button-1.$i "configuration option $name for $classname" \ - -constraints testImageType \ - -body [list $w configure $name $value] \ - -returnCodes error -result "unknown option \"$name\"" - incr i - } - } -} -test button-1.$i {configuration options} { - # Additional check to make sure that -selectcolor may be empty in - # checkbox widgets + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -image image1 + .l cget -image +} -cleanup { + destroy .l + image delete image1 +} -result {image1} +test button-1.152 {configuration option: "image" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -image bogus +} -cleanup { + destroy .l +} -returnCodes {error} -result {image "bogus" doesn't exist} +test button-1.153 {configuration option: "image" for button} -constraints { + testImageType +} -setup { + image create test image1 + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -image image1 + .b cget -image +} -cleanup { + destroy .b + image delete image1 +} -result {image1} +test button-1.154 {configuration option: "image" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -image bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {image "bogus" doesn't exist} +test button-1.155 {configuration option: "image" for checkbutton} -constraints { + testImageType +} -setup { + image create test image1 + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -image image1 + .c cget -image +} -cleanup { + destroy .c + image delete image1 +} -result {image1} +test button-1.156 {configuration option: "image" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -image bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {image "bogus" doesn't exist} +test button-1.157 {configuration option: "image" for radiobutton} -constraints { + testImageType +} -setup { + image create test image1 + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -image image1 + .r cget -image +} -cleanup { + destroy .r + image delete image1 +} -result {image1} +test button-1.158 {configuration option: "image" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -image bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {image "bogus" doesn't exist} + +test button-1.159 {configuration option: "indicatoron" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -indicatoron yes + .c cget -indicatoron +} -cleanup { + destroy .c +} -result {1} +test button-1.160 {configuration option: "indicatoron" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -indicatoron no_way +} -cleanup { + destroy .c +} -returnCodes {error} -result {expected boolean value but got "no_way"} +test button-1.161 {configuration option: "indicatoron" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -indicatoron yes + .r cget -indicatoron +} -cleanup { + destroy .r +} -result {1} +test button-1.162 {configuration option: "indicatoron" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -indicatoron no_way +} -cleanup { + destroy .r +} -returnCodes {error} -result {expected boolean value but got "no_way"} + +test button-1.163 {configuration option: "justify" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -justify right + .l cget -justify +} -cleanup { + destroy .l +} -result {right} +test button-1.164 {configuration option: "justify" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -justify bogus +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} +test button-1.165 {configuration option: "justify" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -justify right + .b cget -justify +} -cleanup { + destroy .b +} -result {right} +test button-1.166 {configuration option: "justify" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -justify bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} +test button-1.167 {configuration option: "justify" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -justify right + .c cget -justify +} -cleanup { + destroy .c +} -result {right} +test button-1.168 {configuration option: "justify" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -justify bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} +test button-1.169 {configuration option: "justify" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -justify right + .r cget -justify +} -cleanup { + destroy .r +} -result {right} +test button-1.170 {configuration option: "justify" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -justify bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} + +test button-1.171 {configuration option: "offrelief" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -offrelief flat + .c cget -offrelief +} -cleanup { + destroy .c +} -result {flat} +test button-1.172 {configuration option: "offrelief" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -offrelief 1.5 +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test button-1.173 {configuration option: "offrelief" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -offrelief flat + .r cget -offrelief +} -cleanup { + destroy .r +} -result {flat} +test button-1.174 {configuration option: "offrelief" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -offrelief 1.5 +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} + +test button-1.175 {configuration option: "offvalue" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -offvalue lousy + .c cget -offvalue +} -cleanup { + destroy .c +} -result {lousy} + +test button-1.176 {configuration option: "onvalue" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -onvalue fantastic + .c cget -onvalue +} -cleanup { + destroy .c +} -result {fantastic} + +test button-1.177 {configuration option: "overrelief" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -overrelief "" + .b cget -overrelief +} -cleanup { + destroy .b +} -result {} +test button-1.178 {configuration option: "overrelief" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -overrelief 1.5 +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test button-1.179 {configuration option: "overrelief" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -overrelief "" + .c cget -overrelief +} -cleanup { + destroy .c +} -result {} +test button-1.180 {configuration option: "overrelief" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -overrelief 1.5 +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test button-1.181 {configuration option: "overrelief" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -overrelief "" + .r cget -overrelief +} -cleanup { + destroy .r +} -result {} +test button-1.182 {configuration option: "overrelief" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -overrelief 1.5 +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} + +test button-1.183 {configuration option: "padx" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -padx 12m + .l cget -padx +} -cleanup { + destroy .l +} -result {12m} +test button-1.184 {configuration option: "padx" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -padx 420x +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad screen distance "420x"} +test button-1.185 {configuration option: "padx" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -padx 12m + .b cget -padx +} -cleanup { + destroy .b +} -result {12m} +test button-1.186 {configuration option: "padx" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -padx 420x +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "420x"} +test button-1.187 {configuration option: "padx" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -padx 12m + .c cget -padx +} -cleanup { + destroy .c +} -result {12m} +test button-1.188 {configuration option: "padx" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -padx 420x +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad screen distance "420x"} +test button-1.189 {configuration option: "padx" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -padx 12m + .r cget -padx +} -cleanup { + destroy .r +} -result {12m} +test button-1.190 {configuration option: "padx" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -padx 420x +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad screen distance "420x"} + +test button-1.191 {configuration option: "pady" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -pady 12m + .l cget -pady +} -cleanup { + destroy .l +} -result {12m} +test button-1.192 {configuration option: "pady" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -pady 420x +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad screen distance "420x"} +test button-1.193 {configuration option: "pady" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -pady 12m + .b cget -pady +} -cleanup { + destroy .b +} -result {12m} +test button-1.194 {configuration option: "pady" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -pady 420x +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "420x"} +test button-1.195 {configuration option: "pady" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -pady 12m + .c cget -pady +} -cleanup { + destroy .c +} -result {12m} +test button-1.196 {configuration option: "pady" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -pady 420x +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad screen distance "420x"} +test button-1.197 {configuration option: "pady" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -pady 12m + .r cget -pady +} -cleanup { + destroy .r +} -result {12m} +test button-1.198 {configuration option: "pady" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -pady 420x +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad screen distance "420x"} + +test button-1.199 {configuration option: "repeatdelay" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -repeatdelay 100 + .b cget -repeatdelay +} -cleanup { + destroy .b +} -result {100} +test button-1.200 {configuration option: "repeatdelay" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -repeatdelay foo +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "foo"} + +test button-1.201 {configuration option: "repeatinterval" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -repeatinterval 100 + .b cget -repeatinterval +} -cleanup { + destroy .b +} -result {100} +test button-1.202 {configuration option: "repeatinterval" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -repeatinterval foo +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "foo"} + +test button-1.203 {configuration option: "relief" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -relief flat + .l cget -relief +} -cleanup { + destroy .l +} -result {flat} +test button-1.204 {configuration option: "relief" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -relief 1.5 +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test button-1.205 {configuration option: "relief" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -relief flat + .b cget -relief +} -cleanup { + destroy .b +} -result {flat} +test button-1.206 {configuration option: "relief" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -relief 1.5 +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test button-1.207 {configuration option: "relief" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -relief flat + .c cget -relief +} -cleanup { + destroy .c +} -result {flat} +test button-1.208 {configuration option: "relief" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -relief 1.5 +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test button-1.209 {configuration option: "relief" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -relief flat + .r cget -relief +} -cleanup { + destroy .r +} -result {flat} +test button-1.210 {configuration option: "relief" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -relief 1.5 +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} + +test button-1.211 {configuration option: "selectcolor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -selectcolor #110022 + .c cget -selectcolor +} -cleanup { + destroy .c +} -result {#110022} +test button-1.212 {configuration option: "selectcolor" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -selectcolor non-existent +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown color name "non-existent"} +test button-1.213 {configuration option: "selectcolor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -selectcolor #110022 + .r cget -selectcolor +} -cleanup { + destroy .r +} -result {#110022} +test button-1.214 {configuration option: "selectcolor" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -selectcolor non-existent +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown color name "non-existent"} + +test button-1.215 {configuration option: "selectimage" for checkbutton} -constraints { + testImageType +} -setup { + image create test image1 + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -selectimage image1 + .c cget -selectimage +} -cleanup { + destroy .c + image delete image1 +} -result {image1} +test button-1.216 {configuration option: "selectimage" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -selectimage bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {image "bogus" doesn't exist} +test button-1.217 {configuration option: "selectimage" for radiobutton} -constraints { + testImageType +} -setup { + image create test image1 + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -selectimage image1 + .r cget -selectimage +} -cleanup { + destroy .r + image delete image1 +} -result {image1} +test button-1.218 {configuration option: "selectimage" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -selectimage bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {image "bogus" doesn't exist} + +test button-1.219 {configuration option: "state" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -state normal + .l cget -state +} -cleanup { + destroy .l +} -result {normal} +test button-1.220 {configuration option: "state" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -state bogus +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal} +test button-1.221 {configuration option: "state" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -state normal + .b cget -state +} -cleanup { + destroy .b +} -result {normal} +test button-1.222 {configuration option: "state" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -state bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal} +test button-1.223 {configuration option: "state" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -state normal + .c cget -state +} -cleanup { + destroy .c +} -result {normal} +test button-1.224 {configuration option: "state" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -state bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal} +test button-1.225 {configuration option: "state" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -state normal + .r cget -state +} -cleanup { + destroy .r +} -result {normal} +test button-1.226 {configuration option: "state" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -state bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad state "bogus": must be active, disabled, or normal} + +test button-1.227 {configuration option: "takefocus" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -takefocus "any string" + .l cget -takefocus +} -cleanup { + destroy .l +} -result {any string} +test button-1.228 {configuration option: "takefocus" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -takefocus "any string" + .b cget -takefocus +} -cleanup { + destroy .b +} -result {any string} +test button-1.229 {configuration option: "takefocus" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -takefocus "any string" + .c cget -takefocus +} -cleanup { + destroy .c +} -result {any string} +test button-1.230 {configuration option: "takefocus" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -takefocus "any string" + .r cget -takefocus +} -cleanup { + destroy .r +} -result {any string} + +test button-1.231 {configuration option: "text" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -text "Sample text" + .l cget -text +} -cleanup { + destroy .l +} -result {Sample text} +test button-1.232 {configuration option: "text" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -text "Sample text" + .b cget -text +} -cleanup { + destroy .b +} -result {Sample text} +test button-1.233 {configuration option: "text" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -text "Sample text" + .c cget -text +} -cleanup { + destroy .c +} -result {Sample text} +test button-1.234 {configuration option: "text" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -text "Sample text" + .r cget -text +} -cleanup { + destroy .r +} -result {Sample text} + +test button-1.235 {configuration option: "textvariable" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -textvariable i + .l cget -textvariable +} -cleanup { + destroy .l +} -result {i} +test button-1.236 {configuration option: "textvariable" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -textvariable i + .b cget -textvariable +} -cleanup { + destroy .b +} -result {i} +test button-1.237 {configuration option: "textvariable" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -textvariable i + .c cget -textvariable +} -cleanup { + destroy .c +} -result {i} +test button-1.238 {configuration option: "textvariable" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -textvariable i + .r cget -textvariable +} -cleanup { + destroy .r +} -result {i} + +test button-1.239 {configuration option: "tristateimage" for checkbutton} -constraints { + testImageType +} -setup { + image create test image1 + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -tristateimage image1 + .c cget -tristateimage +} -cleanup { + destroy .c + image delete image1 +} -result {image1} +test button-1.240 {configuration option: "tristateimage" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -tristateimage bogus +} -cleanup { + destroy .c +} -returnCodes {error} -result {image "bogus" doesn't exist} +test button-1.241 {configuration option: "tristateimage" for radiobutton} -constraints { + testImageType +} -setup { + image create test image1 + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -tristateimage image1 + .r cget -tristateimage +} -cleanup { + destroy .r + image delete image1 +} -result {image1} +test button-1.242 {configuration option: "tristateimage" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -tristateimage bogus +} -cleanup { + destroy .r +} -returnCodes {error} -result {image "bogus" doesn't exist} + +test button-1.243 {configuration option: "underline" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -underline 5 + .l cget -underline +} -cleanup { + destroy .l +} -result {5} +test button-1.244 {configuration option: "underline" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -underline 3p +} -cleanup { + destroy .l +} -returnCodes {error} -result {expected integer but got "3p"} +test button-1.245 {configuration option: "underline" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -underline 5 + .b cget -underline +} -cleanup { + destroy .b +} -result {5} +test button-1.246 {configuration option: "underline" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -underline 3p +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "3p"} +test button-1.247 {configuration option: "underline" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -underline 5 + .c cget -underline +} -cleanup { + destroy .c +} -result {5} +test button-1.248 {configuration option: "underline" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -underline 3p +} -cleanup { + destroy .c +} -returnCodes {error} -result {expected integer but got "3p"} +test button-1.249 {configuration option: "underline" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -underline 5 + .r cget -underline +} -cleanup { + destroy .r +} -result {5} +test button-1.250 {configuration option: "underline" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -underline 3p +} -cleanup { + destroy .r +} -returnCodes {error} -result {expected integer but got "3p"} + +test button-1.251 {configuration option: "tristatevalue" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -tristatevalue unknowable + .c cget -tristatevalue +} -cleanup { + destroy .c +} -result {unknowable} +test button-1.252 {configuration option: "tristatevalue" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -tristatevalue unknowable + .r cget -tristatevalue +} -cleanup { + destroy .r +} -result {unknowable} + +test button-1.253 {configuration option: "value" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -value anyString + .r cget -value +} -cleanup { + destroy .r +} -result {anyString} + +test button-1.254 {configuration option: "width" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -width 402 + .l cget -width +} -cleanup { + destroy .l +} -result {402} +test button-1.255 {configuration option: "width" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -width 3p +} -cleanup { + destroy .l +} -returnCodes {error} -result {expected integer but got "3p"} +test button-1.256 {configuration option: "width" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -width 402 + .b cget -width +} -cleanup { + destroy .b +} -result {402} +test button-1.257 {configuration option: "width" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -width 3p +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "3p"} +test button-1.258 {configuration option: "width" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -width 402 + .c cget -width +} -cleanup { + destroy .c +} -result {402} +test button-1.259 {configuration option: "width" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -width 3p +} -cleanup { + destroy .c +} -returnCodes {error} -result {expected integer but got "3p"} +test button-1.260 {configuration option: "width" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -width 402 + .r cget -width +} -cleanup { + destroy .r +} -result {402} +test button-1.261 {configuration option: "width" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -width 3p +} -cleanup { + destroy .r +} -returnCodes {error} -result {expected integer but got "3p"} + +test button-1.262 {configuration option: "wraplength" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -wraplength 100 + .l cget -wraplength +} -cleanup { + destroy .l +} -result {100} +test button-1.263 {configuration option: "wraplength" for label} -setup { + label .l -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .l + update +} -body { + .l configure -wraplength 6x +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad screen distance "6x"} +test button-1.264 {configuration option: "wraplength" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -wraplength 100 + .b cget -wraplength +} -cleanup { + destroy .b +} -result {100} +test button-1.265 {configuration option: "wraplength" for button} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .b + update +} -body { + .b configure -wraplength 6x +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "6x"} +test button-1.266 {configuration option: "wraplength" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -wraplength 100 + .c cget -wraplength +} -cleanup { + destroy .c +} -result {100} +test button-1.267 {configuration option: "wraplength" for checkbutton} -setup { + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .c + update +} -body { + .c configure -wraplength 6x +} -cleanup { + destroy .c +} -returnCodes {error} -result {bad screen distance "6x"} +test button-1.268 {configuration option: "wraplength" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -wraplength 100 + .r cget -wraplength +} -cleanup { + destroy .r +} -result {100} +test button-1.269 {configuration option: "wraplength" for radiobutton} -setup { + radiobutton .r -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .r + update +} -body { + .r configure -wraplength 6x +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad screen distance "6x"} + +test button-1.270 {configuration options} -body { +# Additional check to make sure that -selectcolor may be empty in +# checkbox widgets + checkbutton .c .c configure -selectcolor {} -} {} - -test button-3.1 {ButtonCreate - not enough cd ../unix -} { - list [catch {button} msg] $msg -} {1 {wrong # args: should be "button pathName ?options?"}} -test button-3.2 {ButtonCreate procedure - setting label class} { - catch {destroy .x} +} -cleanup { + destroy .c +} -result {} + +# ex-tests 3.* +test button-2.1 {ButtonCreate - not enough arguments} -body { + button +} -returnCodes {error} -result {wrong # args: should be "button pathName ?-option value ...?"} + +test button-2.2 {ButtonCreate procedure - setting label class} -body { label .x winfo class .x -} {Label} -test button-3.3 {ButtonCreate - setting button class} { - catch {destroy .x} +} -cleanup { + destroy .x +} -result {Label} +test button-2.3 {ButtonCreate - setting button class} -body { button .x winfo class .x -} {Button} -test button-3.4 {ButtonCreate - setting checkbutton class} { - catch {destroy .x} +} -cleanup { + destroy .x +} -result {Button} +test button-2.4 {ButtonCreate - setting checkbutton class} -body { checkbutton .x winfo class .x -} {Checkbutton} -test button-3.5 {ButtonCreate - setting radiobutton class} { - catch {destroy .x} +} -cleanup { + destroy .x +} -result {Checkbutton} +test button-2.5 {ButtonCreate - setting radiobutton class} -body { radiobutton .x winfo class .x -} {Radiobutton} -rename button gorp -test button-3.6 {ButtonCreate - setting class} { - catch {destroy .x} +} -cleanup { + destroy .x +} -result {Radiobutton} +test button-2.6 {ButtonCreate - setting class} -body { + rename button gorp gorp .x winfo class .x -} {Button} -rename gorp button -test button-3.7 {ButtonCreate - bad window name} { - list [catch {button foo} msg] $msg -} {1 {bad window path name "foo"}} -test button-3.8 {ButtonCreate procedure - error in default option value} { - catch {destroy .funny} +} -cleanup { + destroy .x + rename gorp button +} -result {Button} + +test button-2.7 {ButtonCreate - bad window name} -body { + button foo +} -cleanup { + destroy foo +} -returnCodes {error} -result {bad window path name "foo"} +######### test ex 3.8 +test button-2.8 {ButtonCreate procedure - error in default option value} -body { option add *funny.background bogus - list [catch {button .funny} msg] $msg $errorInfo -} {1 {unknown color name "bogus"} {unknown color name "bogus" + button .funny +} -cleanup { + option clear + destroy .funny +} -returnCodes {error} -result {unknown color name "bogus"} +test button-2.9 {ButtonCreate procedure - error in default option value} -body { + option add *funny.background bogus + catch {button .funny} + return $errorInfo +} -cleanup { + option clear + destroy .funny +} -result {unknown color name "bogus" (database entry for "-background" in widget ".funny") invoked from within -"button .funny"}} -test button-3.9 {ButtonCreate procedure - option error} { - catch {destroy .x} - list [catch {button .x -gorp foo} msg] $msg [winfo exists .x] -} {1 {unknown option "-gorp"} 0} -test button-3.10 {ButtonCreate procedure - return value} { - catch {destroy .abcd} +"button .funny"} + +test button-2.10 {ButtonCreate procedure - option error} -body { + button .x -gorp foo +} -cleanup { + destroy .x +} -returnCodes {error} -result {unknown option "-gorp"} +test button-2.11 {ButtonCreate procedure - option error} -body { + catch {button .x -gorp foo} + winfo exists .x +} -cleanup { + destroy .x +} -result 0 +######### ex 3.10 +test button-2.12 {ButtonCreate procedure - return value} -body { set x [button .abcd] - destroy .abc - set x -} {.abcd} - -test button-4.1 {ButtonWidgetCmd - too few arguments} { - list [catch {.b} msg] $msg -} {1 {wrong # args: should be ".b option ?arg arg ...?"}} -test button-4.2 {ButtonWidgetCmd - bad option name} { - list [catch {.b c} msg] $msg -} {1 {ambiguous option "c": must be cget, configure, flash, or invoke}} -test button-4.3 {ButtonWidgetCmd - bad option name} { - list [catch {.b bogus} msg] $msg -} {1 {bad option "bogus": must be cget, configure, flash, or invoke}} -test button-4.4 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.b cget a b} msg] $msg -} {1 {wrong # args: should be ".b cget option"}} -test button-4.5 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.b cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test button-4.6 {ButtonWidgetCmd procedure, "cget" option} { - .b configure -highlightthickness 3 - .b cget -highlightthickness -} {3} -test button-4.7 {ButtonWidgetCmd procedure, "cget" option} { - catch {.l cget -disabledforeground} -} {0} -test button-4.8 {ButtonWidgetCmd procedure, "cget" option} { - catch {.b cget -disabledforeground} -} {0} -test button-4.9 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.b cget -variable} msg] $msg -} {1 {unknown option "-variable"}} -test button-4.10 {ButtonWidgetCmd procedure, "cget" option} { - catch {.c cget -variable} -} {0} -test button-4.11 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.c cget -value} msg] $msg -} {1 {unknown option "-value"}} -test button-4.12 {ButtonWidgetCmd procedure, "cget" option} { - catch {.r cget -value} -} {0} -test button-4.13 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.r cget -onvalue} msg] $msg -} {1 {unknown option "-onvalue"}} -test button-4.14 {ButtonWidgetCmd procedure, "configure" option} { + return $x +} -cleanup { + destroy .abcd +} -result {.abcd} + +######### ex 4.* +test button-3.1 {ButtonWidgetCmd - too few arguments} -body { + button .b + .b +} -cleanup { + destroy .b +} -returnCodes {error} -result {wrong # args: should be ".b option ?arg ...?"} +test button-3.2 {ButtonWidgetCmd - bad option name} -body { + button .b + .b c +} -cleanup { + destroy .b +} -returnCodes {error} -result {ambiguous option "c": must be cget, configure, flash, or invoke} +test button-3.3 {ButtonWidgetCmd - bad option name} -body { + button .b + .b bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad option "bogus": must be cget, configure, flash, or invoke} +test button-3.4 {ButtonWidgetCmd procedure, "cget" option} -body { + button .b + .b cget a b +} -cleanup { + destroy .b +} -returnCodes {error} -result {wrong # args: should be ".b cget option"} +test button-3.5 {ButtonWidgetCmd procedure, "cget" option} -body { + button .b + .b cget -gorp +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown option "-gorp"} + +#ex 4.7 +test button-3.6 {ButtonWidgetCmd procedure, "cget" option} -body { + label .l + .l cget -disabledforeground +} -cleanup { + destroy .l +} -returnCodes {ok} -match {glob} -result {*} +test button-3.7 {ButtonWidgetCmd procedure, "cget" option} -body { + button .b + .b cget -disabledforeground +} -cleanup { + destroy .b +} -returnCodes {ok} -match {glob} -result {*} +test button-3.8 {ButtonWidgetCmd procedure, "cget" option} -body { + button .b + .b cget -variable +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown option "-variable"} + +test button-3.9 {ButtonWidgetCmd procedure, "cget" option} -body { + checkbutton .c + .c cget -variable +} -cleanup { + destroy .c +} -returnCodes {ok} -match {glob} -result {*} +test button-3.10 {ButtonWidgetCmd procedure, "cget" option} -body { + checkbutton .c + .c cget -value +} -cleanup { + destroy .c +} -returnCodes {error} -result {unknown option "-value"} + +test button-3.11 {ButtonWidgetCmd procedure, "cget" option} -body { + radiobutton .r + .r cget -value +} -cleanup { + destroy .r +} -returnCodes {ok} -match {glob} -result {*} +test button-3.12 {ButtonWidgetCmd procedure, "cget" option} -body { + radiobutton .r + .r cget -onvalue +} -cleanup { + destroy .r +} -returnCodes {error} -result {unknown option "-onvalue"} + +# ex 4.6 +test button-3.13 {ButtonWidgetCmd procedure, "configure" option} -body { + button .b -highlightthickness 3 + lindex [.b configure -highlightthickness] 4 +} -cleanup { + destroy .b +} -result {3} +test button-3.14 {ButtonWidgetCmd procedure, "configure" option} -body { + checkbutton .c llength [.c configure] -} {41} -test button-4.15 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.b configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test button-4.16 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.b co -bg #ffffff -fg} msg] $msg -} {1 {value for "-fg" missing}} -test button-4.17 {ButtonWidgetCmd procedure, "configure" option} { +} -cleanup { + destroy .c +} -result {41} +test button-3.15 {ButtonWidgetCmd procedure, "configure" option} -body { + button .b + .b configure -gorp +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown option "-gorp"} +test button-3.16 {ButtonWidgetCmd procedure, "configure" option} -setup { + button .b +} -body { + .b co -bg #ffffff -fg +} -cleanup { + destroy .b +} -returnCodes {error} -result {value for "-fg" missing} +test button-3.17 {ButtonWidgetCmd procedure, "configure" option} -setup { + button .b +} -body { .b configure -fg #123456 .b configure -bg #654321 lindex [.b configure -fg] 4 -} {#123456} -.c configure -variable value -onvalue 1 -offvalue 0 -.r configure -variable value2 -value red -test button-4.18 {ButtonWidgetCmd procedure, "deselect" option} { - list [catch {.c deselect foo} msg] $msg -} {1 {wrong # args: should be ".c deselect"}} -test button-4.19 {ButtonWidgetCmd procedure, "deselect" option} { - list [catch {.l deselect} msg] $msg -} {1 {bad option "deselect": must be cget or configure}} -test button-4.20 {ButtonWidgetCmd procedure, "deselect" option} { - list [catch {.b deselect} msg] $msg -} {1 {bad option "deselect": must be cget, configure, flash, or invoke}} -test button-4.21 {ButtonWidgetCmd procedure, "deselect" option} { - set value 1 +} -cleanup { + destroy .b +} -result {#123456} +test button-3.18 {ButtonWidgetCmd procedure, "deselect" option} -body { + checkbutton .c + .c deselect foo +} -cleanup { + destroy .c +} -returnCodes {error} -result {wrong # args: should be ".c deselect"} +test button-3.19 {ButtonWidgetCmd procedure, "deselect" option} -body { + label .l + .l deselect +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad option "deselect": must be cget or configure} +test button-3.20 {ButtonWidgetCmd procedure, "deselect" option} -body { + button .b + .b deselect +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad option "deselect": must be cget, configure, flash, or invoke} + +test button-3.21 {ButtonWidgetCmd procedure, "deselect" option} -body { + checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 + set checkvar 1 .c d - set value -} {0} -test button-4.22 {ButtonWidgetCmd procedure, "deselect" option} { - set value2 green + return $checkvar +} -cleanup { + destroy .c +} -result {0} +test button-3.22 {ButtonWidgetCmd procedure, "deselect" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar green .r deselect - set value2 -} {green} -test button-4.23 {ButtonWidgetCmd procedure, "deselect" option} { - set value2 red + return $radiovar +} -cleanup { + destroy .r +} -result {green} +test button-3.23 {ButtonWidgetCmd procedure, "deselect" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar red .r deselect - set value2 -} {} -test button-4.24 {ButtonWidgetCmd procedure, "deselect" option} -body { - set value 1 - trace variable value w bogusTrace - set result [list [catch {.c deselect} msg] $msg $errorInfo $value] - trace vdelete value w bogusTrace - set result -} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted + return $radiovar +} -cleanup { + destroy .r +} -result {} + +test button-3.24 {ButtonWidgetCmd procedure, "deselect" option} -body { + checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 + set checkvar 1 + trace variable checkvar w bogusTrace + .c deselect +} -cleanup { + destroy .c + trace vdelete checkvar w bogusTrace +} -returnCodes {error} -result {can't set "checkvar": trace aborted} +test button-3.25 {ButtonWidgetCmd procedure, "deselect" option} -body { + checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 + set checkvar 1 + trace variable checkvar w bogusTrace + catch {.c deselect} + list $errorInfo $checkvar +} -cleanup { + trace vdelete checkvar w bogusTrace + destroy .c +} -match {glob} -result {{*trace aborted while executing * ".c deselect"} 0} -test button-4.25 {ButtonWidgetCmd procedure, "deselect" option} -body { - set value2 red - trace variable value2 w bogusTrace - set result [list [catch {.r deselect} msg] $msg $errorInfo $value2] - trace vdelete value2 w bogusTrace - set result -} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted +test button-3.26 {ButtonWidgetCmd procedure, "deselect" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar red + trace variable radiovar w bogusTrace + .r deselect +} -cleanup { + destroy .r + trace vdelete radiovar w bogusTrace +} -match {glob} -returnCodes {error} -result {can't set "radiovar": trace aborted} +test button-3.27 {ButtonWidgetCmd procedure, "deselect" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar red + trace variable radiovar w bogusTrace + catch {.r deselect} + list $errorInfo $radiovar +} -cleanup { + destroy .r + trace vdelete radiovar w bogusTrace +} -match glob -result {{*trace aborted while executing * ".r deselect"} {}} -test button-4.26 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.b flash foo} msg] $msg -} {1 {wrong # args: should be ".b flash"}} -test button-4.27 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.l flash} msg] $msg -} {1 {bad option "flash": must be cget or configure}} -test button-4.28 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.b flash} msg] $msg -} {0 {}} -test button-4.29 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.c flash} msg] $msg -} {0 {}} -test button-4.30 {ButtonWidgetCmd procedure, "flash" option} { - list [catch {.r f} msg] $msg -} {0 {}} -test button-4.31 {ButtonWidgetCmd procedure, "invoke" option} { - list [catch {.b invoke foo} msg] $msg -} {1 {wrong # args: should be ".b invoke"}} -test button-4.32 {ButtonWidgetCmd procedure, "invoke" option} { - list [catch {.l invoke} msg] $msg -} {1 {bad option "invoke": must be cget or configure}} -test button-4.33 {ButtonWidgetCmd procedure, "invoke" option} { + +test button-3.28 {ButtonWidgetCmd procedure, "flash" option} -body { + button .b + .b flash foo +} -cleanup { + destroy .b +} -returnCodes {error} -result {wrong # args: should be ".b flash"} +test button-3.29 {ButtonWidgetCmd procedure, "flash" option} -body { + label .l + .l flash +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad option "flash": must be cget or configure} +test button-3.30 {ButtonWidgetCmd procedure, "flash" option} -body { + button .b + catch {.b flash} +} -cleanup { + destroy .b +} -returnCodes {ok} -match {glob} -result {*} +test button-3.31 {ButtonWidgetCmd procedure, "flash" option} -body { + checkbutton .c + catch {.c flash} +} -cleanup { + destroy .c +} -returnCodes {ok} -match {glob} -result {*} +test button-3.32 {ButtonWidgetCmd procedure, "flash" option} -body { + radiobutton .r + catch {.r f} +} -cleanup { + destroy .r +} -returnCodes {ok} -match {glob} -result {*} + +test button-3.33 {ButtonWidgetCmd procedure, "invoke" option} -body { + label .l + .l invoke +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad option "invoke": must be cget or configure} +test button-3.34 {ButtonWidgetCmd procedure, "invoke" option} -body { + button .b + .b invoke foo +} -cleanup { + destroy .b +} -returnCodes {error} -result {wrong # args: should be ".b invoke"} +test button-3.35 {ButtonWidgetCmd procedure, "invoke" option} -body { + button .b .b configure -command {set x invoked} set x "not invoked" .b invoke - set x -} {invoked} -test button-4.34 {ButtonWidgetCmd procedure, "invoke" option} { + return $x +} -cleanup { + destroy .b +} -result {invoked} +test button-3.36 {ButtonWidgetCmd procedure, "invoke" option} -body { + button .b .b configure -command {set x invoked} -state disabled set x "not invoked" .b invoke - set x -} {not invoked} -test button-4.35 {ButtonWidgetCmd procedure, "invoke" option} { - set value bogus - .c configure -command {set x invoked} -variable value -onvalue 1 \ - -offvalue 0 + return $x +} -cleanup { + destroy .b +} -result {not invoked} +test button-3.37 {ButtonWidgetCmd procedure, "invoke" option} -body { + checkbutton .c -variable checkvar -onvalue 1 -offvalue 0 \ + -command {set x invoked} + set checkvar bogus set x "not invoked" .c invoke - list $x $value -} {invoked 1} -test button-4.36 {ButtonWidgetCmd procedure, "invoke" option} { - set value2 green - .r configure -command {set x invoked} -variable value2 -value red + list $x $checkvar +} -cleanup { + destroy .c +} -result {invoked 1} +test button-3.38 {ButtonWidgetCmd procedure, "invoke" option} -body { + radiobutton .r -command {set x invoked} -variable radiovar -value red + set radiovar green set x "not invoked" .r i - list $x $value2 -} {invoked red} -test button-4.37 {ButtonWidgetCmd procedure, "select" option} { - list [catch {.l select} msg] $msg -} {1 {bad option "select": must be cget or configure}} -test button-4.38 {ButtonWidgetCmd procedure, "select" option} { - list [catch {.b select} msg] $msg -} {1 {bad option "select": must be cget, configure, flash, or invoke}} -test button-4.39 {ButtonWidgetCmd procedure, "select" option} { - list [catch {.c select foo} msg] $msg -} {1 {wrong # args: should be ".c select"}} -test button-4.40 {ButtonWidgetCmd procedure, "select" option} { - set value bogus - .c configure -command {} -variable value -onvalue lovely -offvalue 0 + list $x $radiovar +} -cleanup { + destroy .r +} -result {invoked red} + +test button-3.39 {ButtonWidgetCmd procedure, "select" option} -body { + label .l + .l select +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad option "select": must be cget or configure} +test button-3.40 {ButtonWidgetCmd procedure, "select" option} -body { + button .b + .b select +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad option "select": must be cget, configure, flash, or invoke} +test button-3.41 {ButtonWidgetCmd procedure, "select" option} -body { + checkbutton .c + .c select foo +} -cleanup { + destroy .c +} -returnCodes {error} -result {wrong # args: should be ".c select"} +test button-3.42 {ButtonWidgetCmd procedure, "select" option} -body { + checkbutton .c -variable checkvar -onvalue lovely -offvalue 0 + set checkvar bogus .c s - set value -} {lovely} -test button-4.41 {ButtonWidgetCmd procedure, "select" option} { - set value2 green - .r configure -command {} -variable value2 -value red + return $checkvar +} -cleanup { + destroy .c +} -result {lovely} +test button-3.43 {ButtonWidgetCmd procedure, "select" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar green + .r select + return $radiovar +} -cleanup { + destroy .r +} -result {red} +test button-3.44 {ButtonWidgetCmd procedure, "select" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar yellow + trace variable radiovar w bogusTrace .r select - set value2 -} {red} -test button-4.42 {ButtonWidgetCmd procedure, "select" option} -body { - set value2 yellow - trace variable value2 w bogusTrace - set result [list [catch {.r select} msg] $msg $errorInfo $value2] - trace vdelete value2 w bogusTrace - set result -} -match glob -result {1 {can't set "value2": trace aborted} {*trace aborted +} -cleanup { + destroy .r + trace vdelete radiovar w bogusTrace +} -returnCodes {error} -result {can't set "radiovar": trace aborted} +test button-3.45 {ButtonWidgetCmd procedure, "select" option} -body { + radiobutton .r -variable radiovar -value red + set radiovar yellow + trace variable radiovar w bogusTrace + catch {.r select} + list $errorInfo $radiovar +} -cleanup { + destroy .r + trace vdelete radiovar w bogusTrace +} -match {glob} -result {{*trace aborted while executing * ".r select"} red} -test button-4.43 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.l toggle} msg] $msg -} {1 {bad option "toggle": must be cget or configure}} -test button-4.44 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.b toggle} msg] $msg -} {1 {bad option "toggle": must be cget, configure, flash, or invoke}} -test button-4.45 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.r toggle} msg] $msg -} {1 {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select}} -test button-4.46 {ButtonWidgetCmd procedure, "toggle" option} { - list [catch {.c toggle foo} msg] $msg -} {1 {wrong # args: should be ".c toggle"}} -test button-4.47 {ButtonWidgetCmd procedure, "toggle" option} { - set value bogus - .c configure -command {} -variable value -onvalue sunshine -offvalue rain + +# ex 4.43 +test button-3.46 {ButtonWidgetCmd procedure, "toggle" option} -body { + label .l + .l toggle +} -cleanup { + destroy .l +} -returnCodes {error} -result {bad option "toggle": must be cget or configure} +test button-3.47 {ButtonWidgetCmd procedure, "toggle" option} -body { + button .b + .b toggle +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad option "toggle": must be cget, configure, flash, or invoke} +test button-3.48 {ButtonWidgetCmd procedure, "toggle" option} -body { + radiobutton .r + .r toggle +} -cleanup { + destroy .r +} -returnCodes {error} -result {bad option "toggle": must be cget, configure, deselect, flash, invoke, or select} +test button-3.49 {ButtonWidgetCmd procedure, "toggle" option} -body { + checkbutton .c + .c toggle foo +} -cleanup { + destroy .c +} -returnCodes {error} -result {wrong # args: should be ".c toggle"} +test button-3.50 {ButtonWidgetCmd procedure, "toggle" option} -body { + set checkvar bogus + checkbutton .c -variable checkvar -onvalue sunshine -offvalue rain .c toggle - set result $value + set result $checkvar .c toggle - lappend result $value + lappend result $checkvar .c toggle - lappend result $value -} {sunshine rain sunshine} -test button-4.48 {ButtonWidgetCmd procedure, "toggle" option} -body { - .c configure -onvalue xyz -offvalue abc - set value xyz - trace variable value w bogusTrace - set result [list [catch {.c toggle} msg] $msg $errorInfo $value] - trace vdelete value w bogusTrace - set result -} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted + lappend result $checkvar + return $result +} -cleanup { + destroy .c +} -result {sunshine rain sunshine} +test button-3.51 {ButtonWidgetCmd procedure, "toggle" option} -body { + checkbutton .c -variable checkvar -onvalue xyz -offvalue abc + set checkvar xyz + trace variable checkvar w bogusTrace + .c toggle +} -cleanup { + destroy .c + trace vdelete checkvar w bogusTrace +} -returnCodes {error} -result {can't set "checkvar": trace aborted} +test button-3.52 {ButtonWidgetCmd procedure, "toggle" option} -body { + checkbutton .c -variable checkvar -onvalue xyz -offvalue abc + set checkvar xyz + trace variable checkvar w bogusTrace + catch {.c toggle} + list $errorInfo $checkvar +} -cleanup { + trace vdelete checkvar w bogusTrace + destroy .c +} -match {glob} -result {{*trace aborted while executing * ".c toggle"} abc} -test button-4.49 {ButtonWidgetCmd procedure, "toggle" option} -body { - .c configure -onvalue xyz -offvalue abc - set value abc - trace variable value w bogusTrace - set result [list [catch {.c toggle} msg] $msg $errorInfo $value] - trace vdelete value w bogusTrace - set result -} -match glob -result {1 {can't set "value": trace aborted} {*trace aborted +test button-3.53 {ButtonWidgetCmd procedure, "toggle" option} -body { + checkbutton .c -variable checkvar -onvalue xyz -offvalue abc + set checkvar abc + trace variable checkvar w bogusTrace + .c toggle +} -cleanup { + trace vdelete checkvar w bogusTrace + destroy .c +} -returnCodes {error} -result {can't set "checkvar": trace aborted} +test button-3.54 {ButtonWidgetCmd procedure, "toggle" option} -body { + checkbutton .c -variable checkvar -onvalue xyz -offvalue abc + set checkvar abc + trace variable checkvar w bogusTrace + catch {.c toggle} + list $errorInfo $checkvar +} -cleanup { + trace vdelete checkvar w bogusTrace + destroy .c +} -match {glob} -result {{*trace aborted while executing * ".c toggle"} xyz} -test button-4.50 {ButtonWidgetCmd procedure, "toggle" option} { - catch {unset value}; set value(1) 1; - set result [list [catch {.c toggle} msg] $msg $errorInfo] - unset value; - set result -} {1 {can't set "value": variable is array} {can't set "value": variable is array +test button-3.55 {ButtonWidgetCmd procedure, "toggle" option} -setup { + unset -nocomplain checkvar +} -body { + checkbutton .c -variable checkvar -onvalue xyz -offvalue abc + unset checkvar + set checkvar(1) 1 + .c toggle +} -cleanup { + destroy .c +} -returnCodes {error} -result {can't set "checkvar": variable is array} +test button-3.56 {ButtonWidgetCmd procedure, "toggle" option} -setup { + unset -nocomplain checkvar +} -body { + checkbutton .c -variable checkvar -onvalue xyz -offvalue abc + unset checkvar + set checkvar(1) 1 + catch {.c toggle} + return $errorInfo +} -cleanup { + destroy .c +} -match {glob} -result {can't set "checkvar": variable is array while executing -".c toggle"}} +".c toggle"} -test button-5.1 {DestroyButton procedure} testImageType { +test button-4.1 {DestroyButton procedure} -constraints { + testImageType +} -setup { image create test image1 + unset -nocomplain x +} -body { button .b1 -image image1 button .b2 -fg #ff0000 -text "Button 2" button .b3 -state active -text "Button 3" @@ -435,402 +3209,709 @@ test button-5.1 {DestroyButton procedure} testImageType { checkbutton .b5 -variable x -text "Checkbutton 5" set x 1 pack .b1 .b2 .b3 .b4 .b5 - update - deleteWindows -} {} - -test button-6.1 {ConfigureButton - textvariable trace} { - catch {destroy .b1} - button .b1 -bd 4 -bg green - catch {.b1 configure -bd 7 -bg green -fg bogus} - list [catch {.b1 configure -bd 7 -bg red -fg bogus} msg] \ - $msg [.b1 cget -bd] [.b1 cget -bg] -} {1 {unknown color name "bogus"} 4 green} -test button-6.2 {ConfigureButton - textvariable trace} { - catch {destroy .b1} + update + deleteWindows +} -cleanup { + destroy .b1 .b2 .b3 .b4 .b5 + image delete image1 +} -result {} + +test button-5.1 {ConfigureButton - textvariable trace} -body { + button .b -bd 4 -bg green + .b configure -bd 7 -bg red -fg bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {unknown color name "bogus"} +test button-5.2 {ConfigureButton - textvariable trace} -body { + button .b -bd 4 -bg green + catch {.b configure -bd 7 -bg red -fg bogus} + list [.b cget -bd] [.b cget -bg] +} -cleanup { + destroy .b +} -result {4 green} +test button-5.3 {ConfigureButton - textvariable trace} -body { + button .b -textvariable x set x From-x set y From-y - button .b1 -textvariable x - .b1 configure -textvariable y + .b configure -textvariable y set x New - lindex [.b1 configure -text] 4 -} {From-y} -test button-6.2a {ConfigureButton - variable traces} { - catch {destroy .b1} - catch {unset x} - checkbutton .b1 -variable x + lindex [.b configure -text] 4 +} -cleanup { + destroy .b +} -result {From-y} +test button-5.4 {ConfigureButton - variable trace} -body { ;# ex 6.2a + checkbutton .c -variable x set x 1 set y 1 - .b1 configure -textvariable y + .c configure -textvariable y set x 0 - .b1 toggle - set y -} {1} -test button-6.3 {ConfigureButton - image handling} testImageType { - catch {destroy .b1} - eval image delete [image names] + .c toggle + return $y +} -cleanup { + destroy .c +} -result {1} + +test button-5.5 {ConfigureButton - image handling} -constraints { + testImageType +} -setup { + imageCleanup image create test image1 image create test image2 - button .b1 -image image1 +} -body { + button .b -image image1 image delete image1 - .b1 configure -image image2 - image names -} {image2} -test button-6.5 {ConfigureButton - default value for variable} { - catch {destroy .b1} - checkbutton .b1 - .b1 cget -variable -} {b1} -test button-6.6 {ConfigureButton - setting selected state from variable} { - catch {destroy .b1} + .b configure -image image2 + imageNames +} -cleanup { + destroy .b + imageCleanup +} -result {image2} + +test button-5.6 {ConfigureButton - default value for variable} -body { + checkbutton .c + .c cget -variable +} -cleanup { + destroy .c +} -result {c} +test button-5.7 {ConfigureButton - setting selected state from variable} -body { set x 0 set y Shiny - checkbutton .b1 -variable x - .b1 configure -variable y -onvalue Shiny - .b1 toggle - set y -} 0 -test button-6.7 {ConfigureButton - setting selected state from variable} { - catch {destroy .b1} - catch {unset x} - checkbutton .b1 -variable x -offvalue Bogus - set x -} Bogus -test button-6.8 {ConfigureButton - setting selected state from variable} { - catch {destroy .b1} - catch {unset x} - radiobutton .b1 -variable x - set x -} {} -test button-6.9 {ConfigureButton - error in setting variable} { - catch {destroy .b1} - catch {unset x} + checkbutton .c -variable x + .c configure -variable y -onvalue Shiny + .c toggle + return $y +} -cleanup { + destroy .c +} -result {0} +test button-5.8 {ConfigureButton - setting selected state from variable} -setup { + unset -nocomplain x +} -body { + checkbutton .c -variable x -offvalue Bogus + return $x +} -cleanup { + destroy .c +} -result {Bogus} + +test button-5.9 {ConfigureButton - setting selected state from variable} -setup { + unset -nocomplain x +} -body { + radiobutton .r -variable x + return $x +} -cleanup { + destroy .r +} -result {} + +test button-5.10 {ConfigureButton - error in setting variable} -setup { + unset -nocomplain x +} -body { trace variable x w bogusTrace - set result [list [catch {radiobutton .b1 -variable x} msg] $msg] + radiobutton .r -variable x +} -cleanup { + destroy .r trace vdelete x w bogusTrace - set result -} {1 {can't set "x": trace aborted}} -test button-6.10 {ConfigureButton - bad image name} { - catch {destroy .b1} - list [catch {button .b1 -image bogus} msg] $msg -} {1 {image "bogus" doesn't exist}} -test button-6.11 {ConfigureButton - setting variable from current text value} { - catch {destroy .b1} - catch {unset x} - button .b1 -textvariable x -text "Button 1" - set x -} {Button 1} -test button-6.12 {ConfigureButton - using current value of variable} { - catch {destroy .b1} +} -returnCodes {error} -result {can't set "x": trace aborted} + +test button-5.11 {ConfigureButton - bad image name} -body { + button .b -image bogus +} -cleanup { + destroy .b +} -returnCodes {error} -result {image "bogus" doesn't exist} + +test button-5.12 {ConfigureButton - setting variable from current text value} -setup { + unset -nocomplain x +} -body { + button .b -textvariable x -text "Button 1" + return $x +} -cleanup { + destroy .b +} -result {Button 1} + +test button-5.13 {ConfigureButton - using current value of variable} -body { set x Override - button .b1 -textvariable x -text "Button 1" - set x -} {Override} -test button-6.13 {ConfigureButton - variable handling} { - catch {destroy .b1} - catch {unset x} + button .b -textvariable x -text "Button 1" + return $x +} -cleanup { + destroy .b +} -result {Override} + +test button-5.14 {ConfigureButton - variable handling} -setup { + unset -nocomplain x +} -body { + trace variable x w bogusTrace + radiobutton .r -text foo -textvariable x +} -cleanup { + trace vdelete x w bogusTrace + destroy .r +} -returnCodes {error} -result {can't set "x": trace aborted} +test button-5.15 {ConfigureButton - variable handling} -setup { + unset -nocomplain x +} -body { trace variable x w bogusTrace - set result [list [catch {radiobutton .b1 -text foo -textvariable x} msg] \ - $msg $x] + catch {radiobutton .r -text foo -textvariable x} + return $x +} -cleanup { trace vdelete x w bogusTrace - set result -} {1 {can't set "x": trace aborted} foo} -test button-6.14 {ConfigureButton - -width option} { - catch {destroy .b1} - button .b1 -text "Button 1" - list [catch {.b1 configure -width 1i} msg] $msg $errorInfo -} {1 {expected integer but got "1i"} {expected integer but got "1i" + destroy .r +} -result {foo} + +#ex 6.14 +test button-5.16 {ConfigureButton - -width option} -body { + button .b -text "Button 1" + .b configure -width 1i +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "1i"} +test button-5.17 {ConfigureButton - -width option} -body { + button .b -text "Button 1" + catch {.b configure -width 1i} + return $errorInfo +} -cleanup { + destroy .b +} -result {expected integer but got "1i" (processing -width option) invoked from within -".b1 configure -width 1i"}} -test button-6.15 {ConfigureButton - -height option} { - catch {destroy .b1} - button .b1 -text "Button 1" - list [catch {.b1 configure -height 0.5c} msg] $msg $errorInfo -} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" +".b configure -width 1i"} +test button-5.18 {ConfigureButton - -height option} -body { + button .b -text "Button 1" + .b configure -height 0.5c +} -cleanup { + destroy .b +} -returnCodes {error} -result {expected integer but got "0.5c"} +test button-5.19 {ConfigureButton - -height option} -body { + button .b -text "Button 1" + catch {.b configure -height 0.5c} + return $errorInfo +} -cleanup { + destroy .b +} -result {expected integer but got "0.5c" (processing -height option) invoked from within -".b1 configure -height 0.5c"}} -test button-6.16 {ConfigureButton - -width option} { - catch {destroy .b1} - button .b1 -bitmap questhead - list [catch {.b1 configure -width abc} msg] $msg $errorInfo -} {1 {bad screen distance "abc"} {bad screen distance "abc" +".b configure -height 0.5c"} +#ex 6.16 +test button-5.20 {ConfigureButton - -width option} -body { + button .b -bitmap questhead + .b configure -width abc +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad screen distance "abc"} +test button-5.21 {ConfigureButton - -width option} -body { + button .b -bitmap questhead + catch {.b configure -width abc} + return $errorInfo +} -cleanup { + destroy .b +} -result {bad screen distance "abc" (processing -width option) invoked from within -".b1 configure -width abc"}} -test button-6.17 {ConfigureButton - -height option} testImageType { - catch {destroy .b1} - eval image delete [image names] +".b configure -width abc"} +test button-5.22 {ConfigureButton - -height option} -constraints { + testImageType +} -setup { image create test image1 - button .b1 -image image1 - list [catch {.b1 configure -height 0.5x} msg] $msg $errorInfo -} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" +} -body { + button .b -image image1 + .b configure -height 0.5x +} -cleanup { + destroy .b + image delete image1 +} -returnCodes {error} -result {bad screen distance "0.5x"} +test button-5.23 {ConfigureButton - -height option} -constraints { + testImageType +} -setup { + image create test image1 +} -body { +#ztestImageType + button .b -image image1 + catch {.b configure -height 0.5x} + return $errorInfo +} -cleanup { + destroy .b + image delete image1 +} -result {bad screen distance "0.5x" (processing -height option) invoked from within -".b1 configure -height 0.5x"}} -test button-6.18 {ConfigureButton - computing geometry} {nonPortable fonts} { - catch {destroy .b1} - button .b1 -text "Sample text" -width 10 -height 2 - pack .b1 - set result "[winfo reqwidth .b1] [winfo reqheight .b1]" - .b1 configure -bitmap questhead - lappend result [winfo reqwidth .b1] [winfo reqheight .b1] -} {102 46 20 12} -test button-6.19 {ConfigureButton - computing geometry} { - catch {destroy .b1} - button .b1 -text "Button 1" - set old [winfo reqwidth .b1] - .b1 configure -text "Much longer text" - set new [winfo reqwidth .b1] - expr $old == $new -} {0} - -test button-7.1 {ButtonEventProc procedure} { - catch {destroy .b1} - button .b1 -text "Test Button" -command { - destroy .b1 - set x [list [winfo exists .b1] [info commands .b1]] - } - .b1 invoke - set x -} {0 {}} -test button-7.2 {ButtonEventProc procedure} { - deleteWindows +".b configure -height 0.5x"} +#ex 6.18 +test button-5.24 {ConfigureButton - computing geometry} -constraints { + fonts +} -body { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + .b configure -text "Sample text" -width 10 -height 2 + pack .b + set result "[winfo reqwidth .b] [winfo reqheight .b]" + .b configure -bitmap questhead + lappend result [winfo reqwidth .b] [winfo reqheight .b] +} -cleanup { + destroy .b +} -result {104 46 20 12} + +test button-5.25 {ConfigureButton - computing geometry} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} +} -body { + .b configure -text "Button 1" + set old [winfo reqwidth .b] + .b configure -text "Much longer text" + set new [winfo reqwidth .b] + expr {$old == $new} +} -cleanup { + destroy .b +} -result {0} + +test button-6.1 {ButtonEventProc procedure} -body { + button .b -text "Test Button" -command { + destroy .b + set x [list [winfo exists .b] [info commands .b]] +} + .b invoke + return $x +} -cleanup { + destroy .b +} -result {0 {}} + +test button-6.2 {ButtonEventProc procedure} -setup { + set x {} +} -body { button .b1 -bg #543210 rename .b1 .b2 - set x {} lappend x [winfo children .] lappend x [.b2 cget -bg] destroy .b1 lappend x [info command .b*] [winfo children .] -} {.b1 #543210 {} {}} +} -cleanup { + destroy .b1 +} -result {.b1 #543210 {} {}} -test button-8.1 {ButtonCmdDeletedProc procedure} { - deleteWindows - button .b1 - rename .b1 {} +test button-7.1 {ButtonCmdDeletedProc procedure} -body { + button .b + rename .b {} list [info command .b*] [winfo children .] -} {{} {}} +} -cleanup { + destroy .b +} -result {{} {}} -test button-9.1 {TkInvokeButton procedure} { - catch {destroy .b1} +test button-8.1 {TkInvokeButton procedure} -setup { set x 0 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x set result $x - .b1 invoke + .c invoke lappend result $x - .b1 invoke + .c invoke lappend result $x -} {0 1 0} -test button-9.2 {TkInvokeButton procedure} { - catch {destroy .b1} +} -cleanup { + destroy .c +} -result {0 1 0} + +test button-8.2 {TkInvokeButton procedure} -setup { + set x 0 +} -body { + checkbutton .c -variable x + trace variable x w bogusTrace + .c invoke +} -cleanup { + destroy .c + trace vdelete x w bogusTrace +} -returnCodes {error} -result {can't set "x": trace aborted} +test button-8.3 {TkInvokeButton procedure} -setup { set x 0 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x trace variable x w bogusTrace - set result [list [catch {.b1 invoke} msg] $msg $x] + catch {.c invoke} + return $x +} -cleanup { + destroy .c trace vdelete x w bogusTrace - set result -} {1 {can't set "x": trace aborted} 1} -test button-9.3 {TkInvokeButton procedure} { - catch {destroy .b1} +} -result {1} +test button-8.4 {TkInvokeButton procedure} -setup { set x 1 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x trace variable x w bogusTrace - set result [list [catch {.b1 invoke} msg] $msg $x] + .c invoke +} -cleanup { + destroy .c + trace vdelete x w bogusTrace +} -returnCodes {error} -result {can't set "x": trace aborted} +test button-8.5 {TkInvokeButton procedure} -setup { + set x 1 +} -body { + checkbutton .c -variable x + trace variable x w bogusTrace + catch {.c invoke} + return $x +} -cleanup { + destroy .c trace vdelete x w bogusTrace - set result -} {1 {can't set "x": trace aborted} 0} -test button-9.4 {TkInvokeButton procedure} { - catch {destroy .b1} +} -result {0} + +test button-8.6 {TkInvokeButton procedure} -setup { set x 0 - radiobutton .b1 -variable x -value red +} -body { + radiobutton .r -variable x -value red set result $x - .b1 invoke + .r invoke lappend result $x - .b1 invoke + .r invoke lappend result $x -} {0 red red} -test button-9.5 {TkInvokeButton procedure} -body { - catch {destroy .b1} - radiobutton .b1 -variable x -value red +} -cleanup { + destroy .r +} -result {0 red red} + +test button-8.7 {TkInvokeButton procedure} -body { + radiobutton .r -variable x -value red + set x green + trace variable x w bogusTrace + .r invoke +} -cleanup { + destroy .r + trace vdelete x w bogusTrace +} -returnCodes {error} -result {can't set "x": trace aborted} +test button-8.8 {TkInvokeButton procedure} -body { + radiobutton .r -variable x -value red set x green trace variable x w bogusTrace - set result [list [catch {.b1 invoke} msg] $msg $errorInfo $x] + catch {.r invoke} + list $errorInfo $x +} -cleanup { + destroy .r trace vdelete x w bogusTrace - set result -} -match glob -result {1 {can't set "x": trace aborted} {*trace aborted +} -match {glob} -result {{*trace aborted while executing * -".b1 invoke"} red} -test button-9.6 {TkInvokeButton procedure} { - deleteWindows +".r invoke"} red} + +#ex 9.6 +test button-8.9 {TkInvokeButton procedure} -setup { set result untouched - button .b1 -command {set result invoked} - list [catch {.b1 invoke} msg] $msg $result -} {0 invoked invoked} -test button-9.7 {TkInvokeButton procedure} { - deleteWindows +} -body { + button .b -command {set result invoked} + set msg [.b invoke] + list $msg $result +} -cleanup { + destroy .b +} -result {invoked invoked} +test button-8.10 {TkInvokeButton procedure} -setup { set result untouched set x 0 - checkbutton .b1 -variable x -command {set result "invoked $x"} - list [catch {.b1 invoke} msg] $msg $result -} {0 {invoked 1} {invoked 1}} -test button-9.8 {TkInvokeButton procedure} { - deleteWindows +} -body { + checkbutton .c -variable x -command {set result "invoked $x"} + set msg [.c invoke] + list $msg $result +} -cleanup { + destroy .c +} -result {{invoked 1} {invoked 1}} +test button-8.11 {TkInvokeButton procedure} -setup { set result untouched set x 0 - radiobutton .b1 -variable x -value red -command {set result "invoked $x"} - list [catch {.b1 invoke} msg] $msg $result -} {0 {invoked red} {invoked red}} +} -body { + radiobutton .r -variable x -value red -command {set result "invoked $x"} + set msg [.r invoke] + list $msg $result +} -cleanup { + destroy .r +} -result {{invoked red} {invoked red}} -test button-10.1 {ButtonVarProc procedure} { - deleteWindows +test button-9.1 {ButtonVarProc procedure} -body { set x 1 - checkbutton .b1 -variable x + checkbutton .c -variable x unset x set result [info exists x] - .b1 toggle + .c toggle lappend result $x set x 0 - .b1 toggle + .c toggle lappend result $x -} {0 1 1} -test button-10.2 {ButtonVarProc procedure} { - deleteWindows +} -cleanup { + destroy .c +} -result {0 1 1} +test button-9.2 {ButtonVarProc procedure} -body { set x 0 - checkbutton .b1 -variable x + checkbutton .c -variable x set x 44 - .b1 toggle - set x -} {1} -test button-10.3 {ButtonVarProc procedure} { - deleteWindows + .c toggle + return $x +} -cleanup { + destroy .c +} -result {1} +test button-9.3 {ButtonVarProc procedure} -setup { set x 1 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x set x 44 - .b1 toggle - set x -} {1} -test button-10.4 {ButtonVarProc procedure} { - deleteWindows + .c toggle + return $x +} -cleanup { + destroy .c +} -result {1} +test button-9.4 {ButtonVarProc procedure} -setup { set x 0 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x set x 1 - .b1 toggle - set x -} {0} -test button-10.5 {ButtonVarProc procedure} { - deleteWindows + .c toggle + return $x +} -cleanup { + destroy .c +} -result {0} +test button-9.5 {ButtonVarProc procedure} -setup { set x 1 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x set x 1 - .b1 toggle - set x -} {0} -test button-10.6 {ButtonVarProc procedure} { - deleteWindows + .c toggle + return $x +} -cleanup { + destroy .c +} -result {0} +test button-9.6 {ButtonVarProc procedure} -setup { set x 0 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x set x 0 - .b1 toggle - set x -} {1} -test button-10.7 {ButtonVarProc procedure} { - deleteWindows + .c toggle + return $x +} -cleanup { + destroy .c +} -result {1} +test button-9.7 {ButtonVarProc procedure} -setup { set x 1 - checkbutton .b1 -variable x +} -body { + checkbutton .c -variable x set x 0 - .b1 toggle - set x -} {1} -test button-10.8 {ButtonVarProc procedure, can't read variable} { - # This test does nothing but produce a core dump if there's a prbblem. - deleteWindows - catch {unset a} - checkbutton .b1 -variable a + .c toggle + return $x +} -cleanup { + destroy .c +} -result {1} +test button-9.8 {ButtonVarProc procedure, can't read variable} -setup { +# This test does nothing but produce a core dump if there's a prbblem. + unset -nocomplain a +} -body { + checkbutton .c -variable a unset a set a(32) 0 unset a -} {} +} -cleanup { + destroy .c +} -result {} -test button-11.1 {ButtonTextVarProc procedure} { - deleteWindows +test button-10.1 {ButtonTextVarProc procedure} -body { set x Label - button .b1 -textvariable x + button .b -textvariable x unset x - set result [list $x [lindex [.b1 configure -text] 4]] + set result [list $x [.b cget -text]] set x New - lappend result [lindex [.b1 configure -text] 4] -} {Label Label New} -test button-11.2 {ButtonTextVarProc procedure} { - deleteWindows - # Windows buttons have a default min width, so we have to - # set this to be longer to force the wider button. + lappend result [.b cget -text] +} -cleanup { + destroy .b +} -result {Label Label New} +test button-10.2 {ButtonTextVarProc procedure} -setup { + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} +} -body { +# Windows buttons have a default min width, so we have to +# set this to be longer to force the wider button. set x ExtraLongLabel - button .b1 -textvariable x - set old [winfo reqwidth .b1] + .b configure -textvariable x + set old [winfo reqwidth .b] set x New - set new [winfo reqwidth .b1] - list [lindex [.b1 configure -text] 4] [expr $old == $new] -} {New 0} + set new [winfo reqwidth .b] + expr {$old == $new} +} -cleanup { + destroy .b +} -result {0} -test button-12.1 {ButtonImageProc procedure} testImageType { - deleteWindows - eval image delete [image names] +test button-11.1 {ButtonImageProc procedure} -constraints { + testImageType +} -setup { + label .l -highlightthickness 0 -font {Helvetica -12 bold} image create test image1 - label .b1 -image image1 -padx 0 -pady 0 -bd 0 - pack .b1 - set result "[winfo reqwidth .b1] [winfo reqheight .b1]" +} -body { + .l configure -image image1 -padx 0 -pady 0 -bd 0 + pack .l + set result "[winfo reqwidth .l] [winfo reqheight .l]" image1 changed 0 0 0 0 80 100 - lappend result [winfo reqwidth .b1] [winfo reqheight .b1] -} {30 15 80 100} - -deleteWindows -set l [interp hidden] + lappend result [winfo reqwidth .l] [winfo reqheight .l] +} -cleanup { + destroy .l + image delete image1 +} -result {30 15 80 100} -test button-13.1 {button widget vs hidden commands} { - catch {destroy .b} +test button-12.1 {button widget vs hidden commands} -body { button .b -text hello + set l [interp hidden] interp hide {} .b destroy .b - list [winfo children .] [interp hidden] -} [list {} $l] - -deleteWindows - -test button-14.1 {size behaviouor} { - set res {} - foreach class {label button radiobutton checkbutton} { - eval destroy [winfo children .] - - $class .a -text Hej - $class .b -text Hej -width 10 -height 1 - $class .c -text "" -width 10 -height 1 - - for {set t 0} {$t < 2} {incr t} { - set res2 {} - # With -width, width should not be affected by text change - lappend res2 [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] - # With -height, height should not be affected by text change - lappend res2 [expr {[winfo reqheight .b] == [winfo reqheight .c]}] - # A one line text should be as high as -height 1 - lappend res2 [expr {[winfo reqheight .a] == [winfo reqheight .b]}] - lappend res $res2 - - # Do the second round with another font - .a configure -font "Arial 20" - .b configure -font "Arial 20" - .c configure -font "Arial 20" - } - } - set res -} {{1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1} {1 1 1}} - -deleteWindows - -option clear - -# cleanup + + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 == $res2} +} -cleanup { + destroy .b +} -result {1} + +test button-13.1 {size behaviouor: label} -setup { + label .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + label .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + label .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} +test button-13.2 {size behaviouor: label} -setup { + label .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} + label .b -borderwidth 2 -highlightthickness 2 -font {Arial 20} + label .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} + +test button-13.3 {size behaviouor: button} -setup { + button .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + button .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + button .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} +test button-13.4 {size behaviouor: button} -setup { + button .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} + button .b -borderwidth 2 -highlightthickness 2 -font {Arial 20} + button .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} + +test button-13.5 {size behaviouor: radiobutton} -setup { + radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} + +test button-13.6 {size behaviouor: radiobutton} -setup { + radiobutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} + radiobutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20} + radiobutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} + +test button-13.7 {size behaviouor: checkbutton} -setup { + checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} + +test button-13.8 {size behaviouor: checkbutton} -setup { + checkbutton .a -borderwidth 2 -highlightthickness 2 -font {Arial 20} + checkbutton .b -borderwidth 2 -highlightthickness 2 -font {Arial 20} + checkbutton .c -borderwidth 2 -highlightthickness 2 -font {Arial 20} + set result {} +} -body { + .a configure -text Hej + .b configure -text Hej -width 10 -height 1 + .c configure -text "" -width 10 -height 1 + +# With -width, width should not be affected by text change + lappend result [expr {[winfo reqwidth .b] == [winfo reqwidth .c]}] +# With -height, height should not be affected by text change + lappend result [expr {[winfo reqheight .b] == [winfo reqheight .c]}] +# A one line text should be as high as -height 1 + lappend result [expr {[winfo reqheight .a] == [winfo reqheight .b]}] +} -cleanup { + destroy .a .b .c +} -result {1 1 1} + +imageFinish cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/canvImg.test b/tests/canvImg.test index 1dffc5e..776d268 100644 --- a/tests/canvImg.test +++ b/tests/canvImg.test @@ -7,103 +7,161 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit -eval image delete [image names] +# Canvas used in every test case of the whole file canvas .c pack .c update -if {[testConstraint testImageType]} { - image create test foo -variable x - image create test foo2 -variable y - foo2 changed 0 0 0 0 80 60 -} -test canvImg-1.1 {options for image items} { - .c delete all + + +test canvImg-1.1 {options for image items} -body { .c create image 50 50 -anchor nw -tags i1 .c itemconfigure i1 -anchor -} {-anchor {} {} center nw} -test canvImg-1.2 {options for image items} { - .c delete all - list [catch {.c create image 50 50 -anchor gorp -tags i1} msg] $msg -} {1 {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center}} -test canvImg-1.3 {options for image items} testImageType { - .c delete all +} -cleanup { + .c delete all +} -result {-anchor {} {} center nw} +test canvImg-1.2 {options for image items} -body { + .c create image 50 50 -anchor gorp -tags i1 +} -cleanup { + .c delete all +} -returnCodes {error} -result {bad anchor position "gorp": must be n, ne, e, se, s, sw, w, nw, or center} +test canvImg-1.3 {options for image items} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c create image 50 50 -image foo -tags i1 .c itemconfigure i1 -image -} {-image {} {} {} foo} -test canvImg-1.4 {options for image items} { - .c delete all - list [catch {.c create image 50 50 -image unknown -tags i1} msg] $msg -} {1 {image "unknown" doesn't exist}} -test canvImg-1.5 {options for image items} testImageType { - .c delete all +} -cleanup { + .c delete all + image delete foo +} -result {-image {} {} {} foo} +test canvImg-1.4 {options for image items} -body { + .c create image 50 50 -image unknown -tags i1 +} -cleanup { + .c delete all +} -returnCodes {error} -result {image "unknown" doesn't exist} +test canvImg-1.5 {options for image items} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c create image 50 50 -image foo -tags {i1 foo} .c itemconfigure i1 -tags -} {-tags {} {} {} {i1 foo}} +} -cleanup { + .c delete all + image delete foo +} -result {-tags {} {} {} {i1 foo}} -test canvImg-2.1 {CreateImage procedure} { - list [catch {.c create image 40} msg] $msg -} {1 {wrong # coordinates: expected 2, got 1}} -test canvImg-2.2 {CreateImage procedure} { - list [catch {.c create image 40 50 60} msg] $msg -} {1 {unknown option "60"}} -test canvImg-2.3 {CreateImage procedure} { +test canvImg-2.1 {CreateImage procedure} -body { + .c create image 40 +} -cleanup { + .c delete all +} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1} +test canvImg-2.2 {CreateImage procedure} -body { + .c create image 40 50 60 +} -cleanup { + .c delete all +} -returnCodes {error} -result {unknown option "60"} +test canvImg-2.3 {CreateImage procedure} -body { .c delete all set i [.c create image 50 50] list [lindex [.c itemconf $i -anchor] 4] \ [lindex [.c itemconf $i -image] 4] \ [lindex [.c itemconf $i -tags] 4] -} {center {} {}} -test canvImg-2.4 {CreateImage procedure} { - list [catch {.c create image xyz 40} msg] $msg -} {1 {bad screen distance "xyz"}} -test canvImg-2.5 {CreateImage procedure} { - list [catch {.c create image 50 qrs} msg] $msg -} {1 {bad screen distance "qrs"}} -test canvImg-2.6 {CreateImage procedure} testImageType { - list [catch {.c create image 50 50 -gorp foo} msg] $msg -} {1 {unknown option "-gorp"}} - -test canvImg-3.1 {ImageCoords procedure} testImageType { +} -cleanup { .c delete all - .c create image 50 100 -image foo -tags i1 - .c coords i1 -} {50.0 100.0} -test canvImg-3.2 {ImageCoords procedure} testImageType { +} -result {center {} {}} +test canvImg-2.4 {CreateImage procedure} -body { + .c create image xyz 40 +} -cleanup { .c delete all +} -returnCodes {error} -result {bad screen distance "xyz"} +test canvImg-2.5 {CreateImage procedure} -body { + .c create image 50 qrs +} -cleanup { + .c delete all +} -returnCodes {error} -result {bad screen distance "qrs"} +test canvImg-2.6 {CreateImage procedure} -constraints testImageType -body { + .c create image 50 50 -gorp foo +} -cleanup { + .c delete all +} -returnCodes {error} -result {unknown option "-gorp"} + + +test canvImg-3.1 {ImageCoords procedure} -constraints testImageType -setup { + image create test foo +} -body { + .c create image 50 100 -image foo -tags i1 + format {%.6g %.6g} {*}[.c coords i1] +} -cleanup { + .c delete all + image delete foo +} -result {50 100} +test canvImg-3.2 {ImageCoords procedure} -constraints testImageType -setup { + image create test foo +} -body { .c create image 50 100 -image foo -tags i1 - list [catch {.c coords i1 dumb 100} msg] $msg -} {1 {bad screen distance "dumb"}} -test canvImg-3.3 {ImageCoords procedure} testImageType { + .c coords i1 dumb 100 +} -cleanup { + .c delete all + image delete foo +} -returnCodes {error} -result {bad screen distance "dumb"} +test canvImg-3.3 {ImageCoords procedure} -constraints testImageType -setup { + image create test foo +} -body { .c delete all .c create image 50 100 -image foo -tags i1 - list [catch {.c coords i1 250 dumb0} msg] $msg -} {1 {bad screen distance "dumb0"}} -test canvImg-3.4 {ImageCoords procedure} testImageType { + .c coords i1 250 dumb0 +} -cleanup { + .c delete all + image delete foo +} -returnCodes {error} -result {bad screen distance "dumb0"} +test canvImg-3.4 {ImageCoords procedure} -constraints testImageType -setup { + image create test foo +} -body { .c delete all .c create image 50 100 -image foo -tags i1 - list [catch {.c coords i1 250} msg] $msg -} {1 {wrong # coordinates: expected 2, got 1}} -test canvImg-3.5 {ImageCoords procedure} testImageType { + .c coords i1 250 +} -cleanup { + .c delete all + image delete foo +} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1} +test canvImg-3.5 {ImageCoords procedure} -constraints testImageType -setup { + image create test foo +} -body { .c delete all .c create image 50 100 -image foo -tags i1 - list [catch {.c coords i1 250 300 400} msg] $msg -} {1 {wrong # coordinates: expected 0 or 2, got 3}} + .c coords i1 250 300 400 +} -cleanup { + .c delete all + image delete foo +} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3} + -test canvImg-4.1 {ConfiugreImage procedure} testImageType { +test canvImg-4.1 {ConfiugreImage procedure} -constraints testImageType -setup { .c delete all +} -body { + image create test foo -variable x .c create image 50 100 -image foo -tags i1 update set x {} .c itemconfigure i1 -image {} update list $x [.c bbox i1] -} {{{foo free}} {}} -test canvImg-4.2 {ConfiugreImage procedure} testImageType { - .c delete all +} -cleanup { + .c delete all + image delete foo +} -result {{{foo free}} {}} +test canvImg-4.2 {ConfiugreImage procedure} -constraints testImageType -setup { + .c delete all +} -body { + image create test foo -variable x + image create test foo2 -variable y + foo2 changed 0 0 0 0 80 60 .c create image 50 100 -image foo -tags i1 -anchor nw update set x {} @@ -111,281 +169,628 @@ test canvImg-4.2 {ConfiugreImage procedure} testImageType { .c itemconfigure i1 -image foo2 update list $x $y [.c bbox i1] -} {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}} -test canvImg-4.3 {ConfiugreImage procedure} testImageType { - .c delete all +} -cleanup { + .c delete all + image delete foo + image delete foo2 +} -result {{{foo free}} {{foo2 get} {foo2 display 0 0 80 60 30 30}} {50 100 130 160}} +test canvImg-4.3 {ConfiugreImage procedure} -constraints testImageType -setup { + .c delete all +} -body { + image create test foo -variable x + image create test foo2 -variable y + foo2 changed 0 0 0 0 80 60 .c create image 50 100 -image foo -tags i1 -anchor nw update set x {} set y {} - list [catch {.c itemconfigure i1 -image lousy} msg] $msg -} {1 {image "lousy" doesn't exist}} + .c itemconfigure i1 -image lousy +} -cleanup { + .c delete all + image delete foo foo2 +} -returnCodes {error} -result {image "lousy" doesn't exist} -test canvImg-5.1 {DeleteImage procedure} testImageType { - image create test xyzzy -variable z + +test canvImg-5.1 {DeleteImage procedure} -constraints testImageType -setup { .c delete all + imageCleanup +} -body { + image create test foo -variable x + image create test foo2 -variable y + image create test xyzzy -variable z .c create image 50 100 -image xyzzy -tags i1 update - set names [lsort [image names]] + set names [lsort [imageNames]] image delete xyzzy set z {} - set names2 [lsort [image names]] + set names2 [lsort [imageNames]] .c delete i1 update - list $names $names2 $z [lsort [image names]] -} {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}} -test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} { + list $names $names2 $z [lsort [imageNames]] +} -cleanup { + imageCleanup + .c delete all +} -result {{foo foo2 xyzzy} {foo foo2} {} {foo foo2}} +test canvImg-5.2 {DeleteImage procedure (don't delete non-existent image)} -body { .c delete all .c create image 50 100 -tags i1 update .c delete i1 update -} {} +} -result {} + -test canvImg-6.1 {ComputeImageBbox procedure} testImageType { +test canvImg-6.1 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo .c delete all +} -body { .c create image 15.51 17.51 -image foo -tags i1 -anchor nw .c bbox i1 -} {16 18 46 33} -test canvImg-6.2 {ComputeImageBbox procedure} testImageType { +} -cleanup { .c delete all + imageCleanup +} -result {16 18 46 33} +test canvImg-6.2 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c create image 15.49 17.49 -image foo -tags i1 -anchor nw .c bbox i1 -} {15 17 45 32} -test canvImg-6.3 {ComputeImageBbox procedure} { +} -cleanup { + .c delete all + imageCleanup +} -result {15 17 45 32} +test canvImg-6.3 {ComputeImageBbox procedure} -setup { .c delete all +} -body { .c create image 20 30 -tags i1 -anchor nw .c bbox i1 -} {} -test canvImg-6.4 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-6.4 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor nw .c bbox i1 -} {20 30 50 45} -test canvImg-6.5 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + imageCleanup +} -result {20 30 50 45} +test canvImg-6.5 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor n .c bbox i1 -} {5 30 35 45} -test canvImg-6.6 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + imageCleanup +} -result {5 30 35 45} +test canvImg-6.6 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor ne .c bbox i1 -} {-10 30 20 45} -test canvImg-6.7 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + imageCleanup +} -result {-10 30 20 45} +test canvImg-6.7 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor e .c bbox i1 -} {-10 23 20 38} -test canvImg-6.8 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + imageCleanup +} -result {-10 23 20 38} +test canvImg-6.8 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor se .c bbox i1 -} {-10 15 20 30} -test canvImg-6.9 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + imageCleanup +} -result {-10 15 20 30} +test canvImg-6.9 {ComputeImageBbox procedure} -constraints testImageType -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor s .c bbox i1 -} {5 15 35 30} -test canvImg-6.10 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + imageCleanup +} -result {5 15 35 30} +test canvImg-6.10 {ComputeImageBbox procedure} -constraints { + testImageType +} -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor sw .c bbox i1 -} {20 15 50 30} -test canvImg-6.11 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + image delete foo +} -result {20 15 50 30} +test canvImg-6.11 {ComputeImageBbox procedure} -constraints { + testImageType +} -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor w .c bbox i1 -} {20 23 50 38} -test canvImg-6.12 {ComputeImageBbox procedure} testImageType { +} -cleanup { + .c delete all + image delete foo +} -result {20 23 50 38} +test canvImg-6.12 {ComputeImageBbox procedure} -constraints { + testImageType +} -setup { + image create test foo + .c delete all +} -body { .c delete all .c create image 20 30 -image foo -tags i1 -anchor center .c bbox i1 -} {5 23 35 38} +} -cleanup { + .c delete all + image delete foo +} -result {5 23 35 38} # The following test is non-portable because of differences in # coordinate rounding on some machines (does 0.5 round up?). -test canvImg-7.1 {DisplayImage procedure} {nonPortable testImageType} { +test canvImg-7.1 {DisplayImage procedure} -constraints { + nonPortable testImageType +} -setup { .c delete all +} -body { + image create test foo -variable x .c create image 50 100 -image foo -tags i1 -anchor nw update set x {} .c create rect 55 110 65 115 -width 1 -outline black -fill white update set x -} {{foo display 4 9 12 6 30 30}} -test canvImg-7.2 {DisplayImage procedure, no image} { +} -result {{foo display 4 9 12 6 30 30}} +test canvImg-7.2 {DisplayImage procedure, no image} -body { .c delete all .c create image 50 100 -tags i1 update .c create rect 55 110 65 115 -width 1 -outline black -fill white update -} {} +} -result {} -.c delete all + +# image used in 8.* test cases if {[testConstraint testImageType]} { - .c create image 50 100 -image foo -tags image -anchor nw + image create test foo } -.c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} -foreach check { - {canvImg-8.1 {50 70 80 81} {70 90} rect} - {canvImg-8.2 {50 70 80 79} {70 90} image} - {canvImg-8.3 {99 70 110 81} {90 90} rect} - {canvImg-8.4 {101 70 110 79} {90 90} image} - {canvImg-8.5 {99 100 110 115} {90 110} rect} - {canvImg-8.6 {101 100 110 115} {90 110} image} - {canvImg-8.7 {99 134 110 145} {90 125} rect} - {canvImg-8.8 {101 136 110 145} {90 125} image} - {canvImg-8.9 {50 134 80 145} {70 125} rect} - {canvImg-8.10 {50 136 80 145} {70 125} image} - {canvImg-8.11 {20 134 31 145} {40 125} rect} - {canvImg-8.12 {20 136 29 145} {40 125} image} - {canvImg-8.13 {20 100 31 115} {40 110} rect} - {canvImg-8.14 {20 100 29 115} {40 110} image} - {canvImg-8.15 {20 70 31 80} {40 90} rect} - {canvImg-8.16 {20 70 29 79} {40 90} image} - {canvImg-8.17 {60 70 69 109} {70 110} image} - {canvImg-8.18 {60 70 71 111} {70 110} rect} -} { - lassign $check name rectCoords testPoint result - test $name {ImageToPoint procedure} testImageType { - .c coords rect {*}$rectCoords - .c gettags [.c find closest {*}$testPoint] - } $result -} - +test canvImg-8.1 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect 50 70 80 81 + .c gettags [.c find closest 70 90] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.2 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{50 70 80 79} + .c gettags [.c find closest {*}{70 90}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.3 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{99 70 110 81} + .c gettags [.c find closest {*}{90 90}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.4 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{101 70 110 79} + .c gettags [.c find closest {*}{90 90}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.5 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{99 100 110 115} + .c gettags [.c find closest {*}{90 110}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.6 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{101 100 110 115} + .c gettags [.c find closest {*}{90 110}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.7 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{99 134 110 145} + .c gettags [.c find closest {*}{90 125}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.8 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{101 136 110 145} + .c gettags [.c find closest {*}{90 125}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.9 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{50 134 80 145} + .c gettags [.c find closest {*}{70 125}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.10 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{50 136 80 145} + .c gettags [.c find closest {*}{70 125}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.11 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{20 134 31 145} + .c gettags [.c find closest {*}{40 125}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.12 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{20 136 29 145} + .c gettags [.c find closest {*}{40 125}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.13 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{20 100 31 115} + .c gettags [.c find closest {*}{40 110}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.14 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{20 100 29 115} + .c gettags [.c find closest {*}{40 110}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.15 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{20 70 31 80} + .c gettags [.c find closest {*}{40 90}] +} -cleanup { + .c delete all +} -result {rect} +test canvImg-8.16 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{20 70 29 79} + .c gettags [.c find closest {*}{40 90}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.17 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{60 70 69 109} + .c gettags [.c find closest {*}{70 110}] +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.18 {ImageToArea procedure} -constraints testImageType -setup { + .c create image 50 100 -image foo -tags image -anchor nw + .c create rect 10 10 20 20 -tags rect -fill black -width 0 -outline {} +} -body { + .c coords rect {*}{60 70 71 111} + .c gettags [.c find closest {*}{70 110}] +} -cleanup { + .c delete all +} -result {rect} .c delete all -if {[testConstraint testImageType]} { + +test canvImg-8.19 {ImageToArea procedure} -constraints testImageType -body { .c create image 50 100 -image foo -tags image -anchor nw -} -test canvImg-8.19 {ImageToArea procedure} testImageType { .c gettags [.c find overlapping 60 0 70 99] -} {} -test canvImg-8.20 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.20 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 0 70 99.999] -} {} -test canvImg-8.21 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.21 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 0 70 101] -} {image} -test canvImg-8.22 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.22 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 81 105 120 115] -} {} -test canvImg-8.23 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.23 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 80.001 105 120 115] -} {} -test canvImg-8.24 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.24 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 79 105 120 115] -} {image} -test canvImg-8.25 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.25 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 116 70 150] -} {} -test canvImg-8.26 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.26 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 115.001 70 150] -} {} -test canvImg-8.27 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.27 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 60 114 70 150] -} {image} -test canvImg-8.28 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.28 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 105 49 115] -} {} -test canvImg-8.29 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.29 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 105 50 114.999] -} {} -test canvImg-8.30 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.30 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 105 51 115] -} {image} -test canvImg-8.31 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.31 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 0 49.999 99.999] -} {} -test canvImg-8.32 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.32 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 0 51 101] -} {image} -test canvImg-8.33 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.33 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 80 0 150 100] -} {} -test canvImg-8.34 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.34 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 79 0 150 101] -} {image} -test canvImg-8.35 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.35 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 80.001 115.001 150 180] -} {} -test canvImg-8.36 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.36 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 79 114 150 180] -} {image} -test canvImg-8.37 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.37 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 115 50 180] -} {} -test canvImg-8.38 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.38 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find overlapping 0 114 51 180] -} {image} -test canvImg-8.39 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.39 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 0 0 200 200] -} {image} -test canvImg-8.40 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.40 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 49.999 99.999 80.001 115.001] -} {image} -test canvImg-8.41 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {image} +test canvImg-8.41 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 51 100 80 115] -} {} -test canvImg-8.42 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.42 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 50 101 80 115] -} {} -test canvImg-8.43 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.43 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 50 100 79 115] -} {} -test canvImg-8.44 {ImageToArea procedure} testImageType { +} -cleanup { + .c delete all +} -result {} +test canvImg-8.44 {ImageToArea procedure} -constraints testImageType -body { + .c create image 50 100 -image foo -tags image -anchor nw .c gettags [.c find enclosed 50 100 80 114] -} {} +} -cleanup { + .c delete all +} -result {} +if {[testConstraint testImageType]} { + image delete foo +} + -test canvImg-9.1 {DisplayImage procedure} testImageType { +test canvImg-9.1 {DisplayImage procedure} -constraints testImageType -setup { .c delete all + image create test foo +} -body { .c create image 50 100 -image foo -tags image -anchor nw .c scale image 25 0 2.0 1.5 .c bbox image -} {75 150 105 165} +} -cleanup { + .c delete all + image delete foo +} -result {75 150 105 165} -test canvImg-10.1 {TranslateImage procedure} testImageType { +test canvImg-10.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all +} -body { + image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor nw update set x {} foo changed 2 4 6 8 30 15 update - set x -} {{foo display 2 4 6 8 30 30}} + return $x +} -cleanup { + .c delete all + image delete foo +} -result {{foo display 2 4 6 8 30 30}} -test canvImg-11.1 {TranslateImage procedure} testImageType { +test canvImg-11.1 {TranslateImage procedure} -constraints testImageType -setup { .c delete all +} -body { + image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor nw update set x {} foo changed 2 4 6 8 40 50 update - set x -} {{foo display 0 0 40 50 30 30}} -test canvImg-11.2 {ImageChangedProc procedure} testImageType { - .c delete all + return $x +} -cleanup { + .c delete all + image delete foo +} -result {{foo display 0 0 40 50 30 30}} +test canvImg-11.2 {ImageChangedProc procedure} -constraints { + testImageType +} -setup { + .c delete all +} -body { image create test foo -variable x .c create image 50 100 -image foo -tags image -anchor center update set x {} foo changed 0 0 0 0 40 50 .c bbox image -} {30 75 70 125} -test canvImg-11.3 {ImageChangedProc procedure} testImageType { - .c delete all +} -cleanup { + .c delete all + image delete foo +} -result {30 75 70 125} +test canvImg-11.3 {ImageChangedProc procedure} -constraints { + testImageType +} -setup { + .c delete all +} -body { image create test foo -variable x + image create test foo2 -variable y foo changed 0 0 0 0 40 50 + foo2 changed 0 0 0 0 80 60 + .c create image 50 100 -image foo -tags image -anchor nw .c create image 70 110 -image foo2 -anchor nw update set y {} image create test foo -variable x update - set y -} {{foo2 display 0 0 20 40 50 40}} + return $y +} -cleanup { + .c delete all + image delete foo foo2 +} -result {{foo2 display 0 0 20 40 50 40}} # cleanup +imageFinish cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/canvMoveto.test b/tests/canvMoveto.test new file mode 100644 index 0000000..79761a4 --- /dev/null +++ b/tests/canvMoveto.test @@ -0,0 +1,56 @@ +# This file is a Tcl script to test out the canvas "moveto" command. It is +# derived from canvRect.test. +# +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2004 Neil McKay. +# All rights reserved. + +package require tcltest 2.1 +eval tcltest::configure $argv +tcltest::loadTestedCommands + +canvas .c -width 400 -height 300 -bd 2 -relief sunken +.c create rectangle 20 20 80 80 -tag {test rect1} +.c create rectangle 40 40 90 100 -tag {test rect2} + +test canvMoveto-1.1 {Bad args handling for "moveto" command} -body { + .c moveto test +} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"} +test canvMoveto-1.2 {Bad args handling for "moveto" command} -body { + .c moveto rect +} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"} +test canvMoveto-1.3 {Bad args handling for "moveto" command} -body { + .c moveto test 12 +} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"} +test canvMoveto-1.4 {Bad args handling for "moveto" command} -body { + .c moveto test 12 y +} -returnCodes error -result {bad screen distance "y"} +test canvMoveto-1.5 {Bad args handling for "moveto" command} -body { + .c moveto test 12 20 -anchor +} -returnCodes error -result {wrong # args: should be ".c moveto tagOrId x y"} + +test canvMoveto-2.1 {Canvas "moveto" command coordinates} { + .c moveto test 200 150 + .c bbox test +} {200 150 272 232} +test canvMoveto-2.2 {Canvas "moveto" command, blank y coordinate} { + .c moveto test 200 150 + .c moveto test 150 {} + .c bbox test +} {150 150 222 232} +test canvMoveto-2.3 {Canvas "moveto" command, blank x coordinate} { + .c moveto test 200 150 + .c moveto test {} 200 + .c bbox test +} {200 200 272 282} + +.c delete withtag all + +# cleanup +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/canvPs.test b/tests/canvPs.test index f2df447..c7ba958 100644 --- a/tests/canvPs.test +++ b/tests/canvPs.test @@ -6,10 +6,13 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit +# canvas used in 1.* and 2.* test cases canvas .c -width 400 -height 300 -bd 2 -relief sunken .c create rectangle 20 20 80 80 -fill red pack .c @@ -43,6 +46,7 @@ test canvPs-1.2 {test writing to a file, idempotency} -constraints { removeFile bar.ps } -result ok + test canvPs-2.1 {test writing to a channel} -constraints { unixOrPc } -setup { @@ -75,7 +79,7 @@ test canvPs-2.2 {test writing to channel, idempotency} -constraints { close $c2 set status ok if {[file size $bar] != [file size $foo]} { - set status broken + set status broken } set status } -cleanup { @@ -97,7 +101,7 @@ test canvPs-2.3 {test writing to channel and file, same output} -constraints { .c postscript -file $bar set status ok if {[file size $foo] != [file size $bar]} { - set status broken + set status broken } set status } -cleanup { @@ -119,21 +123,22 @@ test canvPs-2.4 {test writing to channel and file, same output} -constraints { .c postscript -file $bar set status ok if {[file size $foo] != [file size $bar]} { - set status broken + set status broken } set status } -cleanup { removeFile foo.ps removeFile bar.ps } -result ok +destroy .c + -test canvPs-3.1 {test ps generation with an embedded window} -setup { +test canvPs-3.1 {test ps generation with an embedded window} -constraints { + notAqua +} -setup { set bar [makeFile {} bar.ps] file delete $bar -} -constraints { - notAqua } -body { - destroy .c pack [canvas .c -width 200 -height 200 -background white] .c create rect 20 20 150 150 -tags rect0 -dash . -width 2 .c create arc 0 50 200 200 -tags arc0 \ @@ -150,13 +155,14 @@ test canvPs-3.1 {test ps generation with an embedded window} -setup { .c postscript -file $bar file exists $bar } -cleanup { + destroy .c + imageCleanup removeFile bar.ps -} -result 1 +} -result {1} test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup { set bar [makeFile {} bar.ps] file delete $bar } -body { - destroy .c pack [canvas .c -width 200 -height 200 -background white] entry .c.e -background pink -foreground blue -width 14 .c.e insert 0 "we gonna be postscripted" @@ -164,18 +170,27 @@ test canvPs-3.2 {test ps generation with an embedded window not mapped} -setup { .c postscript -file $bar file exists $bar } -cleanup { + destroy .c removeFile bar.ps -} -result 1 +} -result {1} -test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} {} { - destroy .c + +test canvPs-4.1 {test ps generation with single-point uncolored poly, bug 734498} -body { pack [canvas .c] .c create poly 10 20 10 20 - catch {.c postscript} -} 0 + .c postscript +} -cleanup { + destroy .c +} -returnCodes ok -match glob -result * + # cleanup unset -nocomplain foo bar +imageFinish deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/canvRect.test b/tests/canvRect.test index b6c828e..a2cc51c 100644 --- a/tests/canvRect.test +++ b/tests/canvRect.test @@ -6,301 +6,444 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Canvas used in every test case of the whole file canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c -bind .c <1> { - puts "button down at (%x,%y)" -} update -set i 1 +# Rectangle used in canvRect-1.* tests .c create rectangle 20 20 80 80 -tag test -foreach test { - {-fill #ff0000 #ff0000 - non-existent {unknown color name "non-existent"}} - {-outline #123456 #123456 - bad_color {unknown color name "bad_color"}} - {-stipple gray50 gray50 - bogus {bitmap "bogus" not defined}} - {-tags {test a b c} {test a b c} - {} {}} - {-width 6.0 6.0 - abc {bad screen distance "abc"}} -} { - lassign $test name goodValue goodResult badValue badResult - test canvRect-1.$i "configuration options: good value for $name" { - .c itemconfigure test $name $goodValue - list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name] - } [list $goodResult $goodResult] - incr i - if {$badValue ne ""} { - test canvRect-1.$i "configuration options: bad value for $name" -body { - .c itemconfigure test $name $badValue - } -returnCodes error -result $badResult - } - incr i -} -test canvRect-1.$i {configuration options} { +test canvRect-1.1 {configuration options: good value for -fill} -body { + .c itemconfigure test -fill #ff0000 + list [.c itemcget test -fill] [lindex [.c itemconfigure test -fill] 4] +} -result {{#ff0000} #ff0000} +test canvRect-1.2 {configuration options: bad value for -fill} -body { + .c itemconfigure test -fill non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test canvRect-1.3 {configuration options: good value for -outline} -body { + .c itemconfigure test -outline #123456 + list [.c itemcget test -outline] [lindex [.c itemconfigure test -outline] 4] +} -result {{#123456} #123456} +test canvRect-1.4 {configuration options: bad value for -outline} -body { + .c itemconfigure test -outline non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test canvRect-1.5 {configuration options: good value for -stipple } -body { + .c itemconfigure test -stipple gray50 + list [.c itemcget test -stipple ] [lindex [.c itemconfigure test -stipple ] 4] +} -result {gray50 gray50} +test canvRect-1.6 {configuration options: bad value for -stipple } -body { + .c itemconfigure test -stipple bogus +} -returnCodes error -result {bitmap "bogus" not defined} +test canvRect-1.7 {configuration options: good value for -tags} -body { + .c itemconfigure test -tags {test a b c} + list [.c itemcget test -tags] [lindex [.c itemconfigure test -tags] 4] +} -result {{test a b c} {test a b c}} +test canvRect-1.8 {configuration options} -body { .c itemconfigure test -tags {test xyz} .c itemcget xyz -tags -} {test xyz} +} -result {test xyz} +test canvRect-1.9 {configuration options: good value for -width} -body { + .c itemconfigure test -width 6.0 + list [.c itemcget test -width] [lindex [.c itemconfigure test -width] 4] +} -result {6.0 6.0} +test canvRect-1.10 {configuration options: bad value for -width} -body { + .c itemconfigure test -width abc +} -returnCodes error -result {bad screen distance "abc"} +.c delete withtag all + -test canvRect-2.1 {CreateRectOval procedure} { - list [catch {.c create rect} msg] $msg -} {1 {wrong # args: should be ".c create rect coords ?arg arg ...?"}} -test canvRect-2.2 {CreateRectOval procedure} { - list [catch {.c create oval x y z} msg] $msg -} {1 {wrong # coordinates: expected 0 or 4, got 3}} -test canvRect-2.3 {CreateRectOval procedure} { - list [catch {.c create rectangle x 2 3 4} msg] $msg -} {1 {bad screen distance "x"}} -test canvRect-2.4 {CreateRectOval procedure} { - list [catch {.c create rectangle 1 y 3 4} msg] $msg -} {1 {bad screen distance "y"}} -test canvRect-2.5 {CreateRectOval procedure} { - list [catch {.c create rectangle 1 2 z 4} msg] $msg -} {1 {bad screen distance "z"}} -test canvRect-2.6 {CreateRectOval procedure} { - list [catch {.c create rectangle 1 2 3 q} msg] $msg -} {1 {bad screen distance "q"}} -test canvRect-2.7 {CreateRectOval procedure} { +test canvRect-2.1 {CreateRectOval procedure} -body { + .c create rect +} -returnCodes error -result {wrong # args: should be ".c create rect coords ?arg ...?"} +test canvRect-2.2 {CreateRectOval procedure} -body { + .c create oval x y z +} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 3} +test canvRect-2.3 {CreateRectOval procedure} -body { + .c create rectangle x 2 3 4 +} -returnCodes error -result {bad screen distance "x"} +test canvRect-2.4 {CreateRectOval procedure} -body { + .c create rectangle 1 y 3 4 +} -returnCodes error -result {bad screen distance "y"} +test canvRect-2.5 {CreateRectOval procedure} -body { + .c create rectangle 1 2 z 4 +} -returnCodes error -result {bad screen distance "z"} +test canvRect-2.6 {CreateRectOval procedure} -body { + .c create rectangle 1 2 3 q +} -returnCodes error -result {bad screen distance "q"} +test canvRect-2.7 {CreateRectOval procedure} -body { .c create rectangle 1 2 3 4 -tags x set result {} foreach element [.c coords x] { - lappend result [format %.1f $element] + lappend result [format %.1f $element] } set result -} {1.0 2.0 3.0 4.0} -test canvRect-2.8 {CreateRectOval procedure} { - list [catch {.c create rectangle 1 2 3 4 -gorp foo} msg] $msg -} {1 {unknown option "-gorp"}} - +} -result {1.0 2.0 3.0 4.0} +test canvRect-2.8 {CreateRectOval procedure} -body { + .c create rectangle 1 2 3 4 -gorp foo +} -returnCodes error -result {unknown option "-gorp"} .c delete withtag all -.c create rectangle 10 20 30 40 -tags x -test canvRect-3.1 {RectOvalCoords procedure} { + + +test canvRect-3.1 {RectOvalCoords procedure} -body { + .c create rectangle 10 20 30 40 -tags x set result {} foreach element [.c coords x] { - lappend result [format %.1f $element] + lappend result [format %.1f $element] } - set result -} {10.0 20.0 30.0 40.0} -test canvRect-3.2 {RectOvalCoords procedure} { - list [catch {.c coords x a 2 3 4} msg] $msg -} {1 {bad screen distance "a"}} -test canvRect-3.3 {RectOvalCoords procedure} { - list [catch {.c coords x 1 b 3 4} msg] $msg -} {1 {bad screen distance "b"}} -test canvRect-3.4 {RectOvalCoords procedure} { - list [catch {.c coords x 1 2 c 4} msg] $msg -} {1 {bad screen distance "c"}} -test canvRect-3.5 {RectOvalCoords procedure} { - list [catch {.c coords x 1 2 3 d} msg] $msg -} {1 {bad screen distance "d"}} -test canvRect-3.6 {RectOvalCoords procedure} {nonPortable} { + return $result +} -cleanup { + .c delete withtag all +} -result {10.0 20.0 30.0 40.0} +test canvRect-3.2 {RectOvalCoords procedure} -body { + .c create rectangle 10 20 30 40 -tags x + .c coords x a 2 3 4 +} -cleanup { + .c delete withtag all +} -returnCodes error -result {bad screen distance "a"} +test canvRect-3.3 {RectOvalCoords procedure} -body { + .c create rectangle 10 20 30 40 -tags x + .c coords x 1 b 3 4 +} -cleanup { + .c delete withtag all +} -returnCodes error -result {bad screen distance "b"} +test canvRect-3.4 {RectOvalCoords procedure} -body { + .c create rectangle 10 20 30 40 -tags x + .c coords x 1 2 c 4 +} -cleanup { + .c delete withtag all +} -returnCodes error -result {bad screen distance "c"} +test canvRect-3.5 {RectOvalCoords procedure} -body { + .c create rectangle 10 20 30 40 -tags x + .c coords x 1 2 3 d +} -cleanup { + .c delete withtag all +} -returnCodes error -result {bad screen distance "d"} +test canvRect-3.6 {RectOvalCoords procedure} -constraints { + nonPortable +} -body { + .c create rectangle 10 20 30 40 -tags x # Non-portable due to rounding differences. .c coords x 10 25 15 40 .c bbox x -} {9 24 16 41} -test canvRect-3.7 {RectOvalCoords procedure} { - list [catch {.c coords x 1 2 3 4 5} msg] $msg -} {1 {wrong # coordinates: expected 0 or 4, got 5}} +} -cleanup { + .c delete withtag all +} -result {9 24 16 41} +test canvRect-3.7 {RectOvalCoords procedure} -body { + .c create rectangle 10 20 30 40 -tags x + .c coords x 1 2 3 4 5 +} -cleanup { + .c delete withtag all +} -returnCodes error -result {wrong # coordinates: expected 0 or 4, got 5} -.c delete withtag all -.c create rectangle 10 20 30 40 -tags x -width 1 -test canvRect-4.1 {ConfigureRectOval procedure} { - list [catch {.c itemconfigure x -width abc} msg] $msg \ - [.c itemcget x -width] -} {1 {bad screen distance "abc"} 1.0} -test canvRect-4.2 {ConfigureRectOval procedure} { - list [catch {.c itemconfigure x -width -5} msg] $msg -} {1 {bad screen distance "-5"}} -test canvRect-4.3 {ConfigureRectOval procedure} {nonPortable} { - # Non-portable due to rounding differences. + +test canvRect-4.1 {ConfigureRectOval procedure} -body { + .c create rectangle 10 20 30 40 -tags x -width 1 + .c itemconfigure x -width abc +} -cleanup { + .c delete withtag all +} -returnCodes error -result {bad screen distance "abc"} +test canvRect-4.2 {ConfigureRectOval procedure} -body { + .c create rectangle 10 20 30 40 -tags x -width 1 + catch {.c itemconfigure x -width abc} + .c itemcget x -width +} -cleanup { + .c delete withtag all +} -result {1.0} +test canvRect-4.3 {ConfigureRectOval procedure} -body { + .c create rectangle 10 20 30 40 -tags x -width 1 + .c itemconfigure x -width -5 +} -cleanup { + .c delete withtag all +} -returnCodes error -result {bad screen distance "-5"} +test canvRect-4.4 {ConfigureRectOval procedure} -constraints nonPortable -body { + # Non-portable due to rounding differences + .c create rectangle 10 20 30 40 -tags x -width 1 .c itemconfigure x -width 10 .c bbox x -} {5 15 35 45} +} -cleanup { + .c delete withtag all +} -result {5 15 35 45} + # I can't come up with any good tests for DeleteRectOval. -.c delete withtag all -.c create rectangle 10 20 30 40 -tags x -width 1 -outline {} -test canvRect-5.1 {ComputeRectOvalBbox procedure} {nonPortable} { +test canvRect-5.1 {ComputeRectOvalBbox procedure} -constraints nonPortable -body { # Non-portable due to rounding differences: + .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} .c coords x 20 15 10 5 .c bbox x -} {10 5 20 15} -test canvRect-5.2 {ComputeRectOvalBbox procedure} {nonPortable} { +} -cleanup { + .c delete withtag all +} -result {10 5 20 15} +test canvRect-5.2 {ComputeRectOvalBbox procedure} -constraints nonPortable -body { # Non-portable due to rounding differences: + .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} .c coords x 10 20 30 10 .c itemconfigure x -width 1 -outline red .c bbox x -} {9 9 31 21} -test canvRect-5.3 {ComputeRectOvalBbox procedure} {nonPortable} { +} -cleanup { + .c delete withtag all +} -result {9 9 31 21} +test canvRect-5.3 {ComputeRectOvalBbox procedure} -constraints nonPortable -body { # Non-portable due to rounding differences: + .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} .c coords x 10 20 30 10 .c itemconfigure x -width 2 -outline red .c bbox x -} {9 9 31 21} -test canvRect-5.4 {ComputeRectOvalBbox procedure} {nonPortable} { +} -cleanup { + .c delete withtag all +} -result {9 9 31 21} +test canvRect-5.4 {ComputeRectOvalBbox procedure} -constraints nonPortable -body { # Non-portable due to rounding differences: + .c create rectangle 10 20 30 40 -tags x -width 1 -outline {} .c coords x 10 20 30 10 .c itemconfigure x -width 3 -outline red .c bbox x -} {8 8 32 22} +} -cleanup { + .c delete withtag all +} -result {8 8 32 22} # I can't come up with any good tests for DisplayRectOval. -.c delete withtag all -set x [.c create rectangle 10 20 30 35 -tags x -fill green] -set y [.c create rectangle 15 25 25 30 -tags y -fill red] -test canvRect-6.1 {RectToPoint procedure} { +test canvRect-6.1 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 35 -tags x -fill green] + set yId [.c create rectangle 15 25 25 30 -tags y -fill red] .c itemconfigure y -outline {} - list [.c find closest 14.9 28] [.c find closest 15.1 28] \ - [.c find closest 24.9 28] [.c find closest 25.1 28] -} "$x $y $y $x" -test canvRect-6.2 {RectToPoint procedure} { + list [expr {[.c find closest 14.9 28] eq $xId}] \ + [expr {[.c find closest 15.1 28] eq $yId}] \ + [expr {[.c find closest 24.9 28] eq $yId}] \ + [expr {[.c find closest 25.1 28] eq $xId}] +} -cleanup { + .c delete all +} -result {1 1 1 1} +test canvRect-6.2 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 35 -tags x -fill green] + set yId [.c create rectangle 15 25 25 30 -tags y -fill red] .c itemconfigure y -outline {} - list [.c find closest 20 24.9] [.c find closest 20 25.1] \ - [.c find closest 20 29.9] [.c find closest 20 30.1] -} "$x $y $y $x" -test canvRect-6.3 {RectToPoint procedure} { + list [expr {[.c find closest 20 24.9] eq $xId}] \ + [expr {[.c find closest 20 25.1] eq $yId}] \ + [expr {[.c find closest 20 29.9] eq $yId}] \ + [expr {[.c find closest 20 30.1] eq $xId}] + +} -cleanup { + .c delete all +} -result {1 1 1 1} +test canvRect-6.3 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 35 -tags x -fill green] + set yId [.c create rectangle 15 25 25 30 -tags y -fill red] .c itemconfigure y -width 1 -outline black - list [.c find closest 14.4 28] [.c find closest 14.6 28] \ - [.c find closest 25.4 28] [.c find closest 25.6 28] -} "$x $y $y $x" -test canvRect-6.4 {RectToPoint procedure} { + list [expr {[.c find closest 14.4 28] eq $xId}] \ + [expr {[.c find closest 14.6 28] eq $yId}] \ + [expr {[.c find closest 25.4 28] eq $yId}] \ + [expr {[.c find closest 25.6 28] eq $xId}] +} -cleanup { + .c delete all +} -result {1 1 1 1} +test canvRect-6.4 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 35 -tags x -fill green] + set yId [.c create rectangle 15 25 25 30 -tags y -fill red] .c itemconfigure y -width 1 -outline black - list [.c find closest 20 24.4] [.c find closest 20 24.6] \ - [.c find closest 20 30.4] [.c find closest 20 30.6] -} "$x $y $y $x" -.c itemconfigure x -fill {} -outline black -width 3 -.c itemconfigure y -outline {} -test canvRect-6.5 {RectToPoint procedure} { - list [.c find closest 13.2 28] [.c find closest 13.3 28] \ - [.c find closest 26.7 28] [.c find closest 26.8 28] -} "$x $y $y $x" -test canvRect-6.6 {RectToPoint procedure} { - list [.c find closest 20 23.2] [.c find closest 20 23.3] \ - [.c find closest 20 31.7] [.c find closest 20 31.8] -} "$x $y $y $x" -.c delete withtag all -set x [.c create rectangle 10 20 30 40 -outline {} -fill black] -set y [.c create rectangle 40 40 50 50 -outline {} -fill black] -test canvRect-6.7 {RectToPoint procedure} { - list [.c find closest 35 35] [.c find closest 36 36] \ - [.c find closest 37 37] [.c find closest 38 38] -} "$x $y $y $y" + list [expr {[.c find closest 20 24.4] eq $xId}] \ + [expr {[.c find closest 20 24.6] eq $yId}] \ + [expr {[.c find closest 20 30.4] eq $yId}] \ + [expr {[.c find closest 20 30.6] eq $xId}] +} -cleanup { + .c delete all +} -result {1 1 1 1} -.c delete withtag all -set x [.c create rectangle 10 20 30 35 -fill green -outline {}] -set y [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] -set z [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] -test canvRect-7.1 {RectToArea procedure} { - list [.c find overlapping 20 50 38 60] \ - [.c find overlapping 20 50 39 60] \ - [.c find overlapping 20 50 70 60] \ - [.c find overlapping 61 50 70 60] \ - [.c find overlapping 62 50 70 60] -} "{} $y $y $y {}" -test canvRect-7.2 {RectToArea procedure} { - list [.c find overlapping 45 20 55 43] \ - [.c find overlapping 45 20 55 44] \ - [.c find overlapping 45 20 55 80] \ - [.c find overlapping 45 71 55 80] \ - [.c find overlapping 45 72 55 80] -} "{} $y $y $y {}" -test canvRect-7.3 {RectToArea procedure} { - list [.c find overlapping 5 25 9.9 30] [.c find overlapping 5 25 10.1 30] -} "{} $x" -test canvRect-7.4 {RectToArea procedure} { - list [.c find overlapping 102 152 118 168] \ - [.c find overlapping 101 152 118 168] \ - [.c find overlapping 102 151 118 168] \ - [.c find overlapping 102 152 119 168] \ - [.c find overlapping 102 152 118 169] -} "{} $z $z $z $z" -test canvRect-7.5 {RectToArea procedure} { - list [.c find enclosed 20 40 38 80] \ - [.c find enclosed 20 40 39 80] \ - [.c find enclosed 20 40 70 80] \ - [.c find enclosed 61 40 70 80] \ - [.c find enclosed 62 40 70 80] -} "{} {} $y {} {}" -test canvRect-7.6 {RectToArea procedure} { - list [.c find enclosed 20 20 65 43] \ - [.c find enclosed 20 20 65 44] \ - [.c find enclosed 20 20 65 80] \ - [.c find enclosed 20 71 65 80] \ - [.c find enclosed 20 72 65 80] -} "{} {} $y {} {}" +test canvRect-6.5 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 35 -tags x -fill green] + set yId [.c create rectangle 15 25 25 30 -tags y -fill red] + .c itemconfigure x -fill {} -outline black -width 3 + .c itemconfigure y -outline {} + list [expr {[.c find closest 13.2 28] eq $xId}] \ + [expr {[.c find closest 13.3 28] eq $yId}] \ + [expr {[.c find closest 26.7 28] eq $yId}] \ + [expr {[.c find closest 26.8 28] eq $xId}] +} -cleanup { + .c delete all +} -result {1 1 1 1} +test canvRect-6.6 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 35 -tags x -fill green] + set yId [.c create rectangle 15 25 25 30 -tags y -fill red] + .c itemconfigure x -fill {} -outline black -width 3 + .c itemconfigure y -outline {} + list [expr {[.c find closest 20 23.2] eq $xId}] \ + [expr {[.c find closest 20 23.3] eq $yId}] \ + [expr {[.c find closest 20 31.7] eq $yId}] \ + [expr {[.c find closest 20 31.8] eq $xId}] +} -cleanup { + .c delete all +} -result {1 1 1 1} + +test canvRect-6.7 {RectToPoint procedure} -body { + set xId [.c create rectangle 10 20 30 40 -outline {} -fill black] + set yId [.c create rectangle 40 40 50 50 -outline {} -fill black] + list [expr {[.c find closest 35 35] eq $xId}] \ + [expr {[.c find closest 36 36] eq $yId}] \ + [expr {[.c find closest 37 37] eq $yId}] \ + [expr {[.c find closest 38 38] eq $yId}] +} -cleanup { + .c delete all +} -result {1 1 1 1} -.c delete withtag all -set x [.c create oval 50 100 200 150 -fill green -outline {}] -set y [.c create oval 50 100 200 150 -fill red -outline black -width 3] -set z [.c create oval 50 100 200 150 -fill {} -outline black -width 3] -test canvRect-8.1 {OvalToArea procedure} { - list [.c find overlapping 20 120 48 130] \ - [.c find overlapping 20 120 49 130] \ - [.c find overlapping 20 120 50.2 130] \ - [.c find overlapping 20 120 300 130] \ - [.c find overlapping 60 120 190 130] \ - [.c find overlapping 199.9 120 300 130] \ - [.c find overlapping 201 120 300 130] \ - [.c find overlapping 202 120 300 130] -} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}" -test canvRect-8.2 {OvalToArea procedure} { - list [.c find overlapping 100 50 150 98] \ - [.c find overlapping 100 50 150 99] \ - [.c find overlapping 100 50 150 100.1] \ - [.c find overlapping 100 50 150 200] \ - [.c find overlapping 100 110 150 140] \ - [.c find overlapping 100 149.9 150 200] \ - [.c find overlapping 100 151 150 200] \ - [.c find overlapping 100 152 150 200] -} "{} {$y $z} {$x $y $z} {$x $y $z} {$x $y} {$x $y $z} {$y $z} {}" -test canvRect-8.3 {OvalToArea procedure} { - list [.c find overlapping 176 104 177 105] \ - [.c find overlapping 187 116 188 117] \ - [.c find overlapping 192 142 193 143] \ - [.c find overlapping 180 138 181 139] \ - [.c find overlapping 61 142 62 143] \ - [.c find overlapping 65 137 66 136] \ - [.c find overlapping 62 108 63 109] \ - [.c find overlapping 68 115 69 116] -} "{} {$x $y} {} {$x $y} {} {$x $y} {} {$x $y}" -test canvRect-9.1 {ScaleRectOval procedure} { +test canvRect-7.1 {RectToArea procedure} -body { + set xId [.c create rectangle 10 20 30 35 -fill green -outline {}] + set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] + set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 20 50 38 60] eq {}}] \ + [expr {[.c find overlapping 20 50 39 60] eq $yId}] \ + [expr {[.c find overlapping 20 50 70 60] eq $yId}] \ + [expr {[.c find overlapping 61 50 70 60] eq $yId}] \ + [expr {[.c find overlapping 62 50 70 60] eq {}}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1} +test canvRect-7.2 {RectToArea procedure} -body { + set xId [.c create rectangle 10 20 30 35 -fill green -outline {}] + set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] + set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 45 20 55 43] eq {}}] \ + [expr {[.c find overlapping 45 20 55 44] eq $yId}] \ + [expr {[.c find overlapping 45 20 55 80] eq $yId}] \ + [expr {[.c find overlapping 45 71 55 80] eq $yId}] \ + [expr {[.c find overlapping 45 72 55 80] eq {}}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1} +test canvRect-7.3 {RectToArea procedure} -body { + set xId [.c create rectangle 10 20 30 35 -fill green -outline {}] + set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] + set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 5 25 9.9 30] eq {}}] \ + [expr {[.c find overlapping 5 25 10.1 30] eq $xId}] +} -cleanup { + .c delete all +} -result {1 1} +test canvRect-7.4 {RectToArea procedure} -body { + set xId [.c create rectangle 10 20 30 35 -fill green -outline {}] + set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] + set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 102 152 118 168] eq {}}]\ + [expr {[.c find overlapping 101 152 118 168] eq $zId}] \ + [expr {[.c find overlapping 102 151 118 168] eq $zId}] \ + [expr {[.c find overlapping 102 152 119 168] eq $zId}] \ + [expr {[.c find overlapping 102 152 118 169] eq $zId}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1} +test canvRect-7.5 {RectToArea procedure} -body { + set xId [.c create rectangle 10 20 30 35 -fill green -outline {}] + set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] + set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] + list [expr {[.c find enclosed 20 40 38 80] eq {}}] \ + [expr {[.c find enclosed 20 40 39 80] eq {}}] \ + [expr {[.c find enclosed 20 40 70 80] eq $yId}] \ + [expr {[.c find enclosed 61 40 70 80] eq {}}] \ + [expr {[.c find enclosed 62 40 70 80] eq {}}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1} +test canvRect-7.6 {RectToArea procedure} -body { + set xId [.c create rectangle 10 20 30 35 -fill green -outline {}] + set yId [.c create rectangle 40 45 60 70 -fill red -outline black -width 3] + set zId [.c create rectangle 100 150 120 170 -fill {} -outline black -width 3] + list [expr {[.c find enclosed 20 20 65 43] eq {}}] \ + [expr {[.c find enclosed 20 20 65 44] eq {}}] \ + [expr {[.c find enclosed 20 20 65 80] eq $yId}] \ + [expr {[.c find enclosed 20 71 65 80] eq {}}] \ + [expr {[.c find enclosed 20 72 65 80] eq {}}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1} + + +test canvRect-8.1 {OvalToArea procedure} -body { + set xId [.c create oval 50 100 200 150 -fill green -outline {}] + set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3] + set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 20 120 48 130] eq {}}] \ + [expr {[.c find overlapping 20 120 49 130] eq "$yId $zId"}] \ + [expr {[.c find overlapping 20 120 50.2 130] eq "$xId $yId $zId"}] \ + [expr {[.c find overlapping 20 120 300 130] eq "$xId $yId $zId"}] \ + [expr {[.c find overlapping 60 120 190 130] eq "$xId $yId"}] \ + [expr {[.c find overlapping 199.9 120 300 130] eq "$xId $yId $zId"}] \ + [expr {[.c find overlapping 201 120 300 130] eq "$yId $zId"}] \ + [expr {[.c find overlapping 202 120 300 130] eq {}}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1 1 1 1} +test canvRect-8.2 {OvalToArea procedure} -body { + set xId [.c create oval 50 100 200 150 -fill green -outline {}] + set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3] + set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 100 50 150 98] eq {}}] \ + [expr {[.c find overlapping 100 50 150 99] eq "$yId $zId"}] \ + [expr {[.c find overlapping 100 50 150 100.1] eq "$xId $yId $zId"}] \ + [expr {[.c find overlapping 100 50 150 200] eq "$xId $yId $zId"}] \ + [expr {[.c find overlapping 100 110 150 140] eq "$xId $yId"}] \ + [expr {[.c find overlapping 100 149.9 150 200] eq "$xId $yId $zId"}] \ + [expr {[.c find overlapping 100 151 150 200] eq "$yId $zId"}] \ + [expr {[.c find overlapping 100 152 150 200] eq {}}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1 1 1 1} +test canvRect-8.3 {OvalToArea procedure} -body { + set xId [.c create oval 50 100 200 150 -fill green -outline {}] + set yId [.c create oval 50 100 200 150 -fill red -outline black -width 3] + set zId [.c create oval 50 100 200 150 -fill {} -outline black -width 3] + list [expr {[.c find overlapping 176 104 177 105] eq {}}] \ + [expr {[.c find overlapping 187 116 188 117] eq "$xId $yId"}] \ + [expr {[.c find overlapping 192 142 193 143] eq {}}] \ + [expr {[.c find overlapping 180 138 181 139] eq "$xId $yId"}] \ + [expr {[.c find overlapping 61 142 62 143] eq {}}] \ + [expr {[.c find overlapping 65 137 66 136] eq "$xId $yId"}] \ + [expr {[.c find overlapping 62 108 63 109] eq {}}] \ + [expr {[.c find overlapping 68 115 69 116] eq "$xId $yId"}] +} -cleanup { + .c delete all +} -result {1 1 1 1 1 1 1 1} + + +test canvRect-9.1 {ScaleRectOval procedure} -setup { .c delete withtag all +} -body { .c create rect 100 300 200 350 -tags x .c scale x 50 100 2 4 - .c coords x -} {150.0 900.0 350.0 1100.0} + format {%.6g %.6g %.6g %.6g} {*}[.c coords x] +} -result {150 900 350 1100} -test canvRect-10.1 {TranslateRectOval procedure} { +test canvRect-10.1 {TranslateRectOval procedure} -setup { .c delete withtag all +} -body { .c create rect 100 300 200 350 -tags x .c move x 100 -10 - .c coords x -} {200.0 290.0 300.0 340.0} + format {%.6g %.6g %.6g %.6g} {*}[.c coords x] +} -result {200 290 300 340} + -# This test is non-portable because different color information -# will get generated on different displays (e.g. mono displays -# vs. color). -test canvRect-11.1 {RectOvalToPostscript procedure} {nonPortable macCrash} { +test canvRect-11.1 {RectOvalToPostscript procedure} -constraints { + nonPortable macCrash +} -setup { + .c delete withtag all +} -body { # Crashes on Mac because the XGetImage() call isn't implemented, causing a # dereference of NULL. - + # This test is non-portable because different color information + # will get generated on different displays (e.g. mono displays + # vs. color). .c configure -bd 0 -highlightthickness 0 - .c delete withtag all .c create rect 50 60 90 80 -fill black -stipple gray50 -outline {} .c create oval 100 150 200 200 -fill {} -outline #ff0000 -width 5 update set x [.c postscript] string range $x [string first "-200 -150 translate" $x] end -} {-200 -150 translate +} -result {-200 -150 translate 0 300 moveto 400 300 lineto 400 0 lineto 0 0 lineto closepath clip newpath gsave 50 240 moveto 40 0 rlineto 0 -20 rlineto -40 0 rlineto closepath @@ -326,3 +469,7 @@ end # cleanup cleanupTests return + + + + diff --git a/tests/canvText.test b/tests/canvText.test index 070011b..f0c677f 100644 --- a/tests/canvText.test +++ b/tests/canvText.test @@ -6,134 +6,220 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# Canvas used in 1.* - 17.* tests canvas .c -width 400 -height 300 -bd 2 -relief sunken pack .c update -set i 1 +# Item used in 1.* tests .c create text 20 20 -tag test - -set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" -set ay [font metrics $font -linespace] -set ax [font measure $font 0] - - -foreach test { - {-anchor nw nw xyz {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center}} - {-fill #ff0000 #ff0000 xyz {unknown color name "xyz"}} - {-fill {} {} {} {}} - {-font {Times 40} {Times 40} {} {font "" doesn't exist}} - {-justify left left xyz {bad justification "xyz": must be left, right, or center}} - {-stipple gray50 gray50 xyz {bitmap "xyz" not defined}} - {-tags {test a b c} {test a b c} {} {}} - {-text xyz xyz {} {}} - {-underline 0 0 xyz {expected integer but got "xyz"}} - {-width 6 6 xyz {bad screen distance "xyz"}} -} { - lassign $test name goodValue goodResult badValue badResult - test canvText-1.$i "configuration options: good value for $name" { - .c itemconfigure test $name $goodValue - list [lindex [.c itemconfigure test $name] 4] [.c itemcget test $name] - } [list $goodResult $goodResult] - incr i - if {$badValue ne ""} { - test canvText-1.$i "configuration options: bad value for $name" -body { - .c itemconfigure test $name $badValue - } -returnCodes error -result $badResult - } - incr i -} -test canvText-1.$i {configuration options} { - .c itemconfigure test -tags {test xyz} - .c itemcget xyz -tags -} {test xyz} - +test canvText-1.1 {configuration options: good value for "anchor"} -body { + .c itemconfigure test -anchor nw + list [lindex [.c itemconfigure test -anchor] 4] [.c itemcget test -anchor] +} -result {nw nw} +test canvasText-1.2 {configuration options: bad value for "anchor"} -body { + .c itemconfigure test -anchor xyz +} -returnCodes error -result {bad anchor position "xyz": must be n, ne, e, se, s, sw, w, nw, or center} +test canvText-1.3 {configuration options: good value for "fill"} -body { + .c itemconfigure test -fill #ff0000 + list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill] +} -result {{#ff0000} #ff0000} +test canvasText-1.4 {configuration options: bad value for "fill"} -body { + .c itemconfigure test -fill xyz +} -returnCodes error -result {unknown color name "xyz"} +test canvText-1.5 {configuration options: good value for "fill"} -body { + .c itemconfigure test -fill {} + list [lindex [.c itemconfigure test -fill] 4] [.c itemcget test -fill] +} -result {{} {}} +test canvText-1.6 {configuration options: good value for "font"} -body { + .c itemconfigure test -font {Times 40} + list [lindex [.c itemconfigure test -font] 4] [.c itemcget test -font] +} -result {{Times 40} {Times 40}} +test canvasText-1.7 {configuration options: bad value for "font"} -body { + .c itemconfigure test -font {} +} -returnCodes error -result {font "" doesn't exist} +test canvText-1.8 {configuration options: good value for "justify"} -body { + .c itemconfigure test -justify left + list [lindex [.c itemconfigure test -justify] 4] [.c itemcget test -justify] +} -result {left left} +test canvasText-1.9 {configuration options: bad value for "justify"} -body { + .c itemconfigure test -justify xyz +} -returnCodes error -result {bad justification "xyz": must be left, right, or center} +test canvText-1.10 {configuration options: good value for "stipple"} -body { + .c itemconfigure test -stipple gray50 + list [lindex [.c itemconfigure test -stipple] 4] [.c itemcget test -stipple] +} -result {gray50 gray50} +test canvasText-1.11 {configuration options: bad value for "stipple"} -body { + .c itemconfigure test -stipple xyz +} -returnCodes error -result {bitmap "xyz" not defined} +test canvText-1.12 {configuration options: good value for "underline"} -body { + .c itemconfigure test -underline 0 + list [lindex [.c itemconfigure test -underline] 4] [.c itemcget test -underline] +} -result {0 0} +test canvasText-1.13 {configuration options: bad value for "underline"} -body { + .c itemconfigure test -underline xyz +} -returnCodes error -result {expected integer but got "xyz"} +test canvText-1.14 {configuration options: good value for "width"} -body { + .c itemconfigure test -width 6 + list [lindex [.c itemconfigure test -width] 4] [.c itemcget test -width] +} -result {6 6} +test canvasText-1.15 {configuration options: bad value for "width"} -body { + .c itemconfigure test -width xyz +} -returnCodes error -result {bad screen distance "xyz"} +test canvText-1.16 {configuration options: good value for "tags"} -body { + .c itemconfigure test -tags {test a b c} + list [lindex [.c itemconfigure test -tags] 4] [.c itemcget test -tags] +} -result {{test a b c} {test a b c}} +test canvasText-1.17 {configuration options: bad value for "angle"} -body { + .c itemconfigure test -angle xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test canvasText-1.18 {configuration options: good value for "angle"} -body { + .c itemconfigure test -angle 32.5 + list [lindex [.c itemconfigure test -angle] 4] [.c itemcget test -angle] +} -result {32.5 32.5} +test canvasText-1.19 {configuration options: bounding of "angle"} -body { + .c itemconfigure test -angle 390 + set result [.c itemcget test -angle] + .c itemconfigure test -angle -30 + lappend result [.c itemcget test -angle] + .c itemconfigure test -angle -360 + lappend result [.c itemcget test -angle] +} -result {30.0 330.0 0.0} .c delete test -.c create text 20 20 -tag test -test canvText-2.1 {CreateText procedure: args} { - list [catch {.c create text} msg] $msg -} {1 {wrong # args: should be ".c create text coords ?arg arg ...?"}} -test canvText-2.2 {CreateText procedure: args} { - list [catch {.c create text xyz 0} msg] $msg -} {1 {bad screen distance "xyz"}} -test canvText-2.3 {CreateText procedure: args} { - list [catch {.c create text 0 xyz} msg] $msg -} {1 {bad screen distance "xyz"}} -test canvText-2.4 {CreateText procedure: args} { - list [catch {.c create text 0 0 -xyz xyz} msg] $msg -} {1 {unknown option "-xyz"}} -test canvText-2.5 {CreateText procedure} { + +test canvText-2.1 {CreateText procedure: args} -body { + .c create text +} -returnCodes {error} -result {wrong # args: should be ".c create text coords ?arg ...?"} +test canvText-2.2 {CreateText procedure: args} -body { + .c create text xyz 0 +} -cleanup { + .c delete all +} -returnCodes {error} -result {bad screen distance "xyz"} +test canvText-2.3 {CreateText procedure: args} -body { + .c create text 0 xyz +} -cleanup { + .c delete all +} -returnCodes {error} -result {bad screen distance "xyz"} +test canvText-2.4 {CreateText procedure: args} -body { + .c create text 0 0 -xyz xyz +} -cleanup { + .c delete all +} -returnCodes {error} -result {unknown option "-xyz"} +test canvText-2.5 {CreateText procedure} -body { .c create text 0 0 -tags x - set x [.c coords x] + .c coords x +} -cleanup { .c delete x - set x -} {0.0 0.0} +} -result {0.0 0.0} -focus -force .c -.c focus test -.c coords test 0 0 -update -test canvText-3.1 {TextCoords procedure} { +test canvText-3.1 {TextCoords procedure} -body { + .c create text 20 20 -tag test + .c coords test 0 0 + update .c coords test -} {0.0 0.0} -test canvText-3.2 {TextCoords procedure} { - list [catch {.c coords test xyz 0} msg] $msg -} {1 {bad screen distance "xyz"}} -test canvText-3.3 {TextCoords procedure} { - list [catch {.c coords test 0 xyz} msg] $msg -} {1 {bad screen distance "xyz"}} -test canvText-3.4 {TextCoords procedure} { +} -cleanup { + .c delete test +} -result {0.0 0.0} +test canvText-3.2 {TextCoords procedure} -setup { + .c create text 20 20 -tag test +} -body { + .c coords test xyz 0 +} -cleanup { + .c delete test +} -returnCodes {error} -result {bad screen distance "xyz"} +test canvText-3.3 {TextCoords procedure} -setup { + .c create text 20 20 -tag test +} -body { + .c coords test 0 xyz +} -cleanup { + .c delete test +} -returnCodes {error} -result {bad screen distance "xyz"} +test canvText-3.4 {TextCoords procedure} -setup { + .c create text 20 20 -tag test +} -body { .c coords test 10 10 set result {} foreach element [.c coords test] { lappend result [format %.1f $element] } - set result -} {10.0 10.0} -test canvText-3.5 {TextCoords procedure} { - list [catch {.c coords test 10} msg] $msg -} {1 {wrong # coordinates: expected 2, got 1}} -test canvText-3.6 {TextCoords procedure} { - list [catch {.c coords test 10 10 10} msg] $msg -} {1 {wrong # coordinates: expected 0 or 2, got 3}} - -test canvText-4.1 {ConfigureText procedure} { - list [catch {.c itemconfig test -fill xyz} msg] $msg -} {1 {unknown color name "xyz"}} -test canvText-4.2 {ConfigureText procedure} { + return $result +} -cleanup { + .c delete test +} -result {10.0 10.0} +test canvText-3.5 {TextCoords procedure} -setup { + .c create text 20 20 -tag test +} -body { + .c coords test 10 +} -cleanup { + .c delete test +} -returnCodes {error} -result {wrong # coordinates: expected 2, got 1} +test canvText-3.6 {TextCoords procedure} -setup { + .c create text 20 20 -tag test +} -body { + .c coords test 10 10 10 +} -cleanup { + .c delete test +} -returnCodes {error} -result {wrong # coordinates: expected 0 or 2, got 3} + + +test canvText-4.1 {ConfigureText procedure} -setup { + .c create text 20 20 -tag test +} -body { + .c itemconfig test -fill xyz +} -cleanup { + .c delete test +} -returnCodes {error} -result {unknown color name "xyz"} +test canvText-4.2 {ConfigureText procedure} -setup { + .c create text 20 20 -tag test +} -body { .c itemconfig test -fill blue .c itemcget test -fill -} {blue} -test canvText-4.3 {ConfigureText procedure: construct font gcs} { +} -cleanup { + .c delete test +} -result {blue} +test canvText-4.3 {ConfigureText procedure: construct font gcs} -setup { + .c create text 20 20 -tag test +} -body { .c itemconfig test -font "times 20" -fill black -stipple gray50 list [.c itemcget test -font] [.c itemcget test -fill] [.c itemcget test -stipple] -} {{times 20} black gray50} -test canvText-4.4 {ConfigureText procedure: construct cursor gc} { +} -cleanup { + .c delete test +} -result {{times 20} black gray50} +test canvText-4.4 {ConfigureText procedure: construct cursor gc} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c icursor test 3 - # Both black -> cursor becomes white. .c config -insertbackground black .c config -selectbackground black .c itemconfig test -just left update - # Both same color (and not black) -> cursor becomes black. .c config -insertbackground red .c config -selectbackground red .c itemconfig test -just left update -} {} -test canvText-4.5 {ConfigureText procedure: adjust selection} { +} -cleanup { + .c delete test +} -result {} +test canvText-4.5 {ConfigureText procedure: adjust selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test set x {} +} -body { .c itemconfig test -text "abcdefghi" .c select from test 2 .c select to test 6 @@ -152,89 +238,250 @@ test canvText-4.5 {ConfigureText procedure: adjust selection} { lappend x [selection get] .c dchars test 4 end lappend x [selection get] -} {cdefg 1 cdefg cd cdef cd} -test canvText-4.6 {ConfigureText procedure: adjust cursor} { +} -cleanup { + .c delete test +} -result {cdefg 1 cdefg cd cdef cd} +test canvText-4.6 {ConfigureText procedure: adjust cursor} -setup { + .c create text 20 20 -tag test +} -body { .c itemconfig test -text "abcdefghi" - set x {} .c icursor test 6 .c dchars test 4 end .c index test insert -} {4} +} -cleanup { + .c delete test +} -result {4} + -test canvText-5.1 {ConfigureText procedure: adjust cursor} { - .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 -text "xyz" +test canvText-5.1 {ConfigureText procedure: adjust cursor} -body { + .c create text 10 10 -tag x -fill blue -font "times 40" -stipple gray50 \ + -text "xyz" .c delete x -} {} +} -result {} + -test canvText-6.1 {ComputeTextBbox procedure} {fonts nonPortable} { +test canvText-6.1 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test .c itemconfig test -font $font -text 0 - .c coords test 0 0 - set x {} - lappend x [.c itemconfig test -anchor n; .c bbox test] - lappend x [.c itemconfig test -anchor nw; .c bbox test] - lappend x [.c itemconfig test -anchor w; .c bbox test] - lappend x [.c itemconfig test -anchor sw; .c bbox test] - lappend x [.c itemconfig test -anchor s; .c bbox test] - lappend x [.c itemconfig test -anchor se; .c bbox test] - lappend x [.c itemconfig test -anchor e; .c bbox test] - lappend x [.c itemconfig test -anchor ne; .c bbox test] - lappend x [.c itemconfig test -anchor center; .c bbox test] -} "{[expr -$ax/2-1] 0 [expr $ax/2+1] $ay}\ -{-1 0 [expr $ax+1] $ay}\ -{-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]}\ -{-1 -$ay [expr $ax+1] 0}\ -{[expr -$ax/2-1] -$ay [expr $ax/2+1] 0}\ -{[expr -$ax-1] -$ay 1 0}\ -{[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]}\ -{[expr -$ax-1] 0 1 $ay}\ -{[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]}" + expr {[.c itemconfig test -anchor n; .c bbox test] \ + eq "[expr -$ax/2-1] 0 [expr $ax/2+1] $ay"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.2 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor nw; .c bbox test] \ + eq "-1 0 [expr $ax+1] $ay"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.3 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor w; .c bbox test] \ + eq "-1 [expr -$ay/2] [expr $ax+1] [expr $ay/2]"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.4 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor sw; .c bbox test] \ + eq "-1 -$ay [expr $ax+1] 0"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.5 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor s; .c bbox test] \ + eq "[expr -$ax/2-1] -$ay [expr $ax/2+1] 0"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.6 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor se; .c bbox test] \ + eq "[expr -$ax-1] -$ay 1 0"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.7 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor e; .c bbox test]\ + eq "[expr -$ax-1] [expr -$ay/2] 1 [expr $ay/2]"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.8 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor ne; .c bbox test] \ + eq "[expr -$ax-1] 0 1 $ay"} +} -cleanup { + .c delete test +} -result 1 +test canvText-6.9 {ComputeTextBbox procedure} -constraints fonts -setup { + .c delete test +} -body { + set font "-adobe-times-medium-r-normal--*-200-*-*-*-*-*-*" + set ay [font metrics $font -linespace] + set ax [font measure $font 0] + .c create text 0 0 -tag test + .c itemconfig test -font $font -text 0 + expr {[.c itemconfig test -anchor center; .c bbox test] \ + eq "[expr -$ax/2-1] [expr -$ay/2] [expr $ax/2+1] [expr $ay/2]"} +} -cleanup { + .c delete test +} -result 1 + +#.c delete test +#.c create text 20 20 -tag test +#focus -force .c +#.c focus test focus .c .c focus test .c itemconfig test -text "abcd\nefghi\njklmnopq" -test canvText-7.0 {DisplayText procedure: stippling} { +test canvText-7.1 {DisplayText procedure: stippling} -body { + .c create text 20 20 -tag test .c itemconfig test -stipple gray50 update .c itemconfig test -stipple {} update -} {} -test canvText-7.2 {DisplayText procedure: draw selection} { +} -cleanup { + .c delete test +} -result {} +test canvText-7.2 {DisplayText procedure: draw selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 0 .c select to test end update selection get -} "abcd\nefghi\njklmnopq" -test canvText-7.3 {DisplayText procedure: selection} { +} -cleanup { + .c delete test +} -result "abcd\nefghi\njklmnopq" +test canvText-7.3 {DisplayText procedure: selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 0 .c select to test end update selection get -} "abcd\nefghi\njklmnopq" -test canvText-7.4 {DisplayText procedure: one line selection} { +} -cleanup { + .c delete test +} -result "abcd\nefghi\njklmnopq" +test canvText-7.4 {DisplayText procedure: one line selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 2 .c select to test 3 update -} {} -test canvText-7.5 {DisplayText procedure: multi-line selection} { +} -cleanup { + .c delete test +} -result {} +test canvText-7.5 {DisplayText procedure: multi-line selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcd\nefghi\njklmnopq" .c select from test 2 .c select to test 12 update -} {} -test canvText-7.6 {DisplayText procedure: draw cursor} { +} -cleanup { + .c delete test +} -result {} +test canvText-7.6 {DisplayText procedure: draw cursor} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcd\nefghi\njklmnopq" .c icursor test 3 update -} {} -test canvText-7.7 {DisplayText procedure: selected text different color} { +} -cleanup { + .c delete test +} -result {} +test canvText-7.7 {DisplayText procedure: selected text different color} -setup { + .c create text 20 20 -tag test + .c itemconfig test -text "abcd\nefghi\njklmnopq" + focus .c + .c focus test +} -body { .c config -selectforeground blue .c itemconfig test -anchor n update -} {} -test canvText-7.8 {DisplayText procedure: not selected} { +} -cleanup { + .c delete test +} -result {} +test canvText-7.8 {DisplayText procedure: not selected} -setup { + .c create text 20 20 -tag test + .c itemconfig test -text "abcd\nefghi\njklmnopq" + focus .c + .c focus test +} -body { .c select clear update -} {} -test canvText-7.9 {DisplayText procedure: select end} { - catch {destroy .t} +} -cleanup { + .c delete test +} -result {} +test canvText-7.9 {DisplayText procedure: select end} -setup { + destroy .t +} -body { toplevel .t wm geometry .t +0+0 canvas .t.c @@ -246,287 +493,398 @@ test canvText-7.9 {DisplayText procedure: select end} { update #catch {destroy .t} update -} {} - -test canvText-8.1 {TextInsert procedure: 0 length insert} { +} -cleanup { + destroy .t +} -result {} + +test canvText-8.1 {TextInsert procedure: 0 length insert} -setup { + .c create text 20 20 -tag test + .c itemconfig test -text "abcd\nefghi\njklmnopq" + focus .c + .c focus test +} -body { .c insert test end {} -} {} -test canvText-8.2 {TextInsert procedure: before beginning/after end} { +} -cleanup { + .c delete test +} -result {} +test canvText-8.2 {TextInsert procedure: before beginning/after end} -body { # Can't test this because GetTextIndex filters out those numbers. -} {} -test canvText-8.3 {TextInsert procedure: inserting in a selected item} { +} -result {} +test canvText-8.3 {TextInsert procedure: inserting in a selected item} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 1 "xyz" .c itemcget test -text -} {axyzbcdefg} -test canvText-8.4 {TextInsert procedure: inserting before selection} { +} -result {axyzbcdefg} +test canvText-8.4 {TextInsert procedure: inserting before selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 1 "xyz" list [.c index test sel.first] [.c index test sel.last] -} {5 7} -test canvText-8.5 {TextInsert procedure: inserting in selection} { +} -result {5 7} +test canvText-8.5 {TextInsert procedure: inserting in selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 3 "xyz" list [.c index test sel.first] [.c index test sel.last] -} {2 7} -test canvText-8.6 {TextInsert procedure: inserting after selection} { +} -result {2 7} +test canvText-8.6 {TextInsert procedure: inserting after selection} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c insert test 5 "xyz" list [.c index test sel.first] [.c index test sel.last] -} {2 4} -test canvText-8.7 {TextInsert procedure: inserting in unselected item} { +} -result {2 4} +test canvText-8.7 {TextInsert procedure: inserting in unselected item} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c select clear .c insert test 5 "xyz" .c itemcget test -text -} {abcdexyzfg} -test canvText-8.8 {TextInsert procedure: inserting before cursor} { +} -result {abcdexyzfg} +test canvText-8.8 {TextInsert procedure: inserting before cursor} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c icursor test 3 .c insert test 2 "xyz" .c index test insert -} {6} -test canvText-8.9 {TextInsert procedure: inserting after cursor} { +} -result {6} +test canvText-8.9 {TextInsert procedure: inserting after cursor} -setup { + .c create text 20 20 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefg" .c icursor test 3 .c insert test 4 "xyz" .c index test insert -} {3} +} -result {3} -test canvText-9.1 {TextInsert procedure: before beginning/after end} { +# Item used in 9.* tests +.c create text 20 20 -tag test +test canvText-9.1 {TextInsert procedure: before beginning/after end} -body { # Can't test this because GetTextIndex filters out those numbers. -} {} -test canvText-9.2 {TextInsert procedure: start > end} { +} -result {} +test canvText-9.2 {TextInsert procedure: start > end} -body { .c itemconfig test -text "abcdefg" .c dchars test 4 2 .c itemcget test -text -} {abcdefg} -test canvText-9.3 {TextInsert procedure: deleting from a selected item} { +} -result {abcdefg} +test canvText-9.3 {TextInsert procedure: deleting from a selected item} -body { .c itemconfig test -text "abcdefg" .c select from test 2 .c select to test 4 .c dchars test 3 5 .c itemcget test -text -} {abcg} -test canvText-9.4 {TextInsert procedure: deleting before start} { +} -result {abcg} +test canvText-9.4 {TextInsert procedure: deleting before start} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 1 1 list [.c index test sel.first] [.c index test sel.last] -} {3 7} -test canvText-9.5 {TextInsert procedure: keep start > first char deleted} { +} -result {3 7} +test canvText-9.5 {TextInsert procedure: keep start > first char deleted} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 2 6 list [.c index test sel.first] [.c index test sel.last] -} {2 3} -test canvText-9.6 {TextInsert procedure: deleting inside selection} { +} -result {2 3} +test canvText-9.6 {TextInsert procedure: deleting inside selection} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 6 6 list [.c index test sel.first] [.c index test sel.last] -} {4 7} -test canvText-9.7 {TextInsert procedure: keep end > first char deleted} { +} -result {4 7} +test canvText-9.7 {TextInsert procedure: keep end > first char deleted} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 6 10 list [.c index test sel.first] [.c index test sel.last] -} {4 5} -test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} { +} -result {4 5} +test canvText-9.8 {TextInsert procedure: selectFirst > selectLast: deselect} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 3 10 - list [catch {.c index test sel.first} msg] $msg -} {1 {selection isn't in item}} -test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} { + .c index test sel.first +} -returnCodes {error} -result {selection isn't in item} +test canvText-9.9 {TextInsert procedure: selectFirst <= selectLast} -body { .c itemconfig test -text "abcdefghijk" .c select from test 4 .c select to test 8 .c dchars test 4 7 list [.c index test sel.first] [.c index test sel.last] -} {4 4} -test canvText-9.10 {TextInsert procedure: move anchor} { +} -result {4 4} +test canvText-9.10 {TextInsert procedure: move anchor} -body { .c itemconfig test -text "abcdefghijk" .c select from test 6 .c select to test 8 .c dchars test 2 4 .c select to test 1 list [.c index test sel.first] [.c index test sel.last] -} {1 2} -test canvText-9.11 {TextInsert procedure: keep anchor >= first} { +} -result {1 2} +test canvText-9.11 {TextInsert procedure: keep anchor >= first} -body { .c itemconfig test -text "abcdefghijk" .c select from test 6 .c select to test 8 .c dchars test 5 7 .c select to test 1 list [.c index test sel.first] [.c index test sel.last] -} {1 4} -test canvText-9.12 {TextInsert procedure: anchor doesn't move} { +} -result {1 4} +test canvText-9.12 {TextInsert procedure: anchor doesn't move} -body { .c itemconfig test -text "abcdefghijk" .c select from test 2 .c select to test 5 .c dchars test 6 8 .c select to test 8 list [.c index test sel.first] [.c index test sel.last] -} {2 8} -test canvText-9.13 {TextInsert procedure: move cursor} { +} -result {2 8} +test canvText-9.13 {TextInsert procedure: move cursor} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 6 .c dchars test 2 4 .c index test insert -} {3} -test canvText-9.14 {TextInsert procedure: keep cursor >= first} { +} -result {3} +test canvText-9.14 {TextInsert procedure: keep cursor >= first} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 6 .c dchars test 2 10 .c index test insert -} {2} -test canvText-9.15 {TextInsert procedure: cursor doesn't move} { +} -result {2} +test canvText-9.15 {TextInsert procedure: cursor doesn't move} -body { .c itemconfig test -text "abcdefghijk" .c icursor test 5 .c dchars test 7 9 .c index test insert -} {5} +} -result {5} +.c delete test -test canvText-10.1 {TextToPoint procedure} { - .c coords test 0 0 + +test canvText-10.1 {TextToPoint procedure} -body { + .c create text 0 0 -tag test .c itemconfig test -text 0 -anchor center .c index test @0,0 -} {0} +} -cleanup { + .c delete test +} -result {0} -test canvText-11.1 {TextToArea procedure} { - .c coords test 0 0 + +test canvText-11.1 {TextToArea procedure} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text 0 -anchor center - .c find overlapping 0 0 1 1 -} [.c find withtag test] -test canvText-11.2 {TextToArea procedure} { - .c coords test 0 0 + set res1 [.c find overlapping 0 0 1 1] + set res2 [.c find withtag test] + expr {$res1 eq $res2} +} -cleanup { + .c delete test +} -result 1 +test canvText-11.2 {TextToArea procedure} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text 0 -anchor center .c find overlapping 1000 1000 1001 1001 -} {} +} -cleanup { + .c delete test +} -result {} -test canvText-12.1 {ScaleText procedure} { - .c coords test 100 100 + +test canvText-12.1 {ScaleText procedure} -body { + .c create text 100 100 -tag test .c scale all 50 50 2 2 format {%.6g %.6g} {*}[.c coords test] -} {150 150} +} -cleanup { + .c delete test +} -result {150 150} + -test canvText-13.1 {TranslateText procedure} { - .c coords test 100 100 +test canvText-13.1 {TranslateText procedure} -body { + .c create text 100 100 -tag test .c move all 10 10 format {%.6g %.6g} {*}[.c coords test] -} {110 110} - -.c itemconfig test -text "abcdefghijklmno" -anchor nw -.c select from test 5 -.c select to test 8 -.c icursor test 12 -.c coords test 0 0 -test canvText-14.1 {GetTextIndex procedure} { +} -cleanup { + .c delete test +} -result {110 110} + + +test canvText-14.1 {GetTextIndex procedure} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcdefghijklmno" -anchor nw + .c select from test 5 + .c select to test 8 + .c icursor test 12 + .c coords test 0 0 list [.c index test end] [.c index test insert] \ [.c index test sel.first] [.c index test sel.last] \ [.c index test @0,0] \ [.c index test -1] [.c index test 10] [.c index test 100] -} {15 12 5 8 0 0 10 15} -test canvText-14.2 {GetTextIndex procedure: select error} { +} -cleanup { + .c delete test +} -result {15 12 5 8 0 0 10 15} +test canvText-14.2 {GetTextIndex procedure: select error} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { .c select clear - list [catch {.c index test sel.first} msg] $msg -} {1 {selection isn't in item}} -test canvText-14.3 {GetTextIndex procedure: select error} { + .c index test sel.first +} -cleanup { + .c delete test +} -returnCodes {error} -result {selection isn't in item} +test canvText-14.3 {GetTextIndex procedure: select error} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { .c select clear - list [catch {.c index test sel.last} msg] $msg -} {1 {selection isn't in item}} -test canvText-14.4 {GetTextIndex procedure: select error} { + .c index test sel.last +} -cleanup { + .c delete test +} -returnCodes {error} -result {selection isn't in item} +test canvText-14.4 {GetTextIndex procedure: select error} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { .c select clear - list [catch {.c index test sel.} msg] $msg -} {1 {bad index "sel."}} -test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} { - list [catch {.c index test xyz} msg] $msg -} {1 {bad index "xyz"}} -test canvText-14.6 {select clear errors} -body { + .c index test sel. +} -cleanup { + .c delete test +} -returnCodes {error} -result {bad index "sel."} +test canvText-14.5 {GetTextIndex procedure: bad int or unknown index} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { + .c index test xyz +} -cleanup { + .c delete test +} -returnCodes {error} -result {bad index "xyz"} +test canvText-14.6 {select clear errors} -setup { + .c create text 0 0 -tag test +} -body { .c select clear test +} -cleanup { + .c delete test } -returnCodes error -result "wrong \# args: should be \".c select clear\"" -test canvText-15.1 {SetTextCursor procedure} { +test canvText-15.1 {SetTextCursor procedure} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { + .c itemconfig test -text "abcdefghijklmno" -anchor nw .c itemconfig -text "abcdefg" .c icursor test 3 .c index test insert -} {3} - -test canvText-16.1 {GetSelText procedure} { +} -cleanup { + .c delete test +} -result {3} + +test canvText-16.1 {GetSelText procedure} -setup { + .c create text 0 0 -tag test + focus .c + .c focus test +} -body { .c itemconfig test -text "abcdefghijklmno" -anchor nw .c select from test 5 .c select to test 8 selection get -} {fghi} +} -cleanup { + .c delete test +} -result {fghi} -set font {Courier 12 italic} -set ax [font measure $font 0] -set ay [font metrics $font -linespace] - -test canvText-17.1 {TextToPostscript procedure} { +test canvText-17.1 {TextToPostscript procedure} -setup { .c delete all - .c config -height 300 -highlightthickness 0 -bd 0 - update - .c create text 100 100 -tags test - .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax] - .c itemconfig test -anchor n -fill black - set x [.c postscript] - set x [string range $x [string first "/Courier-Oblique" $x] end] -} "/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont + set result {/Courier-Oblique findfont [font actual $font -size] scalefont ISOEncode setfont 0.000 0.000 0.000 setrgbcolor AdjustColor -100 200 \[ +0 100 200 \[ \[(000)\] \[(000)\] \[(00)\] -] $ay -0.5 0.0 0 false DrawText +\] $ay -0.5 0 0 false DrawText grestore restore showpage %%Trailer end %%EOF -" +} +} -body { + set font {Courier 12 italic} + set ax [font measure $font 0] + set ay [font metrics $font -linespace] + .c config -height 300 -highlightthickness 0 -bd 0 + update + .c create text 100 100 -tags test + .c itemconfig test -font $font -text "00000000" -width [expr 3*$ax] + .c itemconfig test -anchor n -fill black + set x [.c postscript] + set x [string range $x [string first "/Courier-Oblique" $x] end] + expr {$x eq [subst $result] ? "ok" : $x} +} -result ok -test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} { - catch {destroy .c} - canvas .c - pack .c - .c delete all +test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -setup { + destroy .c +} -body { + pack [canvas .c] .c create text 100 100 -text Hello\n -anchor nw set bbox [.c bbox 1] set x2 [lindex $bbox 2] set y2 [lindex $bbox 3] incr y2 update - .c find enclosed 99 99 [expr $x2 + $i] [expr $y2 + 1] -} 1 + .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1] +} -cleanup { + destroy .c +} -result 1 -test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} { - catch {destroy .c} +test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} -setup { + destroy .c set c [canvas .c -bg black -width 964] pack $c $c delete all - after 1000 "set done 1" ; vwait done - + after 100 "set done 1"; vwait done +} -body { set f {Arial 28 bold} - set s1 { Yeah-ah-ah-ah-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-oh-Yow} set s2 { Yeah ah ah ah oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh oh Yow} - $c create text 21 18 \ -font $f \ -text $s1 \ @@ -534,8 +892,7 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} { -width 922 \ -anchor nw \ -tags tbox1 - eval {$c create rect} [$c bbox tbox1] -outline red - + $c create rect {*}[$c bbox tbox1] -outline red $c create text 21 160 \ -font $f \ -text $s2 \ @@ -543,32 +900,49 @@ test canvText-19.1 {patch 1006286, leading space caused wrap under Win32} { -width 922 \ -anchor nw \ -tags tbox2 - eval {$c create rect} [$c bbox tbox2] -outline red - - after 1000 "set done 1" ; vwait done - + $c create rect {*}[$c bbox tbox2] -outline red + after 500 "set done 1" ; vwait done set results [list] - $c select from tbox2 4 $c select to tbox2 8 lappend results [selection get] - $c select from tbox1 4 $c select to tbox1 8 lappend results [selection get] - array set metrics [font metrics $f] set x [expr {21 + [font measure $f " "] \ + ([font measure {Arial 28 bold} "Y"] / 2)}] set y1 [expr {18 + ($metrics(-linespace) / 2)}] set y2 [expr {160 + ($metrics(-linespace) / 2)}] - lappend results [$c index tbox1 @$x,$y1] lappend results [$c index tbox2 @$x,$y2] +} -cleanup { + destroy .c +} -result {{Yeah } Yeah- 4 4} - set results -} {{Yeah } Yeah- 4 4} - +test canvText-20.1 {angled text bounding box} -setup { + destroy .c + canvas .c + proc transpose {bbox} { + lassign $bbox a b c d + list $b $a $d $c + } +} -body { + .c create text 2 2 -tag t -anchor center -text 0 -font {Helvetica 24} + set bb0 [.c bbox t] + .c itemconf t -angle 90 + set bb1 [.c bbox t] + .c itemconf t -angle 180 + set bb2 [.c bbox t] + .c itemconf t -angle 270 + set bb3 [.c bbox t] + list [expr {$bb0 eq $bb2 ? "ok" : "$bb0,$bb2"}] \ + [expr {$bb1 eq $bb3 ? "ok" : "$bb1,$bb3"}] \ + [expr {$bb0 eq [transpose $bb1] ? "ok" : "$bb0,$bb1"}] \ +} -cleanup { + destroy .c + rename transpose {} +} -result {ok ok ok} # cleanup cleanupTests diff --git a/tests/canvWind.test b/tests/canvWind.test index 9844ff0..436ee2c 100644 --- a/tests/canvWind.test +++ b/tests/canvWind.test @@ -6,12 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { - catch {destroy .t} +test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -37,9 +39,13 @@ test canvWind-1.1 {DisplayWinItem, windows off-screen vertically} { .t.c yview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo y $f]] -} {{1 23} {1 -29} {0 -29} {1 225} {0 225}} -test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 23} {1 -29} {0 -29} {1 225} {0 225}} + +test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -65,9 +71,13 @@ test canvWind-1.2 {DisplayWinItem, windows off-screen vertically} { .t.c yview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo y $f]] -} {{1 3} {1 -49} {0 -49} {1 205} {0 205}} -test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 3} {1 -49} {0 -49} {1 205} {0 205}} + +test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -93,9 +103,13 @@ test canvWind-1.3 {DisplayWinItem, windows off-screen horizontally} { .t.c xview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo x $f]] -} {{1 23} {1 -59} {0 -59} {1 275} {0 275}} -test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 23} {1 -59} {0 -59} {1 275} {0 275}} + +test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} -setup { + destroy .t +} -body { toplevel .t canvas .t.c -scrollregion {0 0 1000 800} -width 250 -height 200 -bd 2 \ -relief sunken -xscrollincrement 1 -yscrollincrement 1 \ @@ -121,8 +135,9 @@ test canvWind-1.4 {DisplayWinItem, windows off-screen horizontally} { .t.c xview scroll -1 units update lappend x [list [winfo ismapped $f] [winfo x $f]] -} {{1 3} {1 -79} {0 -79} {1 255} {0 255}} -catch {destroy .t} +} -cleanup { + destroy .t +} -result {{1 3} {1 -79} {0 -79} {1 255} {0 255}} # cleanup cleanupTests diff --git a/tests/canvas.test b/tests/canvas.test index 6fea894..f5b33cc 100644 --- a/tests/canvas.test +++ b/tests/canvas.test @@ -1,95 +1,213 @@ -# This file is a Tcl script to test out the procedures in tkCanvas.c, -# which implements generic code for canvases. It is organized in the -# standard fashion for Tcl tests. +# This file is a Tcl script to test out the procedures in tkCanvas.c, which +# implements generic code for canvases. It is organized in the standard +# fashion for Tcl tests. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright (c) 2008 Donal K. Fellows # All rights reserved. package require tcltest 2.1 eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit -# XXX - This test file is woefully incomplete. At present, only a -# few of the features are tested. +# XXX - This test file is woefully incomplete. At present, only a few of the +# features are tested. +# Canvas used in 1.* test cases canvas .c pack .c update -set i 1 -foreach {testname testinfo} { - canvas-1.1 {-background #ff0000 #ff0000 - non-existent {unknown color name "non-existent"}} - canvas-1.2 {-bg #ff0000 #ff0000 - non-existent {unknown color name "non-existent"}} - canvas-1.3 {-bd 4 4 badValue {bad screen distance "badValue"}} - canvas-1.4 {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - canvas-1.5 {-closeenough 24 24.0 - bogus {expected floating-point number but got "bogus"}} - canvas-1.6 {-confine true 1 silly {expected boolean value but got "silly"}} - canvas-1.7 {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - canvas-1.8 {-height 2.1 2 x42 {bad screen distance "x42"}} - canvas-1.9 {-highlightbackground #112233 #112233 - ugly {unknown color name "ugly"}} - canvas-1.10 {-highlightcolor #110022 #110022 - bogus {unknown color name "bogus"}} - canvas-1.11 {-highlightthickness 18 18 - badValue {bad screen distance "badValue"}} - canvas-1.12 {-insertbackground #110022 #110022 - bogus {unknown color name "bogus"}} - canvas-1.13 {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} - canvas-1.14 {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} - canvas-1.15 {-insertontime 100 100 3.2 {expected integer but got "3.2"}} - canvas-1.16 {-insertwidth 1.3 1 6x {bad screen distance "6x"}} - canvas-1.17 {-relief groove groove - 1.5 {bad relief type "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - canvas-1.18 {-selectbackground #110022 #110022 - bogus {unknown color name "bogus"}} - canvas-1.19 {-selectborderwidth 1.3 1 - badValue {bad screen distance "badValue"}} - canvas-1.20 {-selectforeground #654321 #654321 - bogus {unknown color name "bogus"}} - canvas-1.21 {-takefocus "any string" "any string" {} {}} - canvas-1.22 {-width 402 402 xyz {bad screen distance "xyz"}} - canvas-1.23 {-xscrollcommand {Some command} {Some command} {} {}} - canvas-1.24 {-yscrollcommand {Another command} {Another command} {} {}} -} { - lassign $testinfo name goodValue goodResult badValue badResult - test $testname-good "configuration options: good value for $name" { - .c configure $name $goodValue - lindex [.c configure $name] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test $testname-bad "configuration options: bad value for $name" -body { - .c configure $name $badValue - } -returnCodes error -result $badResult - } - .c configure $name [lindex [.c configure $name] 3] - incr i -} -test canvas-1.25 {configure throws error on bad option} { - set res [list [catch {.c configure -gorp foo}]] - .c create rect 10 10 100 100 - lappend res [catch {.c configure -gorp foo}] - set res -} [list 1 1] +test canvas-1.1 {configuration options: good value for "background"} -body { + .c configure -background #ff0000 + .c cget -background +} -result {#ff0000} +test canvas-1.2 {configuration options: bad value for "background"} -body { + .c configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test canvas-1.3 {configuration options: good value for "bg"} -body { + .c configure -bg #ff0000 + .c cget -bg +} -result {#ff0000} +test canvas-1.4 {configuration options: bad value for "bg"} -body { + .c configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test canvas-1.5 {configuration options: good value for "bd"} -body { + .c configure -bd 4 + .c cget -bd +} -result {4} +test canvas-1.6 {configuration options: bad value for "bd"} -body { + .c configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test canvas-1.7 {configuration options: good value for "borderwidth"} -body { + .c configure -borderwidth 1.3 + .c cget -borderwidth +} -result {1} +test canvas-1.8 {configuration options: bad value for "borderwidth"} -body { + .c configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test canvas-1.9 {configuration options: good value for "closeenough"} -body { + .c configure -closeenough 24 + .c cget -closeenough +} -result {24.0} +test canvas-1.10 {configuration options: bad value for "closeenough"} -body { + .c configure -closeenough bogus +} -returnCodes error -result {expected floating-point number but got "bogus"} +test canvas-1.11 {configuration options: good value for "confine"} -body { + .c configure -confine true + .c cget -confine +} -result {1} +test canvas-1.12 {configuration options: bad value for "confine"} -body { + .c configure -confine silly +} -returnCodes error -result {expected boolean value but got "silly"} +test canvas-1.13 {configuration options: good value for "cursor"} -body { + .c configure -cursor arrow + .c cget -cursor +} -result {arrow} +test canvas-1.14 {configuration options: bad value for "cursor"} -body { + .c configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test canvas-1.15 {configuration options: good value for "height"} -body { + .c configure -height 2.1 + .c cget -height +} -result {2} +test canvas-1.16 {configuration options: bad value for "height"} -body { + .c configure -height x42 +} -returnCodes error -result {bad screen distance "x42"} +test canvas-1.17 {configuration options: good value for "highlightbackground"} -body { + .c configure -highlightbackground #112233 + .c cget -highlightbackground +} -result {#112233} +test canvas-1.18 {configuration options: bad value for "highlightbackground"} -body { + .c configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test canvas-1.19 {configuration options: good value for "highlightcolor"} -body { + .c configure -highlightcolor #110022 + .c cget -highlightcolor +} -result {#110022} +test canvas-1.20 {configuration options: bad value for "highlightcolor"} -body { + .c configure -highlightcolor bogus +} -returnCodes error -result {unknown color name "bogus"} +test canvas-1.21 {configuration options: good value for "highlightthickness"} -body { + .c configure -highlightthickness 18 + .c cget -highlightthickness +} -result {18} +test canvas-1.22 {configuration options: bad value for "highlightthickness"} -body { + .c configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test canvas-1.23 {configuration options: good value for "insertbackground"} -body { + .c configure -insertbackground #110022 + .c cget -insertbackground +} -result {#110022} +test canvas-1.24 {configuration options: bad value for "insertbackground"} -body { + .c configure -insertbackground bogus +} -returnCodes error -result {unknown color name "bogus"} +test canvas-1.25 {configuration options: good value for "insertborderwidth"} -body { + .c configure -insertborderwidth 1.3 + .c cget -insertborderwidth +} -result {1} +test canvas-1.26 {configuration options: bad value for "insertborderwidth"} -body { + .c configure -insertborderwidth 2.6x +} -returnCodes error -result {bad screen distance "2.6x"} +test canvas-1.27 {configuration options: good value for "insertofftime"} -body { + .c configure -insertofftime 100 + .c cget -insertofftime +} -result {100} +test canvas-1.28 {configuration options: bad value for "insertofftime"} -body { + .c configure -insertofftime 3.2 +} -returnCodes error -result {expected integer but got "3.2"} +test canvas-1.29 {configuration options: good value for "insertontime"} -body { + .c configure -insertontime 100 + .c cget -insertontime +} -result {100} +test canvas-1.30 {configuration options: bad value for "insertontime"} -body { + .c configure -insertontime 3.2 +} -returnCodes error -result {expected integer but got "3.2"} +test canvas-1.31 {configuration options: good value for "insertwidth"} -body { + .c configure -insertwidth 1.3 + .c cget -insertwidth +} -result {1} +test canvas-1.32 {configuration options: bad value for "insertwidth"} -body { + .c configure -insertwidth 6x +} -returnCodes error -result {bad screen distance "6x"} +test canvas-1.33 {configuration options: good value for "relief"} -body { + .c configure -relief groove + .c cget -relief +} -result {groove} +test canvas-1.34 {configuration options: bad value for "relief"} -body { + .c configure -relief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test canvas-1.35 {configuration options: good value for "selectbackground"} -body { + .c configure -selectbackground #110022 + .c cget -selectbackground +} -result {#110022} +test canvas-1.36 {configuration options: bad value for "selectbackground"} -body { + .c configure -selectbackground bogus +} -returnCodes error -result {unknown color name "bogus"} +test canvas-1.37 {configuration options: good value for "selectborderwidth"} -body { + .c configure -selectborderwidth 1.3 + .c cget -selectborderwidth +} -result {1} +test canvas-1.38 {configuration options: bad value for "selectborderwidth"} -body { + .c configure -selectborderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test canvas-1.39 {configuration options: good value for "selectforeground"} -body { + .c configure -selectforeground #654321 + .c cget -selectforeground +} -result {#654321} +test canvas-1.40 {configuration options: bad value for "selectforeground"} -body { + .c configure -selectforeground bogus +} -returnCodes error -result {unknown color name "bogus"} +test canvas-1.41 {configuration options: good value for "takefocus"} -body { + .c configure -takefocus "any string" + .c cget -takefocus +} -result {any string} +test canvas-1.42 {configuration options: good value for "width"} -body { + .c configure -width 402 + .c cget -width +} -result {402} +test canvas-1.43 {configuration options: bad value for "width"} -body { + .c configure -width xyz +} -returnCodes error -result {bad screen distance "xyz"} +test canvas-1.44 {configuration options: good value for "xscrollcommand"} -body { + .c configure -xscrollcommand {Some command} + .c cget -xscrollcommand +} -result {Some command} +test canvas-1.45 {configuration options: good value for "yscrollcommand"} -body { + .c configure -yscrollcommand {Another command} + .c cget -yscrollcommand +} -result {Another command} +test canvas-1.46 {configure throws error on bad option} -body { + .c configure -gorp foo +} -returnCodes error -match glob -result {*} +test canvas-1.47 {configure throws error on bad option} -body { + catch {.c configure -gorp foo} + .c create rect 10 10 100 100 + .c configure -gorp foo +} -returnCodes error -match glob -result {*} catch {destroy .c} + +# Canvas used in 2.* test cases canvas .c -width 60 -height 40 -scrollregion {0 0 200 150} -bd 0 \ -highlightthickness 0 pack .c update -test canvas-2.1 {CanvasWidgetCmd, bind option} { +test canvas-2.1 {CanvasWidgetCmd, bind option} -body { set i [.c create rect 10 10 100 100] - list [catch {.c bind $i <a>} msg] $msg -} {0 {}} -test canvas-2.2 {CanvasWidgetCmd, bind option} { + .c bind $i <a> +} -cleanup { + .c delete $i +} -returnCodes ok +test canvas-2.2 {CanvasWidgetCmd, bind option} -body { set i [.c create rect 10 10 100 100] - list [catch {.c bind $i <} msg] $msg -} {1 {no event type or button # or keysym}} -test canvas-2.3 {CanvasWidgetCmd, xview option} { + .c bind $i < +} -cleanup { + .c delete $i +} -returnCodes error -result {no event type or button # or keysym} +test canvas-2.3 {CanvasWidgetCmd, xview option} -body { .c configure -xscrollincrement 40 -yscrollincrement 5 .c xview moveto 0 update @@ -97,10 +215,10 @@ test canvas-2.3 {CanvasWidgetCmd, xview option} { .c xview scroll 2 units update lappend x [.c xview] -} {{0.0 0.3} {0.4 0.7}} -test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { - # This test gives slightly different results on platforms such - # as NetBSD. I don't know why... +} -result {{0.0 0.3} {0.4 0.7}} +test canvas-2.4 {CanvasWidgetCmd, xview option} -constraints nonPortable -body { + # This test gives slightly different results on platforms such as NetBSD. + # I don't know why... .c configure -xscrollincrement 0 -yscrollincrement 5 .c xview moveto 0.6 update @@ -108,14 +226,16 @@ test canvas-2.4 {CanvasWidgetCmd, xview option} {nonPortable} { .c xview scroll 2 units update lappend x [.c xview] -} {{0.6 0.9} {0.66 0.96}} - +} -result {{0.6 0.9} {0.66 0.96}} catch {destroy .c} + +# Canvas used in 3.* test cases canvas .c -width 60 -height 40 -scrollregion {0 0 200 80} \ -borderwidth 0 -highlightthickness 0 pack .c update -test canvas-3.1 {CanvasWidgetCmd, yview option} { + +test canvas-3.1 {CanvasWidgetCmd, yview option} -body { .c configure -xscrollincrement 40 -yscrollincrement 5 .c yview moveto 0 update @@ -123,8 +243,8 @@ test canvas-3.1 {CanvasWidgetCmd, yview option} { .c yview scroll 3 units update lappend x [.c yview] -} {{0.0 0.5} {0.1875 0.6875}} -test canvas-3.2 {CanvasWidgetCmd, yview option} { +} -result {{0.0 0.5} {0.1875 0.6875}} +test canvas-3.2 {CanvasWidgetCmd, yview option} -body { .c configure -xscrollincrement 40 -yscrollincrement 0 .c yview moveto 0 update @@ -132,39 +252,43 @@ test canvas-3.2 {CanvasWidgetCmd, yview option} { .c yview scroll 2 units update lappend x [.c yview] -} {{0.0 0.5} {0.1 0.6}} +} -result {{0.0 0.5} {0.1 0.6}} +destroy .c -test canvas-4.1 {ButtonEventProc procedure} { +test canvas-4.1 {ButtonEventProc procedure} -setup { deleteWindows + set x {} +} -body { canvas .c1 -bg #543210 rename .c1 .c2 - set x {} lappend x [winfo children .] lappend x [.c2 cget -bg] destroy .c1 lappend x [info command .c*] [winfo children .] -} {.c1 #543210 {} {}} +} -result {.c1 #543210 {} {}} -test canvas-5.1 {ButtonCmdDeletedProc procedure} { - deleteWindows +test canvas-5.1 {ButtonCmdDeletedProc procedure} -body { canvas .c1 rename .c1 {} list [info command .c*] [winfo children .] -} {{} {}} +} -cleanup { + destroy .c1 +} -result {{} {}} -catch {destroy .c} +# Canvas used in 6.* test cases canvas .c -width 100 -height 50 -scrollregion {-200 -100 305 102} \ -borderwidth 2 -highlightthickness 3 pack .c update -test canvas-6.1 {CanvasSetOrigin procedure} { + +test canvas-6.1 {CanvasSetOrigin procedure} -body { .c configure -xscrollincrement 0 -yscrollincrement 0 .c xview moveto 0 .c yview moveto 0 update list [.c canvasx 0] [.c canvasy 0] -} {-205.0 -105.0} -test canvas-6.2 {CanvasSetOrigin procedure} { +} -result {-205.0 -105.0} +test canvas-6.2 {CanvasSetOrigin procedure} -body { .c configure -xscrollincrement 20 -yscrollincrement 10 set x "" foreach i {.08 .10 .48 .50} { @@ -172,9 +296,9 @@ test canvas-6.2 {CanvasSetOrigin procedure} { update lappend x [.c canvasx 0] } - set x -} {-165.0 -145.0 35.0 55.0} -test canvas-6.3 {CanvasSetOrigin procedure} { + return $x +} -result {-165.0 -145.0 35.0 55.0} +test canvas-6.3 {CanvasSetOrigin procedure} -body { .c configure -xscrollincrement 20 -yscrollincrement 10 set x "" foreach i {.06 .08 .70 .72} { @@ -182,30 +306,29 @@ test canvas-6.3 {CanvasSetOrigin procedure} { update lappend x [.c canvasy 0] } - set x -} {-95.0 -85.0 35.0 45.0} -test canvas-6.4 {CanvasSetOrigin procedure} { + return $x +} -result {-95.0 -85.0 35.0 45.0} +test canvas-6.4 {CanvasSetOrigin procedure} -body { .c configure -xscrollincrement 20 -yscrollincrement 10 .c xview moveto 1.0 .c canvasx 0 -} {215.0} -test canvas-6.5 {CanvasSetOrigin procedure} { +} -result {215.0} +test canvas-6.5 {CanvasSetOrigin procedure} -body { .c configure -xscrollincrement 20 -yscrollincrement 10 .c yview moveto 1.0 .c canvasy 0 -} {55.0} - +} -result {55.0} deleteWindows -set l [lsort [interp hidden]] test canvas-7.1 {canvas widget vs hidden commands} -setup { - catch {destroy .c} -} -body { canvas .c +} -body { interp hide {} .c destroy .c list [winfo children .] [lsort [interp hidden]] -} -result [list {} $l] +} -cleanup { + destroy .c +} -result [list {} [lsort [interp hidden]]] test canvas-8.1 {canvas arc bbox} -setup { catch {destroy .c} @@ -224,11 +347,10 @@ test canvas-9.1 {canvas id creation and deletion} -setup { catch {destroy .c} canvas .c } -body { - # With Tk 8.0.4 the ids are now stored in a hash table. You - # can use this test as a performance test with older versions - # by changing the value of size. + # With Tk 8.0.4 the ids are now stored in a hash table. You can use this + # test as a performance test with older versions by changing the value of + # size. set size 15 - for {set i 0} {$i < $size} {incr i} { set x [expr {-10 + 3*$i}] for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} { @@ -238,10 +360,8 @@ test canvas-9.1 {canvas id creation and deletion} -setup { -anchor center -tags text } } - - # The actual bench mark - this code also exercises all the hash - # table changes. - + # The actual bench mark - this code also exercises all the hash table + # changes. set time [lindex [time { foreach id [.c find withtag all] { .c lower $id @@ -251,12 +371,13 @@ test canvas-9.1 {canvas id creation and deletion} -setup { .c delete $id } }] 0] - set x "" } -result {} + test canvas-10.1 {find items using tag expressions} -setup { catch {destroy .c} canvas .c + set res {} } -body { .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 60 40 80 -fill yellow -tag [list b a] @@ -265,7 +386,6 @@ test canvas-10.1 {find items using tag expressions} -setup { .c create oval 20 180 40 200 -fill bisque -tag [list a d e] .c create oval 20 220 40 240 -fill bisque -tag b .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] - set res {} lappend res [.c find withtag {!a}] lappend res [.c find withtag {b&&c}] lappend res [.c find withtag {b||c}] @@ -332,9 +452,9 @@ test canvas-10.8 {check errors from tag expressions} -setup { canvas .c .c create oval 20 20 40 40 -fill red -tag [list a b c d] .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] -} -body { +} -returnCodes error -body { .c find withtag {a&&"tag with spaces"z} -} -returnCodes error -result {Invalid boolean operator in tag search expression} +} -result {Invalid boolean operator in tag search expression} test canvas-10.9 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -354,7 +474,8 @@ test canvas-10.10 {check errors from tag expressions} -setup { test canvas-10.11 {backward compatility - strange tags that are not expressions} -setup { catch {destroy .c} canvas .c - .c create oval 20 20 40 40 -fill red -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] + .c create oval 20 20 40 40 -fill red \ + -tag [list { strange tag(xxx&yyy|zzz) " && \" || ! ^ " }] } -body { .c find withtag { strange tag(xxx&yyy|zzz) " && \" || ! ^ " } } -result 1 @@ -386,22 +507,22 @@ test canvas-11.1 {canvas poly fill check, bug 5783} -setup { test canvas-11.2 {canvas poly overlap fill check, bug 226357} -setup { destroy .c pack [canvas .c] -} -body { set result {} +} -body { .c create poly 30 30 90 90 30 90 90 30 - lappend result [.c find over 40 40 45 45]; # rect region inc. edge - lappend result [.c find over 60 40 60 40]; # top-center point - lappend result [.c find over 0 0 0 0]; # not on poly - lappend result [.c find over 60 60 60 60]; # center-point - lappend result [.c find over 45 50 45 50]; # outside poly + lappend result [.c find over 40 40 45 45]; # rect region inc. edge + lappend result [.c find over 60 40 60 40]; # top-center point + lappend result [.c find over 0 0 0 0]; # not on poly + lappend result [.c find over 60 60 60 60]; # center-point + lappend result [.c find over 45 50 45 50]; # outside poly .c itemconfig 1 -fill "" -outline black - lappend result [.c find over 40 40 45 45]; # rect region inc. edge - lappend result [.c find over 60 40 60 40]; # top-center point - lappend result [.c find over 0 0 0 0]; # not on poly - lappend result [.c find over 60 60 60 60]; # center-point - lappend result [.c find over 45 50 45 50]; # outside poly + lappend result [.c find over 40 40 45 45]; # rect region inc. edge + lappend result [.c find over 60 40 60 40]; # top-center point + lappend result [.c find over 0 0 0 0]; # not on poly + lappend result [.c find over 60 60 60 60]; # center-point + lappend result [.c find over 45 50 45 50]; # outside poly .c itemconfig 1 -width 8 - lappend result [.c find over 45 50 45 50]; # outside poly + lappend result [.c find over 45 50 45 50]; # outside poly } -result {1 1 {} 1 {} 1 1 {} 1 {} 1} test canvas-11.3 {canvas poly dchars, bug 3291543} { # This would crash @@ -434,6 +555,7 @@ test canvas-12.2 {canvas mm obj, patch SF-403327, 102471} -setup { incr val } -result 12 +# procedure used in 13.1 test case proc kill_canvas {w} { destroy $w pack [canvas $w -height 200 -width 200] -fill both -expand yes @@ -443,11 +565,9 @@ proc kill_canvas {w} { $w bind blue <ButtonRelease-1> [subst { [lindex [info level 0] 0] $w append ::x ok - } - ] + }] } - -test canvas-13.1 {canvas delete during event, SF bug-228024} { +test canvas-13.1 {canvas delete during event, SF bug-228024} -body { kill_canvas .c set ::x {} # do this many times to improve chances of triggering the crash @@ -455,27 +575,27 @@ test canvas-13.1 {canvas delete during event, SF bug-228024} { event generate .c <1> -x 100 -y 100 event generate .c <ButtonRelease-1> -x 100 -y 100 } - set ::x -} okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok + return $::x +} -result {okokokokokokokokokokokokokokokokokokokokokokokokokokokokokok} test canvas-14.1 {canvas scan SF bug 581560} -setup { destroy .c canvas .c -} -body { +} -returnCodes error -body { .c scan -} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} test canvas-14.2 {canvas scan} -setup { destroy .c canvas .c -} -body { +} -returnCodes error -body { .c scan bogus -} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} test canvas-14.3 {canvas scan} -setup { destroy .c canvas .c -} -body { +} -returnCodes error -body { .c scan mark -} -returnCodes error -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} +} -result {wrong # args: should be ".c scan mark|dragto x y ?dragGain?"} test canvas-14.4 {canvas scan} -setup { destroy .c canvas .c @@ -495,37 +615,133 @@ test canvas-14.6 {canvas scan} -setup { .c scan dragto 10 10 5 } -result {} -set i 0 -proc create {w type args} { - eval [list $w create $type] $args -} -foreach type {arc bitmap image line oval polygon rect text window} { - incr i - test canvas-15.$i "basic types check: $type requires coords" -setup { - destroy .c - canvas .c - } -body { - .c create $type - } -returnCodes error -result [format {wrong # args: should be ".c create %s coords ?arg arg ...?"} $type] - incr i - test canvas-15.$i "basic coords check: $type coords are paired" -setup { - destroy .c - canvas .c - } -match glob -body { - .c create $type 0 - } -returnCodes error -result "wrong # coordinates: expected*" -} +test canvas-15.1 {basic types check: arc requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create arc +} -result {wrong # args: should be ".c create arc coords ?arg ...?"} +test canvas-15.2 "basic coords check: arc coords are paired" -setup { + destroy .c + canvas .c +} -body { + .c create arc 0 +} -returnCodes error -result {wrong # coordinates: expected 4, got 1} +test canvas-15.3 {basic types check: bitmap requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create bitmap +} -result {wrong # args: should be ".c create bitmap coords ?arg ...?"} +test canvas-15.4 "basic coords check: bitmap coords are paired" -setup { + destroy .c + canvas .c +} -body { + .c create bitmap 0 +} -returnCodes error -result {wrong # coordinates: expected 2, got 1} +test canvas-15.5 {basic types check: image requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create image +} -result {wrong # args: should be ".c create image coords ?arg ...?"} +test canvas-15.6 "basic coords check: image coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create image 0 +} -result {wrong # coordinates: expected 2, got 1} +test canvas-15.7 {basic types check: line requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create line +} -result {wrong # args: should be ".c create line coords ?arg ...?"} +test canvas-15.8 "basic coords check: line coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create line 0 +} -result {wrong # coordinates: expected an even number, got 1} +test canvas-15.9 {basic types check: oval requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create oval +} -result {wrong # args: should be ".c create oval coords ?arg ...?"} +test canvas-15.10 "basic coords check: oval coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create oval 0 +} -result {wrong # coordinates: expected 0 or 4, got 1} +test canvas-15.11 {basic types check: polygon requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create polygon +} -result {wrong # args: should be ".c create polygon coords ?arg ...?"} +test canvas-15.12 "basic coords check: polygon coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create polygon 0 +} -result {wrong # coordinates: expected an even number, got 1} +test canvas-15.13 {basic types check: rect requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create rect +} -result {wrong # args: should be ".c create rect coords ?arg ...?"} +test canvas-15.14 "basic coords check: rect coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create rect 0 +} -result {wrong # coordinates: expected 0 or 4, got 1} +test canvas-15.15 {basic types check: text requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create text +} -result {wrong # args: should be ".c create text coords ?arg ...?"} +test canvas-15.16 "basic coords check: text coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create text 0 +} -result {wrong # coordinates: expected 2, got 1} +test canvas-15.17 {basic types check: window requires coords} -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create window +} -result {wrong # args: should be ".c create window coords ?arg ...?"} +test canvas-15.18 "basic coords check: window coords are paired" -setup { + destroy .c + canvas .c +} -returnCodes error -body { + .c create window 0 +} -result {wrong # coordinates: expected 2, got 1} +test canvas-15.19 "basic coords check: centimeters are larger than pixels" -setup { + destroy .c + canvas .c +} -body { + set id [.c create rect 0 0 1cm 1cm] + expr {[lindex [.c coords $id] 2]>1} +} -result {1} +destroy .c test canvas-16.1 {arc coords check} -setup { - destroy .c canvas .c } -body { set id [.c create arc {0 10 20 30} -start 33] .c itemcget $id -start +} -cleanup { + destroy .c } -result {33.0} test canvas-17.1 {default smooth method handling} -setup { - destroy .c canvas .c } -body { set id [.c create line {0 0 1 1 2 2 3 3 4 4 5 5 6 6}] @@ -534,11 +750,211 @@ test canvas-17.1 {default smooth method handling} -setup { .c itemconfigure $id -smooth $smoother lappend result [.c itemcget $id -smooth] } - set result + return $result +} -cleanup { + destroy .c } -result {0 true true true raw raw true} -destroy .c +test canvas-18.1 {imove method - lines} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c imove $id 0 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0} +test canvas-18.2 {imove method - lines} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1] + .c imove $id 0 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {4.0 4.0 1.0 1.0} +test canvas-18.3 {imove method - lines} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c imove $id @1,1 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0} +test canvas-18.4 {imove method - lines} -constraints knownBug -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c imove $id end 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0} +test canvas-18.5 {imove method - polygon} -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1 2 2 3 3] + .c imove $id 0 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {4.0 4.0 1.0 1.0 2.0 2.0 3.0 3.0} +test canvas-18.6 {imove method - polygon} -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1] + .c imove $id 0 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {4.0 4.0 1.0 1.0} +test canvas-18.7 {imove method - polygon} -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1 2 2 3 3] + .c imove $id @1,1 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 4.0 4.0 2.0 2.0 3.0 3.0} +test canvas-18.8 {imove method - polygon} -constraints knownBug -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1 2 2 3 3] + .c imove $id end 4 4 + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 1.0 1.0 2.0 2.0 4.0 4.0} +test canvas-18.9 {imove method - errors} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c imove $id foobar 4 4 +} -cleanup { + destroy .c +} -returnCodes error -result {bad index "foobar"} +test canvas-18.10 {imove method - errors} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c imove $id 0 foobar 4 +} -cleanup { + destroy .c +} -returnCodes error -result {bad screen distance "foobar"} +test canvas-18.11 {imove method - errors} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c imove $id 0 4 foobar +} -cleanup { + destroy .c +} -returnCodes error -result {bad screen distance "foobar"} + +test canvas-19.1 {rchars method - lines} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c rchars $id 2 4 {4 4} + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 4.0 4.0 3.0 3.0} +test canvas-19.2 {rchars method - lines} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c rchars $id 2 4 {} + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 3.0 3.0} +test canvas-19.3 {rchars method - lines} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1 2 2 3 3] + .c rchars $id 2 4 {10 11 12 13 14 15} + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0} +test canvas-19.4 {rchars method - polygon} -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1 2 2 3 3] + .c rchars $id 2 4 {4 4} + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 4.0 4.0 3.0 3.0} +test canvas-19.5 {rchars method - polygon} -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1 2 2 3 3] + .c rchars $id 2 4 {} + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 3.0 3.0} +test canvas-19.6 {rchars method - polygon} -setup { + canvas .c +} -body { + set id [.c create polygon 0 0 1 1 2 2 3 3] + .c rchars $id 2 4 {10 11 12 13 14 15} + .c coords $id +} -cleanup { + destroy .c +} -result {0.0 0.0 10.0 11.0 12.0 13.0 14.0 15.0 3.0 3.0} +test canvas-19.7 {rchars method - text} -setup { + canvas .c +} -body { + set id [.c create text 0 0 -text abcde] + .c rchars $id 1 3 XYZ + .c itemcget $id -text +} -cleanup { + destroy .c +} -result aXYZe +test canvas-19.8 {rchars method - text} -setup { + canvas .c +} -body { + set id [.c create text 0 0 -text abcde] + .c rchars $id 1 3 {} + .c itemcget $id -text +} -cleanup { + destroy .c +} -result ae +test canvas-19.9 {rchars method - text} -setup { + canvas .c +} -body { + set id [.c create text 0 0 -text abcde] + .c rchars $id 1 3 FOOBAR + .c itemcget $id -text +} -cleanup { + destroy .c +} -result aFOOBARe +test canvas-19.10 {rchars method - errors} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1] + .c rchars $id foo 1 {2 2} +} -cleanup { + destroy .c +} -returnCodes error -result {bad index "foo"} +test canvas-19.11 {rchars method - errors} -setup { + canvas .c +} -body { + set id [.c create line 0 0 1 1] + .c rchars $id 1 foo {2 2} +} -cleanup { + destroy .c +} -returnCodes error -result {bad index "foo"} # cleanup +imageCleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/choosedir.test b/tests/choosedir.test index 01a319f..fb6e62d 100644 --- a/tests/choosedir.test +++ b/tests/choosedir.test @@ -5,7 +5,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -84,61 +85,86 @@ set fake [file join $dir non-existant] set parent . -foreach opt {-initialdir -mustexist -parent -title} { - test choosedir-1.1$opt "tk_chooseDirectory command" unix { - list [catch {tk_chooseDirectory $opt} msg] $msg - } [list 1 "value for \"$opt\" missing"] -} -test choosedir-1.2 "tk_chooseDirectory command" unix { - list [catch {tk_chooseDirectory -foo bar} msg] $msg -} [list 1 "bad option \"-foo\": must be -initialdir, -mustexist, -parent, or -title"] -test choosedir-1.3 "tk_chooseDirectory command" unix { - list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg -} {1 {bad window path name "foo.bar"}} - - -test choosedir-2.1 "tk_chooseDirectory command, cancel gives null" {unix notAqua} { +test choosedir-1.1 {tk_chooseDirectory command} -constraints unix -body { + tk_chooseDirectory -initialdir +} -returnCodes error -result {value for "-initialdir" missing} +test choosedir-1.2 {tk_chooseDirectory command} -constraints unix -body { + tk_chooseDirectory -mustexist +} -returnCodes error -result {value for "-mustexist" missing} +test choosedir-1.3 {tk_chooseDirectory command} -constraints unix -body { + tk_chooseDirectory -parent +} -returnCodes error -result {value for "-parent" missing} +test choosedir-1.4 {tk_chooseDirectory command} -constraints unix -body { + tk_chooseDirectory -title +} -returnCodes error -result {value for "-title" missing} + +test choosedir-1.5 {tk_chooseDirectory command} -constraints unix -body { + tk_chooseDirectory -foo bar +} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} +test choosedir-1.6 {tk_chooseDirectory command} -constraints unix -body { + tk_chooseDirectory -parent foo.bar +} -returnCodes error -result {bad window path name "foo.bar"} + + +test choosedir-2.1 {tk_chooseDirectory command, cancel gives null} -constraints { + unix notAqua +} -body { ToPressButton $parent cancel tk_chooseDirectory -title "Press Cancel" -parent $parent -} "" +} -result {} -test choosedir-3.1 "tk_chooseDirectory -mustexist 1" {unix notAqua} { + +test choosedir-3.1 {tk_chooseDirectory -mustexist 1} -constraints { + unix notAqua +} -body { # first enter a bogus dirname, then enter a real one. ToEnterDirsByKey $parent [list $fake $real $real] set result [tk_chooseDirectory \ -title "Enter \"$fake\", press OK, enter \"$real\", press OK" \ -parent $parent -mustexist 1] set result -} $real -test choosedir-3.2 "tk_chooseDirectory -mustexist 0" {unix notAqua} { +} -result $real +test choosedir-3.2 {tk_chooseDirectory -mustexist 0} -constraints { + unix notAqua +} -body { ToEnterDirsByKey $parent [list $fake $fake] tk_chooseDirectory -title "Enter \"$fake\", press OK" \ -parent $parent -mustexist 0 -} $fake +} -result $fake + -test choosedir-4.1 "tk_chooseDirectory command, initialdir" {unix notAqua} { +test choosedir-4.1 {tk_chooseDirectory command, initialdir} -constraints { + unix notAqua +} -body { ToPressButton $parent ok tk_chooseDirectory -title "Press Ok" -parent $parent -initialdir $real -} $real -test choosedir-4.2 "tk_chooseDirectory command, initialdir" {unix notAqua} { +} -result $real +test choosedir-4.2 {tk_chooseDirectory command, initialdir} -constraints { + unix notAqua +} -body { ToEnterDirsByKey $parent [list $fake $fake] tk_chooseDirectory \ -title "Enter \"$fake\" and press Ok" \ -parent $parent -initialdir $real -} $fake -test choosedir-4.3 "tk_chooseDirectory, -initialdir {}" {unix notAqua} { +} -result $fake +test choosedir-4.3 {tk_chooseDirectory command, {} initialdir} -constraints { + unix notAqua +} -body { catch {unset ::tk::dialog::file::__tk_choosedir} ToPressButton $parent ok tk_chooseDirectory \ -title "Press OK" \ -parent $parent -initialdir "" -} [pwd] +} -result [pwd] + -test choosedir-5.1 "tk_chooseDirectory, handles {} entry text" {unix notAqua} { +test choosedir-5.1 {tk_chooseDirectory, handles {} entry text} -constraints { + unix notAqua +} -body { ToEnterDirsByKey $parent [list "" $real $real] tk_chooseDirectory -title "Clear entry, Press OK; Enter $real, press OK" \ -parent $parent -} $real +} -result $real # cleanup removeDirectory choosedirTest diff --git a/tests/clipboard.test b/tests/clipboard.test index 37e45a3..6077940 100644 --- a/tests/clipboard.test +++ b/tests/clipboard.test @@ -11,7 +11,8 @@ # environment variable TK_ALT_DISPLAY is set to an alternate display. # -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -23,124 +24,189 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { } # Now we start the main body of the test code - -test clipboard-1.1 {ClipboardHandler procedure} { + +test clipboard-1.1 {ClipboardHandler procedure} -setup { clipboard clear +} -body { clipboard append "test" clipboard get -} {test} -test clipboard-1.2 {ClipboardHandler procedure} { +} -cleanup { + clipboard clear +} -result {test} +test clipboard-1.2 {ClipboardHandler procedure} -setup { clipboard clear +} -body { clipboard append "test" clipboard append "ing" clipboard get -} {testing} -test clipboard-1.3 {ClipboardHandler procedure} { +} -cleanup { clipboard clear +} -result {testing} +test clipboard-1.3 {ClipboardHandler procedure} -setup { + clipboard clear +} -body { clipboard append "t" clipboard append "e" clipboard append "s" clipboard append "t" clipboard get -} {test} -test clipboard-1.4 {ClipboardHandler procedure} { +} -cleanup { + clipboard clear +} -result {test} +test clipboard-1.4 {ClipboardHandler procedure} -setup { clipboard clear +} -body { clipboard append $longValue clipboard get -} "$longValue" -test clipboard-1.5 {ClipboardHandler procedure} { +} -cleanup { clipboard clear +} -result "$longValue" +test clipboard-1.5 {ClipboardHandler procedure} -setup { + clipboard clear +} -body { clipboard append $longValue clipboard append "test" clipboard get -} "${longValue}test" -test clipboard-1.6 {ClipboardHandler procedure} { +} -cleanup { + clipboard clear +} -result "${longValue}test" +test clipboard-1.6 {ClipboardHandler procedure} -setup { clipboard clear +} -body { clipboard append -t TEST $longValue clipboard append -t STRING "test" - list [clipboard get -t STRING] \ - [clipboard get -t TEST] -} [list test $longValue] -test clipboard-1.7 {ClipboardHandler procedure} { + list [clipboard get -t STRING] [clipboard get -t TEST] +} -cleanup { clipboard clear +} -result [list test $longValue] +test clipboard-1.7 {ClipboardHandler procedure} -setup { + clipboard clear +} -body { clipboard append -t TEST [string range $longValue 1 4000] clipboard append -t STRING "test" - list [clipboard get -t STRING] \ - [clipboard get -t TEST] -} [list test [string range $longValue 1 4000]] -test clipboard-1.8 {ClipboardHandler procedure} { + list [clipboard get -t STRING] [clipboard get -t TEST] +} -cleanup { + clipboard clear +} -result [list test [string range $longValue 1 4000]] +test clipboard-1.8 {ClipboardHandler procedure} -setup { clipboard clear +} -body { clipboard append "" clipboard get -} {} -test clipboard-1.9 {ClipboardHandler procedure} { +} -cleanup { clipboard clear +} -result {} +test clipboard-1.9 {ClipboardHandler procedure} -setup { + clipboard clear +} -body { clipboard append "" clipboard append "Test" clipboard get -} {Test} +} -cleanup { + clipboard clear +} -result {Test} ############################################################################## -test clipboard-2.1 {ClipboardAppHandler procedure} { +test clipboard-2.1 {ClipboardAppHandler procedure} -setup { set oldAppName [tk appname] - tk appname UnexpectedName clipboard clear +} -body { + tk appname UnexpectedName clipboard append -type NEW_TYPE Data - set result [selection get -selection CLIPBOARD -type TK_APPLICATION] + selection get -selection CLIPBOARD -type TK_APPLICATION +} -cleanup { tk appname $oldAppName - set result -} {UnexpectedName} + clipboard clear +} -result {UnexpectedName} ############################################################################## -test clipboard-3.1 {ClipboardWindowHandler procedure} { +test clipboard-3.1 {ClipboardWindowHandler procedure} -setup { set oldAppName [tk appname] - tk appname UnexpectedName clipboard clear +} -body { + tk appname UnexpectedName clipboard append -type NEW_TYPE Data - set result [selection get -selection CLIPBOARD -type TK_WINDOW] + selection get -selection CLIPBOARD -type TK_WINDOW +} -cleanup { tk appname $oldAppName - set result -} {.} + clipboard clear +} -result {.} ############################################################################## -test clipboard-4.1 {ClipboardLostSel procedure} { +test clipboard-4.1 {ClipboardLostSel procedure} -setup { clipboard clear +} -body { clipboard append "Test" selection clear -s CLIPBOARD - list [catch {clipboard get} msg] $msg -} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined}} -test clipboard-4.2 {ClipboardLostSel procedure} { + clipboard get +} -cleanup { + clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} +test clipboard-4.2 {ClipboardLostSel procedure} -setup { + clipboard clear +} -body { + clipboard append "Test" + clipboard append -t TEST "Test2" + selection clear -s CLIPBOARD + clipboard get +} -cleanup { + clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} +test clipboard-4.3 {ClipboardLostSel procedure} -setup { clipboard clear +} -body { clipboard append "Test" clipboard append -t TEST "Test2" selection clear -s CLIPBOARD - list [catch {clipboard get} msg] $msg \ - [catch {clipboard get -t TEST} msg] $msg -} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}} -test clipboard-4.3 {ClipboardLostSel procedure} { + catch {clipboard get} + clipboard get -t TEST +} -cleanup { + clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined} +test clipboard-4.4 {ClipboardLostSel procedure} -setup { + clipboard clear +} -body { + clipboard append "Test" + clipboard append -t TEST "Test2" + clipboard append "Test3" + selection clear -s CLIPBOARD + clipboard get +} -cleanup { clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} +test clipboard-4.5 {ClipboardLostSel procedure} -setup { + clipboard clear +} -body { clipboard append "Test" clipboard append -t TEST "Test2" clipboard append "Test3" selection clear -s CLIPBOARD - list [catch {clipboard get} msg] $msg \ - [catch {clipboard get -t TEST} msg] $msg -} {1 {CLIPBOARD selection doesn't exist or form "STRING" not defined} 1 {CLIPBOARD selection doesn't exist or form "TEST" not defined}} + catch {clipboard get} + clipboard get -t TEST +} -cleanup { + clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "TEST" not defined} + + ############################################################################## -test clipboard-5.1 {Tk_ClipboardClear procedure} { +test clipboard-5.1 {Tk_ClipboardClear procedure} -setup { clipboard clear +} -body { clipboard append -t TEST "test" set result [lsort [clipboard get TARGETS]] clipboard clear list $result [lsort [clipboard get TARGETS]] -} {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test clipboard-5.2 {Tk_ClipboardClear procedure} { +} -cleanup { clipboard clear +} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test clipboard-5.2 {Tk_ClipboardClear procedure} -setup { + clipboard clear +} -body { clipboard append -t TEST "test" set result [lsort [clipboard get TARGETS]] selection own -s CLIPBOARD . @@ -148,97 +214,148 @@ test clipboard-5.2 {Tk_ClipboardClear procedure} { clipboard clear clipboard append -t TEST "test" lappend result [lsort [clipboard get TARGETS]] -} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +} -cleanup { + clipboard clear +} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} ############################################################################## -test clipboard-6.1 {Tk_ClipboardAppend procedure} { +test clipboard-6.1 {Tk_ClipboardAppend procedure} -setup { clipboard clear +} -body { clipboard append "first chunk" selection own -s CLIPBOARD . - list [catch { clipboard append " second chunk" clipboard get - } msg] $msg -} {0 {first chunk second chunk}} -test clipboard-6.2 {Tk_ClipboardAppend procedure} unix { - setupbg +} -cleanup { + clipboard clear +} -returnCodes ok -result {first chunk second chunk} +test clipboard-6.2 {Tk_ClipboardAppend procedure} -constraints unix -setup { clipboard clear +} -body { + setupbg clipboard append -f INTEGER -t TEST "16" set result [dobg {clipboard get TEST}] + return $result +} -cleanup { + clipboard clear cleanupbg - set result -} {0x10 } -test clipboard-6.3 {Tk_ClipboardAppend procedure} { +} -result {0x10 } +test clipboard-6.3 {Tk_ClipboardAppend procedure} -setup { clipboard clear +} -body { clipboard append -f INTEGER -t TEST "16" - list [catch {clipboard append -t TEST "test"} msg] $msg -} {1 {format "STRING" does not match current format "INTEGER" for TEST}} + clipboard append -t TEST "test" +} -cleanup { + clipboard clear +} -returnCodes error -result {format "STRING" does not match current format "INTEGER" for TEST} ############################################################################## -test clipboard-7.1 {Tk_ClipboardCmd procedure} { - list [catch {clipboard} msg] $msg -} {1 {wrong # args: should be "clipboard option ?arg arg ...?"}} -test clipboard-7.2 {Tk_ClipboardCmd procedure} { - clipboard clear - list [catch {clipboard append --} msg] $msg \ - [selection get -selection CLIPBOARD] -} {0 {} --} -test clipboard-7.3 {Tk_ClipboardCmd procedure} { - clipboard clear - list [catch {clipboard append -- information} msg] $msg \ - [selection get -selection CLIPBOARD] -} {0 {} information} -test clipboard-7.4 {Tk_ClipboardCmd procedure} { - list [catch {clipboard append --x a b} msg] $msg -} {1 {bad option "--x": must be -displayof, -format, or -type}} -test clipboard-7.5 {Tk_ClipboardCmd procedure} { - list [catch {clipboard append -- a b} msg] $msg -} {1 {wrong # args: should be "clipboard append ?options? data"}} -test clipboard-7.6 {Tk_ClipboardCmd procedure} { - clipboard clear - list [catch {clipboard append -format} msg] $msg \ - [selection get -selection CLIPBOARD] -} {0 {} -format} -test clipboard-7.7 {Tk_ClipboardCmd procedure} { - list [catch {clipboard append -displayofoo f} msg] $msg -} {1 {bad option "-displayofoo": must be -displayof, -format, or -type}} -test clipboard-7.8 {Tk_ClipboardCmd procedure} { - list [catch {clipboard append -type TEST} msg] $msg -} {1 {wrong # args: should be "clipboard append ?options? data"}} -test clipboard-7.9 {Tk_ClipboardCmd procedure} { - list [catch {clipboard append -displayof foo "test"} msg] $msg -} {1 {bad window path name "foo"}} - -test clipboard-7.10 {Tk_ClipboardCmd procedure} { - list [catch {clipboard clear -displayof} msg] $msg -} {1 {wrong # args: should be "clipboard clear ?-displayof window?"}} -test clipboard-7.11 {Tk_ClipboardCmd procedure} { - list [catch {clipboard clear -displayofoo f} msg] $msg -} {1 {bad option "-displayofoo": must be -displayof}} -test clipboard-7.12 {Tk_ClipboardCmd procedure} { - list [catch {clipboard clear foo} msg] $msg -} {1 {wrong # args: should be "clipboard clear ?-displayof window?"}} -test clipboard-7.13 {Tk_ClipboardCmd procedure} { - list [catch {clipboard clear -displayof foo} msg] $msg -} {1 {bad window path name "foo"}} - -test clipboard-7.14 {Tk_ClipboardCmd procedure} { - list [catch {clipboard error} msg] $msg -} {1 {bad option "error": must be append, clear, or get}} - -test clipboard-7.15 {Tk_ClipboardCmd procedure} { - clipboard clear - list [catch {clipboard append -displayof} msg] $msg \ - [selection get -selection CLIPBOARD] -} {0 {} -displayof} -test clipboard-7.16 {Tk_ClipboardCmd procedure} { - clipboard clear - list [catch {clipboard append -type} msg] $msg \ - [selection get -selection CLIPBOARD] -} {0 {} -type} - +test clipboard-7.1 {Tk_ClipboardCmd procedure} -body { + clipboard +} -returnCodes error -result {wrong # args: should be "clipboard option ?arg ...?"} +test clipboard-7.2 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -- +} -cleanup { + clipboard clear +} -returnCodes ok -result {} +test clipboard-7.3 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -- + selection get -selection CLIPBOARD +} -cleanup { + clipboard clear +} -result {--} +test clipboard-7.4 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -- information + selection get -selection CLIPBOARD +} -cleanup { + clipboard clear +} -result {information} +test clipboard-7.5 {Tk_ClipboardCmd procedure} -body { + clipboard append --x a b +} -returnCodes error -result {bad option "--x": must be -displayof, -format, or -type} +test clipboard-7.6 {Tk_ClipboardCmd procedure} -body { + clipboard append -- a b +} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"} +test clipboard-7.7 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -format +} -returnCodes ok -result {} +test clipboard-7.8 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -format + selection get -selection CLIPBOARD +} -cleanup { + clipboard clear +} -result {-format} +test clipboard-7.9 {Tk_ClipboardCmd procedure} -body { + clipboard append -displayofoo f +} -returnCodes error -result {bad option "-displayofoo": must be -displayof, -format, or -type} +test clipboard-7.10 {Tk_ClipboardCmd procedure} -body { + clipboard append -type TEST +} -returnCodes error -result {wrong # args: should be "clipboard append ?-option value ...? data"} +test clipboard-7.11 {Tk_ClipboardCmd procedure} -body { + clipboard append -displayof foo "test" +} -returnCodes error -result {bad window path name "foo"} +test clipboard-7.12 {Tk_ClipboardCmd procedure} -body { + clipboard clear -displayof +} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"} +test clipboard-7.13 {Tk_ClipboardCmd procedure} -body { + clipboard clear -displayofoo f +} -returnCodes error -result {bad option "-displayofoo": must be -displayof} +test clipboard-7.14 {Tk_ClipboardCmd procedure} -body { + clipboard clear foo +} -returnCodes error -result {wrong # args: should be "clipboard clear ?-displayof window?"} +test clipboard-7.15 {Tk_ClipboardCmd procedure} -body { + clipboard clear -displayof foo +} -returnCodes error -result {bad window path name "foo"} +test clipboard-7.16 {Tk_ClipboardCmd procedure} -body { + clipboard error +} -returnCodes error -result {bad option "error": must be append, clear, or get} +test clipboard-7.17 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -displayof +} -cleanup { + clipboard clear +} -returnCodes ok -result {} +test clipboard-7.18 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -displayof + selection get -selection CLIPBOARD +} -cleanup { + clipboard clear +} -result {-displayof} +test clipboard-7.19 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -type +} -cleanup { + clipboard clear +} -returnCodes ok -result {} +test clipboard-7.20 {Tk_ClipboardCmd procedure} -setup { + clipboard clear +} -body { + clipboard append -type + selection get -selection CLIPBOARD +} -cleanup { + clipboard clear +} -result {-type} + # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/clrpick.test b/tests/clrpick.test index 8b3769e..5f1b8b5 100644 --- a/tests/clrpick.test +++ b/tests/clrpick.test @@ -5,9 +5,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test if {[testConstraint defaultPseudocolor8]} { # let's soak up a bunch of colors...so that @@ -43,51 +44,54 @@ if {[testConstraint defaultPseudocolor8]} { testConstraint colorsLeftover 0 } -test clrpick-1.1 {tk_chooseColor command} { - list [catch {tk_chooseColor -foo} msg] $msg -} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} - -catch {tk_chooseColor -foo 1} msg -regsub -all , $msg "" options -regsub \"-foo\" $options "" options - -foreach option $options { - if {[string index $option 0] eq "-"} { - test clrpick-1.2$option {tk_chooseColor command} -body { - tk_chooseColor $option - } -returnCodes error -result "value for \"$option\" missing" - } -} - -test clrpick-1.3 {tk_chooseColor command} { - list [catch {tk_chooseColor -foo bar} msg] $msg -} {1 {bad option "-foo": must be -initialcolor, -parent, or -title}} -test clrpick-1.4 {tk_chooseColor command} { - list [catch {tk_chooseColor -initialcolor} msg] $msg -} {1 {value for "-initialcolor" missing}} -test clrpick-1.5 {tk_chooseColor command} { - list [catch {tk_chooseColor -parent foo.bar} msg] $msg -} {1 {bad window path name "foo.bar"}} -test clrpick-1.6 {tk_chooseColor command} { - list [catch {tk_chooseColor -initialcolor badbadbaadcolor} msg] $msg -} {1 {unknown color name "badbadbaadcolor"}} -test clrpick-1.7 {tk_chooseColor command} { - list [catch {tk_chooseColor -initialcolor ##badbadbaadcolor} msg] $msg -} {1 {invalid color name "##badbadbaadcolor"}} - +test clrpick-1.1 {tk_chooseColor command} -body { + tk_chooseColor -foo +} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} + +test clrpick-1.2 {tk_chooseColor command } -body { + tk_chooseColor -initialcolor +} -returnCodes error -result {value for "-initialcolor" missing} +test clrpick-1.2.1 {tk_chooseColor command } -body { + tk_chooseColor -parent +} -returnCodes error -result {value for "-parent" missing} +test clrpick-1.2.2 {tk_chooseColor command } -body { + tk_chooseColor -title +} -returnCodes error -result {value for "-title" missing} + +test clrpick-1.3 {tk_chooseColor command} -body { + tk_chooseColor -foo bar +} -returnCodes error -result {bad option "-foo": must be -initialcolor, -parent, or -title} +test clrpick-1.4 {tk_chooseColor command} -body { + tk_chooseColor -initialcolor +} -returnCodes error -result {value for "-initialcolor" missing} +test clrpick-1.5 {tk_chooseColor command} -body { + tk_chooseColor -parent foo.bar +} -returnCodes error -result {bad window path name "foo.bar"} +test clrpick-1.6 {tk_chooseColor command} -body { + tk_chooseColor -initialcolor badbadbaadcolor +} -returnCodes error -result {unknown color name "badbadbaadcolor"} +test clrpick-1.7 {tk_chooseColor command} -body { + tk_chooseColor -initialcolor ##badbadbaadcolor +} -returnCodes error -result {invalid color name "##badbadbaadcolor"} + + +# tests 3.1 and 3.2 fail when individually run +# if there is no catch {tk_chooseColor -foo 1} msg +# before settin isNative +catch {tk_chooseColor -foo 1} msg set isNative [expr {[info commands tk::dialog::color::] eq ""}] proc ToPressButton {parent btn} { global isNative if {!$isNative} { - after 200 "SendButtonPress $parent $btn mouse" + after 200 "SendButtonPress . $btn mouse" } } proc ToChooseColorByKey {parent r g b} { global isNative if {!$isNative} { - after 200 ChooseColorByKey $parent $r $g $b + after 200 ChooseColorByKey . $r $g $b } } @@ -115,7 +119,7 @@ proc ChooseColorByKey {parent r g b} { # the values for us. tk::dialog::color::HandleRGBEntry $w - SendButtonPress $parent ok mouse + SendButtonPress . ok mouse } proc SendButtonPress {parent btn type} { @@ -137,65 +141,76 @@ proc SendButtonPress {parent btn type} { } } -set parent . - -set verylongstring longstring: -set verylongstring $verylongstring$verylongstring -set verylongstring $verylongstring$verylongstring -set verylongstring $verylongstring$verylongstring -set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring -# Interesting thing...when this is too long, the -# delay caused in processing it kills the automated testing, -# and makes a lot of the test cases fail. -#set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring -#set verylongstring $verylongstring$verylongstring - -set color #404040 -test clrpick-2.1 {tk_chooseColor command} \ - {nonUnixUserInteraction colorsLeftover} { - ToPressButton $parent ok - tk_chooseColor -title "Press Ok $verylongstring" -initialcolor $color \ - -parent $parent -} "$color" -set color #808040 -test clrpick-2.2 {tk_chooseColor command} \ - {nonUnixUserInteraction colorsLeftover} { + + +test clrpick-2.1 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -setup { + set verylongstring longstring: + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring + # Interesting thing...when this is too long, the + # delay caused in processing it kills the automated testing, + # and makes a lot of the test cases fail. + #set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring + #set verylongstring $verylongstring$verylongstring +} -body { + ToPressButton . ok + tk_chooseColor -title "Press Ok $verylongstring" -initialcolor #404040 \ + -parent . +} -result {#404040} +test clrpick-2.2 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -body { set colors "128 128 64" - ToChooseColorByKey $parent 128 128 64 - tk_chooseColor -parent $parent -title "choose $colors" -} "$color" -test clrpick-2.3 {tk_chooseColor command} \ - {nonUnixUserInteraction colorsLeftover} { - ToPressButton $parent ok - tk_chooseColor -parent $parent -title "Press OK" -} "$color" -test clrpick-2.4 {tk_chooseColor command} {nonUnixUserInteraction} { - ToPressButton $parent cancel - tk_chooseColor -parent $parent -title "Press Cancel" -} "" - -set color "#000000" -test clrpick-3.1 {tk_chooseColor: background events} {nonUnixUserInteraction} { + ToChooseColorByKey . 128 128 64 + tk_chooseColor -parent . -title "choose #808040" +} -result {#808040} +test clrpick-2.3 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -body { + ToPressButton . ok + tk_chooseColor -parent . -title "Press OK" +} -result {#808040} +test clrpick-2.4 {tk_chooseColor command} -constraints { + nonUnixUserInteraction colorsLeftover +} -body { + ToPressButton . cancel + tk_chooseColor -parent . -title "Press Cancel" +} -result {} + + +test clrpick-3.1 {tk_chooseColor: background events} -constraints { + nonUnixUserInteraction +} -body { after 1 {set x 53} - ToPressButton $parent ok - tk_chooseColor -parent $parent -title "Press OK" -initialcolor $color -} "#000000" -test clrpick-3.2 {tk_chooseColor: background events} {nonUnixUserInteraction} { + ToPressButton . ok + tk_chooseColor -parent . -title "Press OK" -initialcolor #000000 +} -result {#000000} +test clrpick-3.2 {tk_chooseColor: background events} -constraints { + nonUnixUserInteraction +} -body { after 1 {set x 53} - ToPressButton $parent cancel - tk_chooseColor -parent $parent -title "Press Cancel" -} "" + ToPressButton . cancel + tk_chooseColor -parent . -title "Press Cancel" +} -result {} -test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} {unix notAqua} { + +test clrpick-4.1 {tk_chooseColor: screen is inherited from parent} -constraints { + unix notAqua +} -body { after 50 {set ::scr [winfo screen .__tk__color]} - ToPressButton $parent cancel - tk_chooseColor -parent $parent + ToPressButton . cancel + tk_chooseColor -parent . set ::scr -} [winfo screen $parent] +} -result [winfo screen .] # cleanup cleanupTests return + diff --git a/tests/cmds.test b/tests/cmds.test index f630209..fa7e788 100644 --- a/tests/cmds.test +++ b/tests/cmds.test @@ -5,38 +5,56 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test update -test cmds-1.1 {tkwait visibility, argument errors} { - list [catch {tkwait visibility} msg] $msg -} {1 {wrong # args: should be "tkwait variable|visibility|window name"}} -test cmds-1.2 {tkwait visibility, argument errors} { - list [catch {tkwait visibility foo bar} msg] $msg -} {1 {wrong # args: should be "tkwait variable|visibility|window name"}} -test cmds-1.3 {tkwait visibility, argument errors} { - list [catch {tkwait visibility bad_window} msg] $msg -} {1 {bad window path name "bad_window"}} -test cmds-1.4 {tkwait visibility, waiting for window to be mapped} { +test cmds-1.1 {tkwait visibility, argument errors} -body { + tkwait visibility +} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"} +test cmds-1.2 {tkwait visibility, argument errors} -body { + tkwait visibility foo bar +} -returnCodes {error} -result {wrong # args: should be "tkwait variable|visibility|window name"} +test cmds-1.3 {tkwait visibility, argument errors} -body { + tkwait visibility bad_window +} -returnCodes {error} -result {bad window path name "bad_window"} +test cmds-1.4 {tkwait visibility, waiting for window to be mapped} -setup { button .b -text "Test" set x init +} -body { after 100 {set x delay; place .b -x 0 -y 0} tkwait visibility .b + return $x +} -cleanup { destroy .b - set x -} {delay} -test cmds-1.5 {tkwait visibility, window gets deleted} { +} -result {delay} +test cmds-1.5 {tkwait visibility, window gets deleted} -setup { frame .f button .f.b -text "Test" pack .f.b set x init +} -body { after 100 {set x deleted; destroy .f} - list [catch {tkwait visibility .f.b} msg] $msg $x -} {1 {window ".f.b" was deleted before its visibility changed} deleted} + tkwait visibility .f.b +} -returnCodes {error} -result {window ".f.b" was deleted before its visibility changed} +test cmds-1.6 {tkwait visibility, window gets deleted} -setup { + frame .f + button .f.b -text "Test" + pack .f.b + set x init +} -body { + after 100 {set x deleted; destroy .f} + catch {tkwait visibility .f.b} + return $x +} -cleanup { + destroy .f +} -result {deleted} + # cleanup cleanupTests return + diff --git a/tests/config.test b/tests/config.test index 0d1e0e1..8f7aa9f 100644 --- a/tests/config.test +++ b/tests/config.test @@ -6,7 +6,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -14,436 +15,1038 @@ proc killTables {} { # Note: it's important to delete chain2 before chain1, because # chain2 depends on chain1. If chain1 is deleted first, the # delete of chain2 will crash. - + deleteWindows foreach t {alltypes chain2 chain1 configerror internal new notenoughparams twowindows} { - while {[testobjconfig info $t] != ""} { - testobjconfig delete $t - } + while {[testobjconfig info $t] != ""} { + testobjconfig delete $t + } } } + +option clear +deleteWindows if {[testConstraint testobjconfig]} { killTables } -test config-1.1 {Tk_CreateOptionTable - reference counts} testobjconfig { - deleteWindows - killTables +test config-1.1 {Tk_CreateOptionTable - reference counts} -constraints { + testobjconfig +} -body { set x {} testobjconfig alltypes .a lappend x [testobjconfig info alltypes] testobjconfig alltypes .b lappend x [testobjconfig info alltypes] - deleteWindows set x -} {{1 16 -boolean} {2 16 -boolean}} -test config-1.2 {Tk_CreateOptionTable - synonym initialization} testobjconfig { - deleteWindows +} -cleanup { + killTables +} -result {{1 16 -boolean} {2 16 -boolean}} +test config-1.2 {Tk_CreateOptionTable - synonym initialization} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a -synonym green .a cget -color -} {green} -test config-1.3 {Tk_CreateOptionTable - option database initialization} testobjconfig { - deleteWindows - option clear +} -cleanup { + killTables +} -result {green} +test config-1.3 {Tk_CreateOptionTable - option database initialization} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a option add *b.string different testobjconfig alltypes .b list [.a cget -string] [.b cget -string] -} {foo different} -test config-1.4 {Tk_CreateOptionTable - option database initialization} testobjconfig { - deleteWindows +} -cleanup { + killTables option clear +} -result {foo different} +test config-1.4 {Tk_CreateOptionTable - option database initialization} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a option add *b.String bar testobjconfig alltypes .b list [.a cget -string] [.b cget -string] -} {foo bar} -test config-1.5 {Tk_CreateOptionTable - default initialization} testobjconfig { - deleteWindows +} -cleanup { + killTables + option clear +} -result {foo bar} +test config-1.5 {Tk_CreateOptionTable - default initialization} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a .a cget -relief -} {raised} -test config-1.6 {Tk_CreateOptionTable - chained tables} testobjconfig { - deleteWindows +} -cleanup { killTables +} -result {raised} +test config-1.6 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { testobjconfig chain1 .a testobjconfig chain2 .b testobjconfig info chain2 -} {1 4 -three 2 2 -one} -test config-1.7 {Tk_CreateOptionTable - chained tables} testobjconfig { - deleteWindows +} -cleanup { killTables +} -result {1 4 -three 2 2 -one} +test config-1.7 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { testobjconfig chain2 .b testobjconfig chain1 .a testobjconfig info chain2 -} {1 4 -three 2 2 -one} -test config-1.8 {Tk_CreateOptionTable - chained tables} testobjconfig { - deleteWindows +} -cleanup { + killTables +} -result {1 4 -three 2 2 -one} +test config-1.8 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { testobjconfig chain1 .a testobjconfig chain2 .b - list [catch {.a cget -four} msg] $msg [.a cget -one] \ - [.b cget -four] [.b cget -one] -} {1 {unknown option "-four"} one four one} - -test config-2.1 {Tk_DeleteOptionTable - reference counts} testobjconfig { - deleteWindows + .a cget -four +} -cleanup { killTables +} -returnCodes error -result {unknown option "-four"} +test config-1.9 {Tk_CreateOptionTable - chained tables} -constraints { + testobjconfig +} -body { + testobjconfig chain1 .a + testobjconfig chain2 .b + catch {.a cget -four} + list [.a cget -one] [.b cget -four] [.b cget -one] +} -cleanup { + killTables +} -result {one four one} + + +test config-2.1 {Tk_DeleteOptionTable - reference counts} -constraints { + testobjconfig +} -body { + set x {} testobjconfig chain1 .a testobjconfig chain2 .b testobjconfig chain2 .c deleteWindows - set x {} testobjconfig delete chain2 lappend x [testobjconfig info chain2] [testobjconfig info chain1] testobjconfig delete chain2 lappend x [testobjconfig info chain2] [testobjconfig info chain1] -} {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}} +} -cleanup { + killTables +} -result {{1 4 -three 2 2 -one} {2 2 -one} {} {1 2 -one}} # No tests for DestroyOptionHashTable; couldn't figure out how to test. -test config-3.1 {Tk_InitOptions - priority of chained tables} testobjconfig { - deleteWindows +test config-3.1 {Tk_InitOptions - priority of chained tables} -constraints { + testobjconfig +} -body { testobjconfig chain1 .a testobjconfig chain2 .b list [.a cget -two] [.b cget -two] -} {two {two and a half}} -test config-3.2 {Tk_InitOptions - initialize from database} testobjconfig { - deleteWindows - option clear +} -cleanup { + killTables +} -result {two {two and a half}} +test config-3.2 {Tk_InitOptions - initialize from database} -constraints { + testobjconfig +} -body { option add *a.color blue testobjconfig alltypes .a list [.a cget -color] -} {blue} -test config-3.3 {Tk_InitOptions - initialize from database} testobjconfig { - deleteWindows +} -cleanup { + killTables option clear +} -result {blue} +test config-3.3 {Tk_InitOptions - initialize from database} -constraints { + testobjconfig +} -body { option add *a.justify bogus testobjconfig alltypes .a list [.a cget -justify] -} {left} -test config-3.4 {Tk_InitOptions - initialize from widget class} testobjconfig { - deleteWindows +} -cleanup { + killTables + option clear +} -result {left} +test config-3.4 {Tk_InitOptions - initialize from widget class} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a list [.a cget -color] -} {red} -test config-3.5 {Tk_InitOptions - no initial value} testobjconfig { - deleteWindows +} -cleanup { + killTables +} -result {red} +test config-3.5 {Tk_InitOptions - no initial value} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a .a cget -anchor -} {} -test config-3.6 {Tk_InitOptions - bad initial value} testobjconfig { - deleteWindows +} -cleanup { + killTables +} -result {} +test config-3.6 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + option add *a.color non-existent + testobjconfig alltypes .a +} -cleanup { + killTables option clear +} -returnCodes error -result {unknown color name "non-existent"} +test config-3.7 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { option add *a.color non-existent - list [catch {testobjconfig alltypes .a} msg] $msg $errorInfo -} {1 {unknown color name "non-existent"} {unknown color name "non-existent" + catch {testobjconfig alltypes .a} + return $errorInfo +} -cleanup { + killTables + option clear +} -result {unknown color name "non-existent" (database entry for "-color" in widget ".a") invoked from within -"testobjconfig alltypes .a"}} -option clear -test config-3.7 {Tk_InitOptions - bad initial value} testobjconfig { - deleteWindows - list [catch {testobjconfig configerror} msg] $msg $errorInfo -} {1 {expected integer but got "bogus"} {expected integer but got "bogus" +"testobjconfig alltypes .a"} + +test config-3.8 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + testobjconfig configerror +} -returnCodes error -result {expected integer but got "bogus"} +test config-3.9 {Tk_InitOptions - bad initial value} -constraints { + testobjconfig +} -body { + catch {testobjconfig configerror} + return $errorInfo +} -result {expected integer but got "bogus" (default value for "-int") invoked from within -"testobjconfig configerror"}} -option clear +"testobjconfig configerror"} -test config-4.1 {DoObjConfig - boolean} testobjconfig { +test config-4.1 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 0 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.2 {DoObjConfig - boolean} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -boolean 0} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] -} {0 .foo 0 0 0} -test config-4.2 {DoObjConfig - boolean} testobjconfig { +} -body { + testobjconfig alltypes .foo -boolean 0 + .foo cget -boolean +} -cleanup { + killTables +} -returnCodes ok -result {0} +test config-4.3 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 0 + .foo cget -boolean + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.4 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 1 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.5 {DoObjConfig - boolean} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -boolean 1 + .foo cget -boolean +} -cleanup { + killTables +} -returnCodes ok -result {1} +test config-4.6 {DoObjConfig - boolean} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -boolean 1} msg] $msg [catch {.foo cget -boolean} result] $result [catch {rename .foo {}}] -} {0 .foo 0 1 0} -test config-4.3 {DoObjConfig - invalid boolean} testobjconfig { +} -body { + testobjconfig alltypes .foo -boolean 1 + .foo cget -boolean + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.7 {DoObjConfig - invalid boolean} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -boolean {}} msg] $msg -} {1 {expected boolean value but got ""}} -test config-4.4 {DoObjConfig - boolean internal value} testobjconfig { +} -body { + testobjconfig alltypes .foo -boolean {} +} -cleanup { + killTables +} -returnCodes error -result {expected boolean value but got ""} +test config-4.8 {DoObjConfig - boolean internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -boolean 0 .foo cget -boolean -} {0} -test config-4.5 {DoObjConfig - integer} testobjconfig { +} -cleanup { + killTables +} -result {0} + +test config-4.9 {DoObjConfig - integer} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -integer 3} msg] $msg [catch {.foo cget -integer} result] $result [catch {rename .foo {}}] -} {0 .foo 0 3 0} -test config-4.6 {DoObjConfig - invalid integer} testobjconfig { +} -body { + testobjconfig alltypes .foo -integer 3 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.10 {DoObjConfig - integer} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -integer bar} msg] $msg -} {1 {expected integer but got "bar"}} -test config-4.7 {DoObjConfig - integer internal value} testobjconfig { +} -body { + testobjconfig alltypes .foo -integer 3 + .foo cget -integer +} -cleanup { + killTables +} -returnCodes ok -result {3} +test config-4.11 {DoObjConfig - integer} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -integer 3 + .foo cget -integer + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.12 {DoObjConfig - invalid integer} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -integer bar +} -cleanup { + killTables +} -cleanup { + killTables +} -returnCodes error -result {expected integer but got "bar"} +test config-4.13 {DoObjConfig - integer internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -integer 421 .foo cget -integer -} {421} -test config-4.8 {DoObjConfig - double} testobjconfig { +} -cleanup { + killTables +} -result {421} + +test config-4.14 {DoObjConfig - double} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -double 3.14} msg] $msg [catch {.foo cget -double} result] $result [catch {rename .foo {}}] -} {0 .foo 0 3.14 0} -test config-4.9 {DoObjConfig - invalid double} testobjconfig { +} -body { + testobjconfig alltypes .foo -double 3.14 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.15 {DoObjConfig - double} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -double bar} msg] $msg -} {1 {expected floating-point number but got "bar"}} -test config-4.10 {DoObjConfig - double internal value} testobjconfig { +} -body { + testobjconfig alltypes .foo -double 3.14 + .foo cget -double +} -cleanup { + killTables +} -returnCodes ok -result {3.14} +test config-4.16 {DoObjConfig - double} -constraints testobjconfig -setup { catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -double 3.14 + .foo cget -double + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.17 {DoObjConfig - invalid double} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -double bar +} -cleanup { + killTables +} -returnCodes error -result {expected floating-point number but got "bar"} +test config-4.18 {DoObjConfig - double internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { testobjconfig internal .foo -double 62.75 .foo cget -double -} {62.75} -test config-4.11 {DoObjConfig - string} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -string test} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] -} {0 .foo 0 test {}} -test config-4.12 {DoObjConfig - null string} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -string {}} msg] $msg [catch {.foo cget -string} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.13 {DoObjConfig - string internal value} testobjconfig { +} -cleanup { + killTables +} -result {62.75} + +test config-4.19 {DoObjConfig - string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string test +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.20 {DoObjConfig - string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string test + .foo cget -string +} -cleanup { + killTables +} -returnCodes ok -result {test} +test config-4.21 {DoObjConfig - string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string test + .foo cget -string + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.22 {DoObjConfig - null string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.23 {DoObjConfig - null string} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string {} + .foo cget -string +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.24 {DoObjConfig - null string} -constraints testobjconfig -setup { catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -string {} + .foo cget -string + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok + +test config-4.25 {DoObjConfig - string internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { testobjconfig internal .foo -string "this is a test" .foo cget -string -} {this is a test} -test config-4.14 {DoObjConfig - string table} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -stringtable two} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] -} {0 .foo 0 two {}} -test config-4.15 {DoObjConfig - invalid string table} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -stringtable foo} msg] $msg -} {1 {bad stringtable "foo": must be one, two, three, or four}} -test config-4.16 {DoObjConfig - new string table} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {this is a test} + +test config-4.26 {DoObjConfig - string table} -constraints testobjconfig -body { + testobjconfig alltypes .foo -stringtable two +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.27 {DoObjConfig - string table} -constraints testobjconfig -body { + testobjconfig alltypes .foo -stringtable two + .foo cget -stringtable +} -cleanup { + killTables +} -returnCodes ok -result {two} +test config-4.28 {DoObjConfig - string table} -constraints testobjconfig -body { testobjconfig alltypes .foo -stringtable two - list [catch {.foo configure -stringtable three} msg] $msg [catch {.foo cget -stringtable} result] $result [destroy .foo] -} {0 16 0 three {}} -test config-4.17 {DoObjConfig - stringtable internal value} testobjconfig { + .foo cget -stringtable + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.29 {DoObjConfig - invalid string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable foo +} -cleanup { + killTables +} -returnCodes error -result {bad stringtable "foo": must be one, two, three, or four} + +test config-4.30 {DoObjConfig - new string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable two + .foo configure -stringtable three +} -cleanup { + killTables +} -returnCodes ok -result {16} +test config-4.31 {DoObjConfig - new string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable two + .foo configure -stringtable three + .foo cget -stringtable +} -cleanup { + killTables +} -returnCodes ok -result {three} +test config-4.32 {DoObjConfig - new string table} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -stringtable two + .foo configure -stringtable three + .foo cget -stringtable + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.33 {DoObjConfig - stringtable internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -stringtable "four" .foo cget -stringtable -} {four} -test config-4.18 {DoObjConfig - color} testobjconfig { - catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -color blue} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] -} {0 .foo 0 blue {}} -test config-4.19 {DoObjConfig - invalid color} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -color xxx} msg] $msg -} {1 {unknown color name "xxx"}} -test config-4.20 {DoObjConfig - color internal value} testobjconfig { +} -cleanup { + killTables +} -result {four} + +test config-4.34 {DoObjConfig - color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color blue +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.35 {DoObjConfig - color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color blue + .foo cget -color +} -cleanup { + killTables +} -returnCodes ok -result {blue} +test config-4.36 {DoObjConfig - color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color blue + .foo cget -color + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.37 {DoObjConfig - invalid color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color xxx +} -cleanup { + killTables +} -returnCodes error -result {unknown color name "xxx"} +test config-4.38 {DoObjConfig - color internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -color purple .foo cget -color -} {purple} -test config-4.21 {DoObjConfig - null color} testobjconfig { - catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -color {}} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.22 {DoObjConfig - getting rid of old color} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {purple} + +test config-4.39 {DoObjConfig - null color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.40 {DoObjConfig - null color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color {} + .foo cget -color +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.41 {DoObjConfig - null color} -constraints testobjconfig -body { + testobjconfig alltypes .foo -color {} + .foo cget -color + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.42 {DoObjConfig - getting rid of old color} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo -color #333333 - list [catch {.foo configure -color #444444} msg] $msg [catch {.foo cget -color} result] $result [destroy .foo] -} {0 32 0 #444444 {}} -test config-4.23 {DoObjConfig - font} testobjconfig { + .foo configure -color #444444 +} -cleanup { + killTables +} -returnCodes ok -result {32} +test config-4.43 {DoObjConfig - getting rid of old color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color #333333 + .foo configure -color #444444 + .foo cget -color +} -cleanup { + killTables +} -returnCodes ok -result {#444444} +test config-4.44 {DoObjConfig - getting rid of old color} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color #333333 + .foo configure -color #444444 + .foo cget -color + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok + +test config-4.45 {DoObjConfig - font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {Helvetica 72} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.46 {DoObjConfig - font} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] -} {0 .foo 0 {Helvetica 72} {}} -test config-4.24 {DoObjConfig - new font} testobjconfig { +} -body { + testobjconfig alltypes .foo -font {Helvetica 72} + .foo cget -font +} -cleanup { + killTables +} -returnCodes ok -result {Helvetica 72} +test config-4.47 {DoObjConfig - new font} -constraints testobjconfig -setup { catch {rename .foo {}} +} -body { testobjconfig alltypes .foo -font {Courier 12} - list [catch {.foo configure -font {Helvetica 72}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] -} {0 64 0 {Helvetica 72} {}} -test config-4.25 {DoObjConfig - invalid font} testobjconfig { + .foo configure -font {Helvetica 72} +} -cleanup { + killTables +} -returnCodes ok -result {64} +test config-4.48 {DoObjConfig - new font} -constraints testobjconfig -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -font {Helvetica 12 foo}} msg] $msg -} {1 {unknown font style "foo"}} -test config-4.26 {DoObjConfig - null font} testobjconfig { +} -body { + testobjconfig alltypes .foo -font {Courier 12} + .foo configure -font {Helvetica 72} + .foo cget -font +} -cleanup { + killTables +} -returnCodes ok -result {Helvetica 72} +test config-4.49 {DoObjConfig - invalid font} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -font {}} msg] $msg [catch {.foo cget -font} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.27 {DoObjConfig - font internal value} testobjconfig { +} -body { + testobjconfig alltypes .foo -font {Helvetica 12 foo} +} -cleanup { + killTables +} -returnCodes error -result {unknown font style "foo"} +test config-4.50 {DoObjConfig - null font} -constraints testobjconfig -setup { catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.51 {DoObjConfig - null font} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -font {} + .foo cget -font +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.52 {DoObjConfig - font internal value} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { testobjconfig internal .foo -font {Times 16} .foo cget -font -} {Times 16} -test config-4.28 {DoObjConfig - bitmap} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -bitmap gray75} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] -} {0 .foo 0 gray75 {}} -test config-4.29 {DoObjConfig - new bitmap} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {Times 16} + +test config-4.53 {DoObjConfig - bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.54 {DoObjConfig - bitmap} -constraints testobjconfig -body { testobjconfig alltypes .foo -bitmap gray75 - list [catch {.foo configure -bitmap gray50} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] -} {0 128 0 gray50 {}} -test config-4.30 {DoObjConfig - invalid bitmap} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -bitmap foo} msg] $msg -} {1 {bitmap "foo" not defined}} -test config-4.31 {DoObjConfig - null bitmap} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -bitmap {}} msg] $msg [catch {.foo cget -bitmap} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.32 {DoObjConfig - bitmap internal value} testobjconfig { + .foo cget -bitmap +} -cleanup { + killTables +} -returnCodes ok -result {gray75} +test config-4.55 {DoObjConfig - new bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 + .foo configure -bitmap gray50 +} -cleanup { + killTables +} -returnCodes ok -result {128} +test config-4.56 {DoObjConfig - new bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap gray75 + .foo configure -bitmap gray50 + .foo cget -bitmap +} -cleanup { + killTables +} -returnCodes ok -result {gray50} +test config-4.57 {DoObjConfig - invalid bitmap} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -bitmap foo +} -cleanup { + killTables +} -returnCodes error -result {bitmap "foo" not defined} +test config-4.58 {DoObjConfig - null bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.59 {DoObjConfig - null bitmap} -constraints testobjconfig -body { + testobjconfig alltypes .foo -bitmap {} + .foo cget -bitmap +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.60 {DoObjConfig - bitmap internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -bitmap gray25 .foo cget -bitmap -} {gray25} -test config-4.33 {DoObjConfig - border} testobjconfig { - catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -border green} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] -} {0 .foo 0 green {}} -test config-4.34 {DoObjConfig - invalid border} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -border xxx} msg] $msg -} {1 {unknown color name "xxx"}} -test config-4.35 {DoObjConfig - null border} testobjconfig { - catch {rename .foo {}} - list [catch {testobjconfig alltypes .foo -border {}} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.36 {DoObjConfig - border internal value} testobjconfig { +} -cleanup { + killTables +} -result {gray25} + +test config-4.61 {DoObjConfig - border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border green +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.62 {DoObjConfig - border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border green + .foo cget -border +} -cleanup { + killTables +} -returnCodes ok -result {green} +test config-4.63 {DoObjConfig - invalid border} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -border xxx +} -cleanup { + killTables +} -returnCodes error -result {unknown color name "xxx"} +test config-4.64 {DoObjConfig - null border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.65 {DoObjConfig - null border} -constraints testobjconfig -body { + testobjconfig alltypes .foo -border {} + .foo cget -border +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.66 {DoObjConfig - border internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -border #123456 .foo cget -border -} {#123456} -test config-4.37 {DoObjConfig - getting rid of old border} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {#123456} +test config-4.67 {DoObjConfig - getting rid of old border} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo -border #333333 - list [catch {.foo configure -border #444444} msg] $msg [catch {.foo cget -border} result] $result [destroy .foo] -} {0 256 0 #444444 {}} -test config-4.38 {DoObjConfig - relief} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] -} {0 .foo 0 flat {}} -test config-4.39 {DoObjConfig - invalid relief} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -relief foo} msg] $msg -} {1 {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken}} -test config-4.40 {DoObjConfig - new relief} testobjconfig { - catch {destroy .foo} - testobjconfig alltypes .foo -relief raised - list [catch {.foo configure -relief flat} msg] $msg [catch {.foo cget -relief} result] $result [destroy .foo] -} {0 512 0 flat {}} -test config-4.41 {DoObjConfig - relief internal value} testobjconfig { + .foo configure -border #444444 +} -cleanup { + killTables +} -returnCodes ok -result {256} +test config-4.68 {DoObjConfig - getting rid of old border} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -border #333333 + .foo configure -border #444444 + .foo cget -border +} -cleanup { + killTables +} -returnCodes ok -result {#444444} + +test config-4.69 {DoObjConfig - relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief flat +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.70 {DoObjConfig - relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief flat + .foo cget -relief +} -cleanup { + killTables +} -returnCodes ok -result {flat} +test config-4.71 {DoObjConfig - invalid relief} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -relief foo +} -cleanup { + killTables +} -returnCodes error -result {bad relief "foo": must be flat, groove, raised, ridge, solid, or sunken} +test config-4.72 {DoObjConfig - relief internal value} -constraints testobjconfig -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -relief ridge .foo cget -relief -} {ridge} -test config-4.42 {DoObjConfig - cursor} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] -} {0 .foo 0 arrow {}} -test config-4.43 {DoObjConfig - invalid cursor} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -cursor foo} msg] $msg -} {1 {bad cursor spec "foo"}} -test config-4.44 {DoObjConfig - null cursor} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -cursor {}} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.45 {DoObjConfig - new cursor} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {ridge} +test config-4.73 {DoObjConfig - new relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief raised + .foo configure -relief flat +} -cleanup { + killTables +} -returnCodes ok -result {512} +test config-4.74 {DoObjConfig - new relief} -constraints testobjconfig -body { + testobjconfig alltypes .foo -relief raised + .foo configure -relief flat + .foo cget -relief +} -cleanup { + killTables +} -returnCodes ok -result {flat} + +test config-4.75 {DoObjConfig - cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor arrow +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.76 {DoObjConfig - cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor arrow + .foo cget -cursor +} -cleanup { + killTables +} -returnCodes ok -result {arrow} +test config-4.77 {DoObjConfig - invalid cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor foo +} -cleanup { + killTables +} -returnCodes error -result {bad cursor spec "foo"} +test config-4.78 {DoObjConfig - null cursor} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -cursor {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.79 {DoObjConfig - null cursor} -constraints testobjconfig -setup { + catch {rename .foo {}} +} -body { + testobjconfig alltypes .foo -cursor {} + .foo cget -cursor +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.80 {DoObjConfig - new cursor} -constraints testobjconfig -body { testobjconfig alltypes .foo -cursor xterm - list [catch {.foo configure -cursor arrow} msg] $msg [catch {.foo cget -cursor} result] $result [destroy .foo] -} {0 1024 0 arrow {}} -test config-4.46 {DoObjConfig - cursor internal value} testobjconfig { + .foo configure -cursor arrow +} -cleanup { + killTables +} -returnCodes ok -result {1024} +test config-4.81 {DoObjConfig - new cursor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -cursor xterm + .foo configure -cursor arrow + .foo cget -cursor +} -cleanup { + killTables +} -returnCodes ok -result {arrow} +test config-4.82 {DoObjConfig - cursor internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -cursor watch .foo cget -cursor -} {watch} -test config-4.47 {DoObjConfig - justify} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -justify center} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] -} {0 .foo 0 center {}} -test config-4.48 {DoObjConfig - invalid justify} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -justify foo} msg] $msg -} {1 {bad justification "foo": must be left, right, or center}} -test config-4.49 {DoObjConfig - new justify} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {watch} + +test config-4.83 {DoObjConfig - justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify center +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.84 {DoObjConfig - justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify center + .foo cget -justify +} -cleanup { + killTables +} -returnCodes ok -result {center} +test config-4.85 {DoObjConfig - invalid justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify foo +} -cleanup { + killTables +} -returnCodes error -result {bad justification "foo": must be left, right, or center} +test config-4.86 {DoObjConfig - new justify} -constraints testobjconfig -body { testobjconfig alltypes .foo -justify left - list [catch {.foo configure -justify right} msg] $msg [catch {.foo cget -justify} result] $result [destroy .foo] -} {0 2048 0 right {}} -test config-4.50 {DoObjConfig - justify internal value} testobjconfig { + .foo configure -justify right +} -cleanup { + killTables +} -returnCodes ok -result {2048} +test config-4.87 {DoObjConfig - new justify} -constraints testobjconfig -body { + testobjconfig alltypes .foo -justify left + .foo configure -justify right + .foo cget -justify +} -cleanup { + killTables +} -returnCodes ok -result {right} +test config-4.88 {DoObjConfig - justify internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -justify center .foo cget -justify -} {center} -test config-4.51 {DoObjConfig - anchor} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -anchor center} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] -} {0 .foo 0 center {}} -test config-4.52 {DoObjConfig - invalid anchor} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -anchor foo} msg] $msg -} {1 {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center}} -test config-4.53 {DoObjConfig - new anchor} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {center} + +test config-4.89 {DoObjConfig - anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor center +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.90 {DoObjConfig - anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor center + .foo cget -anchor +} -cleanup { + killTables +} -returnCodes ok -result {center} +test config-4.91 {DoObjConfig - invalid anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor foo +} -cleanup { + killTables +} -returnCodes error -result {bad anchor "foo": must be n, ne, e, se, s, sw, w, nw, or center} +test config-4.92 {DoObjConfig - new anchor} -constraints testobjconfig -body { testobjconfig alltypes .foo -anchor e - list [catch {.foo configure -anchor n} msg] $msg [catch {.foo cget -anchor} result] $result [destroy .foo] -} {0 4096 0 n {}} -test config-4.54 {DoObjConfig - anchor internal value} testobjconfig { + .foo configure -anchor n +} -cleanup { + killTables +} -returnCodes ok -result {4096} +test config-4.93 {DoObjConfig - new anchor} -constraints testobjconfig -body { + testobjconfig alltypes .foo -anchor e + .foo configure -anchor n + .foo cget -anchor +} -cleanup { + killTables +} -returnCodes ok -result {n} +test config-4.94 {DoObjConfig - anchor internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -anchor sw .foo cget -anchor -} {sw} -test config-4.55 {DoObjConfig - pixel} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -pixel 42} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] -} {0 .foo 0 42 {}} -test config-4.56 {DoObjConfig - invalid pixel} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -pixel foo} msg] $msg -} {1 {bad screen distance "foo"}} -test config-4.57 {DoObjConfig - new pixel} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {sw} +test config-4.95 {DoObjConfig - pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.96 {DoObjConfig - pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42 + .foo cget -pixel +} -cleanup { + killTables +} -returnCodes ok -result {42} +test config-4.97 {DoObjConfig - invalid pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel foo +} -cleanup { + killTables +} -returnCodes error -result {bad screen distance "foo"} +test config-4.98 {DoObjConfig - new pixel} -constraints testobjconfig -body { + testobjconfig alltypes .foo -pixel 42m + .foo configure -pixel 3c +} -cleanup { + killTables +} -returnCodes ok -result {8192} +test config-4.99 {DoObjConfig - new pixel} -constraints testobjconfig -body { testobjconfig alltypes .foo -pixel 42m - list [catch {.foo configure -pixel 3c} msg] $msg [catch {.foo cget -pixel} result] $result [destroy .foo] -} {0 8192 0 3c {}} -test config-4.58 {DoObjConfig - pixel internal value} testobjconfig { + .foo configure -pixel 3c + .foo cget -pixel +} -cleanup { + killTables +} -returnCodes ok -result {3c} +test config-4.100 {DoObjConfig - pixel internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -pixel [winfo screenmmwidth .]m - .foo cget -pixel -} [winfo screenwidth .] -test config-4.59 {DoObjConfig - window} testobjconfig { - catch {destroy .foo} - catch {destroy .bar} + set screenW [winfo screenwidth .] + set result [.foo cget -pixel] + expr {$screenW eq $result} +} -cleanup { + killTables +} -result {1} + +test config-4.101 {DoObjConfig - window} -constraints testobjconfig -body { toplevel .bar - list [catch {testobjconfig twowindows .foo -window .bar} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] -} {0 .foo 0 .bar {} {}} -test config-4.60 {DoObjConfig - invalid window} testobjconfig { - catch {destroy .foo} + testobjconfig twowindows .foo -window .bar +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.102 {DoObjConfig - window} -constraints testobjconfig -body { toplevel .bar - list [catch {testobjconfig twowindows .foo -window foo} msg] $msg [destroy .bar] -} {1 {bad window path name "foo"} {}} -test config-4.61 {DoObjConfig - null window} testobjconfig { - catch {destroy .foo} - catch {destroy .bar} + testobjconfig twowindows .foo -window .bar + .foo cget -window +} -cleanup { + killTables +} -returnCodes ok -result {.bar} +test config-4.103 {DoObjConfig - invalid window} -constraints testobjconfig -body { toplevel .bar - list [catch {testobjconfig twowindows .foo -window {}} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.62 {DoObjConfig - new window} testobjconfig { - catch {destroy .foo} - catch {destroy .bar} - catch {destroy .blamph} + testobjconfig twowindows .foo -window foo +} -cleanup { + killTables +} -returnCodes error -result {bad window path name "foo"} +test config-4.104 {DoObjConfig - null window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.105 {DoObjConfig - null window} -constraints testobjconfig -body { + toplevel .bar + testobjconfig twowindows .foo -window {} + .foo cget -window +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.106 {DoObjConfig - new window} -constraints testobjconfig -body { toplevel .bar toplevel .blamph testobjconfig twowindows .foo -window .bar - list [catch {.foo configure -window .blamph} msg] $msg [catch {.foo cget -window} result] $result [destroy .foo] [destroy .bar] [destroy .blamph] -} {0 0 0 .blamph {} {} {}} -test config-4.63 {DoObjConfig - window internal value} testobjconfig { + .foo configure -window .blamph +} -cleanup { + killTables +} -returnCodes ok -result {0} +test config-4.107 {DoObjConfig - new window} -constraints testobjconfig -body { + toplevel .bar + toplevel .blamph + testobjconfig twowindows .foo -window .bar + .foo configure -window .blamph + .foo cget -window +} -cleanup { + killTables +} -returnCodes ok -result {.blamph} +test config-4.108 {DoObjConfig - window internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -window . .foo cget -window -} {.} -test config-4.64 {DoObjConfig - releasing old values} testobjconfig { +} -cleanup { + killTables +} -result {.} + +test config-4.109 {DoObjConfig - releasing old values} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { # This test doesn't generate a useful value to check; if an # error occurs, it will be detected only by memory checking software # such as Purify or Tcl's built-in checker. - catch {rename .foo {}} testobjconfig alltypes .foo -string {Test string} -color yellow \ -font {Courier 18} -bitmap questhead -border green -cursor cross \ -custom foobar @@ -451,13 +1054,18 @@ test config-4.64 {DoObjConfig - releasing old values} testobjconfig { -font {Times 8} -bitmap gray75 -border pink -cursor watch \ -custom barbaz concat {} -} {} -test config-4.65 {DoObjConfig - releasing old values} testobjconfig { +} -cleanup { + killTables +} -result {} +test config-4.110 {DoObjConfig - releasing old values} -constraints { + testobjconfig +} -setup { + catch {rename .foo {}} +} -body { # This test doesn't generate a useful value to check; if an # error occurs, it will be detected only by memory checking software # such as Purify or Tcl's built-in checker. - catch {rename .foo {}} testobjconfig internal .foo -string {Test string} -color yellow \ -font {Courier 18} -bitmap questhead -border green -cursor cross \ -custom foobar @@ -465,421 +1073,844 @@ test config-4.65 {DoObjConfig - releasing old values} testobjconfig { -font {Times 8} -bitmap gray75 -border pink -cursor watch \ -custom barbaz concat {} -} {} -test config-4.66 {DoObjConfig - custom} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -custom test} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo] -} {0 .foo 0 TEST {}} -test config-4.67 {DoObjConfig - null custom} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -custom {}} msg] $msg [catch {.foo cget -custom} result] $result [destroy .foo] -} {0 .foo 0 {} {}} -test config-4.68 {DoObjConfig - custom internal value} testobjconfig { +} -cleanup { + killTables +} -result {} + +test config-4.111 {DoObjConfig - custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom test +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.112 {DoObjConfig - custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom test + .foo cget -custom +} -cleanup { + killTables +} -returnCodes ok -result {TEST} +test config-4.113 {DoObjConfig - null custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom {} +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.114 {DoObjConfig - null custom} -constraints testobjconfig -body { + testobjconfig alltypes .foo -custom {} + .foo cget -custom +} -cleanup { + killTables +} -returnCodes ok -result {} +test config-4.115 {DoObjConfig - custom internal value} -constraints { + testobjconfig +} -setup { catch {rename .foo {}} +} -body { testobjconfig internal .foo -custom "this is a test" .foo cget -custom -} {THIS IS A TEST} +} -cleanup { + killTables +} -result {THIS IS A TEST} -test config-5.1 {ObjectIsEmpty - object is already string} testobjconfig { - catch {destroy .foo} + +test config-5.1 {ObjectIsEmpty - object is already string} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo -color [format ""] .foo cget -color -} {} -test config-5.2 {ObjectIsEmpty - object is already string} testobjconfig { - catch {destroy .foo} - list [catch {testobjconfig alltypes .foo -color [format " "]} msg] $msg -} {1 {unknown color name " "}} -test config-5.3 {ObjectIsEmpty - must convert back to string} testobjconfig { - catch {destroy .foo} +} -cleanup { + killTables +} -result {} +test config-5.2 {ObjectIsEmpty - object is already string} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .foo -color [format " "] +} -cleanup { + killTables +} -returnCodes error -result {unknown color name " "} +test config-5.3 {ObjectIsEmpty - must convert back to string} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo -color [list] .foo cget -color -} {} +} -cleanup { + killTables +} -result {} -deleteWindows -if {[testConstraint testobjconfig]} { + +test config-6.1 {GetOptionFromObj - cached answer} -constraints { + testobjconfig +} -body { testobjconfig chain2 .a - testobjconfig alltypes .b -} -test config-6.1 {GetOptionFromObj - cached answer} testobjconfig { list [.a cget -three] [.a cget -three] -} {three three} -test config-6.2 {GetOptionFromObj - exact match} testobjconfig { +} -cleanup { + killTables +} -result {three three} +test config-6.2 {GetOptionFromObj - exact match} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a .a cget -one -} {one} -test config-6.3 {GetOptionFromObj - abbreviation} testobjconfig { +} -cleanup { + killTables +} -result {one} +test config-6.3 {GetOptionFromObj - abbreviation} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a .a cget -fo -} {four} -test config-6.4 {GetOptionFromObj - ambiguous abbreviation} testobjconfig { - list [catch {.a cget -on} msg] $msg -} {1 {unknown option "-on"}} -test config-6.5 {GetOptionFromObj - duplicate options in different tables} testobjconfig { +} -cleanup { + killTables +} -result {four} +test config-6.4 {GetOptionFromObj - ambiguous abbreviation} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a + .a cget -on +} -cleanup { + killTables +} -cleanup { + killTables +} -returnCodes error -result {unknown option "-on"} +test config-6.5 {GetOptionFromObj - duplicate options in different tables} -constraints { + testobjconfig +} -body { + testobjconfig chain2 .a .a cget -tw -} {two and a half} -test config-6.6 {GetOptionFromObj - synonym} testobjconfig { +} -cleanup { + killTables +} -result {two and a half} +test config-6.6 {GetOptionFromObj - synonym} -constraints testobjconfig -body { + testobjconfig alltypes .b .b cget -synonym -} {red} +} -cleanup { + killTables +} -result {red} + -deleteWindows if {[testConstraint testobjconfig]} { testobjconfig alltypes .a } -test config-7.1 {Tk_SetOptions - basics} testobjconfig { +test config-7.1 {Tk_SetOptions - basics} -constraints testobjconfig -body { .a configure -color green -rel sunken list [.a cget -color] [.a cget -relief] -} {green sunken} -test config-7.2 {Tk_SetOptions - bogus option name} testobjconfig { - list [catch {.a configure -bogus} msg] $msg -} {1 {unknown option "-bogus"}} -test config-7.3 {Tk_SetOptions - synonym} testobjconfig { +} -result {green sunken} +test config-7.2 {Tk_SetOptions - bogus option name} -constraints { + testobjconfig +} -body { + .a configure -bogus +} -returnCodes error -result {unknown option "-bogus"} +test config-7.3 {Tk_SetOptions - synonym} -constraints testobjconfig -body { .a configure -synonym blue .a cget -color -} {blue} -test config-7.4 {Tk_SetOptions - missing value} testobjconfig { - list [catch {.a configure -color green -relief} msg] $msg [.a cget -color] -} {1 {value for "-relief" missing} green} -test config-7.5 {Tk_SetOptions - saving old values} testobjconfig { +} -result {blue} +test config-7.4 {Tk_SetOptions - missing value} -constraints { + testobjconfig +} -body { + .a configure -color green -relief +} -returnCodes error -result {value for "-relief" missing} +test config-7.5 {Tk_SetOptions - missing value} -constraints { + testobjconfig +} -body { + catch {.a configure -color green -relief} + .a cget -color +} -result {green} +test config-7.6 {Tk_SetOptions - saving old values} -constraints { + testobjconfig +} -body { + .a configure -color red -int 7 -relief raised -double 3.14159 + .a csave -color green -int 432 -relief sunken -double 2.0 -color bogus +} -returnCodes error -result {unknown color name "bogus"} +test config-7.7 {Tk_SetOptions - saving old values} -constraints { + testobjconfig +} -body { .a configure -color red -int 7 -relief raised -double 3.14159 - list [catch {.a csave -color green -int 432 -relief sunken \ - -double 2.0 -color bogus} msg] $msg [.a cget -color] \ - [.a cget -int] [.a cget -relief] [.a cget -double] -} {1 {unknown color name "bogus"} red 7 raised 3.14159} -test config-7.6 {Tk_SetOptions - error in DoObjConfig call} testobjconfig { - list [catch {.a configure -color bogus} msg] $msg $errorInfo -} {1 {unknown color name "bogus"} {unknown color name "bogus" + catch {.a csave -color green -int 432 -relief sunken -double 2.0 -color bogus} + list [.a cget -color] [.a cget -int] [.a cget -relief] [.a cget -double] +} -result {red 7 raised 3.14159} + +test config-7.8 {Tk_SetOptions - error in DoObjConfig call} -constraints { + testobjconfig +} -body { + .a configure -color bogus +} -returnCodes error -result {unknown color name "bogus"} +test config-7.9 {Tk_SetOptions - error in DoObjConfig call} -constraints { + testobjconfig +} -body { + catch {.a configure -color bogus} + return $errorInfo +} -result {unknown color name "bogus" (processing "-color" option) invoked from within -".a configure -color bogus"}} -test config-7.7 {Tk_SetOptions - synonym name in error message} testobjconfig { - list [catch {.a configure -synonym bogus} msg] $msg $errorInfo -} {1 {unknown color name "bogus"} {unknown color name "bogus" +".a configure -color bogus"} + +test config-7.10 {Tk_SetOptions - synonym name in error message} -constraints { + testobjconfig +} -body { + .a configure -synonym bogus +} -returnCodes error -result {unknown color name "bogus"} +test config-7.11 {Tk_SetOptions - synonym name in error message} -constraints { + testobjconfig +} -body { + catch {.a configure -synonym bogus} + return $errorInfo +} -result {unknown color name "bogus" (processing "-synonym" option) invoked from within -".a configure -synonym bogus"}} -test config-7.8 {Tk_SetOptions - returning mask} testobjconfig { +".a configure -synonym bogus"} +test config-7.12 {Tk_SetOptions - returning mask} -constraints testobjconfig -body { format %x [.a configure -color red -int 7 -relief raised -double 3.14159] -} {226} -test config-7.9 {Tk_SetOptions - error in DoObjConfig with custom option} testobjconfig { - list [catch {.a configure -custom bad} msg] $msg $errorInfo -} {1 {expected good value, got "BAD"} {expected good value, got "BAD" +} -result {226} +test config-7.13 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { + testobjconfig +} -body { + .a configure -custom bad +} -returnCodes error -result {expected good value, got "BAD"} +test config-7.14 {Tk_SetOptions - error in DoObjConfig with custom option} -constraints { + testobjconfig +} -body { + catch {.a configure -custom bad} + return $errorInfo +} -result {expected good value, got "BAD" (processing "-custom" option) invoked from within -".a configure -custom bad"}} +".a configure -custom bad"} +if {[testConstraint testobjconfig]} { + killTables +} -test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} testobjconfig { - deleteWindows + +test config-8.1 {Tk_RestoreSavedOptions - restore in proper order} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a - list [catch {.a csave -color green -color black -color blue \ - -color #ffff00 -color #ff00ff -color bogus} msg] $msg \ - [.a cget -color] -} {1 {unknown color name "bogus"} red} -test config-8.2 {Tk_RestoreSavedOptions - freeing object memory} testobjconfig { - deleteWindows + .a csave -color green -color black -color blue \ + -color #ffff00 -color #ff00ff -color bogus \ +} -cleanup { + killTables +} -returnCodes error -result {unknown color name "bogus"} +test config-8.2 {Tk_RestoreSavedOptions - restore in proper order} -constraints { + testobjconfig +} -body { testobjconfig alltypes .a - .a csave -color green -color black -color blue -color #ffff00 \ - -color #ff00ff -} {32} -test config-8.3 {Tk_RestoreSavedOptions - boolean internal form} testobjconfig { - deleteWindows + catch {.a csave -color green -color black -color blue \ + -color #ffff00 -color #ff00ff -color bogus} + .a cget -color +} -cleanup { + killTables +} -result {red} +test config-8.3 {Tk_RestoreSavedOptions - freeing object memory} -constraints { + testobjconfig +} -body { + testobjconfig alltypes .a + .a csave -color green -color black -color blue -color #ffff00 -color #ff00ff +} -cleanup { + killTables +} -result {32} +test config-8.4 {Tk_RestoreSavedOptions - boolean internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -boolean 0 -color bogus}] [.a cget -boolean] -} {1 1} -test config-8.4 {Tk_RestoreSavedOptions - integer internal form} testobjconfig { - deleteWindows + .a csave -boolean 0 -color bogus +} -cleanup { + killTables +} -returnCodes error -match glob -result * +test config-8.5 {Tk_RestoreSavedOptions - boolean internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -integer 24 -color bogus}] [.a cget -integer] -} {1 148962237} -test config-8.5 {Tk_RestoreSavedOptions - double internal form} testobjconfig { - deleteWindows + catch {.a csave -boolean 0 -color bogus} + .a cget -boolean +} -cleanup { + killTables +} -result {1} +test config-8.6 {Tk_RestoreSavedOptions - integer internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -double 62.4 -color bogus}] [.a cget -double] -} {1 3.14159} -test config-8.6 {Tk_RestoreSavedOptions - string internal form} testobjconfig { - deleteWindows + .a csave -integer 24 -color bogus +} -cleanup { + killTables +} -returnCodes error -match glob -result * +test config-8.7 {Tk_RestoreSavedOptions - integer internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -string "A long string" -color bogus}] \ - [.a cget -string] -} {1 foo} -test config-8.7 {Tk_RestoreSavedOptions - string table internal form} testobjconfig { - deleteWindows + catch {.a csave -integer 24 -color bogus} + .a cget -integer +} -cleanup { + killTables +} -result {148962237} +test config-8.8 {Tk_RestoreSavedOptions - double internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -stringtable three -color bogus}] \ - [.a cget -stringtable] -} {1 one} -test config-8.8 {Tk_RestoreSavedOptions - color internal form} testobjconfig { - deleteWindows + catch {.a csave -double 62.4 -color bogus} + .a cget -double +} -cleanup { + killTables +} -result {3.14159} +test config-8.9 {Tk_RestoreSavedOptions - string internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -color green -color bogus}] [.a cget -color] -} {1 red} -test config-8.9 {Tk_RestoreSavedOptions - font internal form} {testobjconfig nonPortable} { - deleteWindows + catch {.a csave -string "A long string" -color bogus} + .a cget -string +} -cleanup { + killTables +} -result {foo} +test config-8.10 {Tk_RestoreSavedOptions - string table internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -font {Times 12} -color bogus}] [.a cget -font] -} {1 {Helvetica 12}} -test config-8.10 {Tk_RestoreSavedOptions - bitmap internal form} testobjconfig { - deleteWindows + catch {.a csave -stringtable three -color bogus} + .a cget -stringtable +} -cleanup { + killTables +} -result {one} +test config-8.11 {Tk_RestoreSavedOptions - color internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -bitmap questhead -color bogus}] [.a cget -bitmap] -} {1 gray50} -test config-8.11 {Tk_RestoreSavedOptions - border internal form} testobjconfig { - deleteWindows + catch {.a csave -color green -color bogus} + .a cget -color +} -cleanup { + killTables +} -result {red} +test config-8.12 {Tk_RestoreSavedOptions - font internal form} -constraints { + testobjconfig nonPortable +} -body { testobjconfig internal .a - list [catch {.a csave -border brown -color bogus}] [.a cget -border] -} {1 blue} -test config-8.12 {Tk_RestoreSavedOptions - relief internal form} testobjconfig { - deleteWindows + catch {.a csave -font {Times 12} -color bogus} + .a cget -font +} -cleanup { + killTables +} -result {Helvetica 12} +test config-8.13 {Tk_RestoreSavedOptions - bitmap internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -relief sunken -color bogus}] [.a cget -relief] -} {1 raised} -test config-8.13 {Tk_RestoreSavedOptions - cursor internal form} testobjconfig { - deleteWindows + catch {.a csave -bitmap questhead -color bogus} + .a cget -bitmap +} -cleanup { + killTables +} -result {gray50} +test config-8.14 {Tk_RestoreSavedOptions - border internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -cursor watch -color bogus}] [.a cget -cursor] -} {1 xterm} -test config-8.14 {Tk_RestoreSavedOptions - justify internal form} testobjconfig { - deleteWindows + catch {.a csave -border brown -color bogus} + .a cget -border +} -cleanup { + killTables +} -result {blue} +test config-8.15 {Tk_RestoreSavedOptions - relief internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -justify right -color bogus}] [.a cget -justify] -} {1 left} -test config-8.15 {Tk_RestoreSavedOptions - anchor internal form} testobjconfig { - deleteWindows + catch {.a csave -relief sunken -color bogus} + .a cget -relief +} -cleanup { + killTables +} -result {raised} +test config-8.16 {Tk_RestoreSavedOptions - cursor internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a - list [catch {.a csave -anchor center -color bogus}] [.a cget -anchor] -} {1 n} -test config-8.16 {Tk_RestoreSavedOptions - window internal form} testobjconfig { - deleteWindows + catch {.a csave -cursor watch -color bogus} + .a cget -cursor +} -cleanup { + killTables +} -result {xterm} +test config-8.17 {Tk_RestoreSavedOptions - justify internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -justify right -color bogus} + .a cget -justify +} -cleanup { + killTables +} -result {left} +test config-8.18 {Tk_RestoreSavedOptions - anchor internal form} -constraints { + testobjconfig +} -body { + testobjconfig internal .a + catch {.a csave -anchor center -color bogus} + .a cget -anchor +} -cleanup { + killTables +} -result {n} +test config-8.19 {Tk_RestoreSavedOptions - window internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a -window .a - list [catch {.a csave -window .a -color bogus}] [.a cget -window] -} {1 .a} -test config-8.17 {Tk_RestoreSavedOptions - custom internal form} testobjconfig { - deleteWindows + catch {.a csave -window .a -color bogus} + .a cget -window +} -cleanup { + killTables +} -result {.a} +test config-8.20 {Tk_RestoreSavedOptions - custom internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .a -custom "foobar" - list [catch {.a csave -custom "barbaz" -color bogus}] [.a cget -custom] -} {1 FOOBAR} + catch {.a csave -custom "barbaz" -color bogus} + .a cget -custom +} -cleanup { + killTables +} -result {FOOBAR} # Most of the tests below will cause memory leakage if there is a # problem. This may not be evident unless the tests are run in # conjunction with a memory usage analyzer such as Purify. -test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} testobjconfig { - catch {destroy .foo} +test config-9.1 {Tk_FreeConfigOptions/FreeResources - string internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .foo .foo configure -string "two words" destroy .foo -} {} -test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.2 {Tk_FreeConfigOptions/FreeResources - color internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .foo .foo configure -color yellow destroy .foo -} {} -test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.3 {Tk_FreeConfigOptions/FreeResources - color} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -color [format blue] destroy .foo -} {} -test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.4 {Tk_FreeConfigOptions/FreeResources - font internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .foo .foo configure -font {Courier 20} destroy .foo -} {} -test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.5 {Tk_FreeConfigOptions/FreeResources - font} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -font [format {Courier 24}] destroy .foo -} {} -test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.6 {Tk_FreeConfigOptions/FreeResources - bitmap internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .foo .foo configure -bitmap gray75 destroy .foo -} {} -test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.7 {Tk_FreeConfigOptions/FreeResources - bitmap} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -bitmap [format gray75] destroy .foo -} {} -test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.8 {Tk_FreeConfigOptions/FreeResources - border internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .foo .foo configure -border orange destroy .foo -} {} -test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.9 {Tk_FreeConfigOptions/FreeResources - border} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -border [format blue] destroy .foo -} {} -test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.10 {Tk_FreeConfigOptions/FreeResources - cursor internal form} -constraints { + testobjconfig +} -body { testobjconfig internal .foo .foo configure -cursor cross destroy .foo -} {} -test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.11 {Tk_FreeConfigOptions/FreeResources - cursor} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -cursor [format watch] destroy .foo -} {} -test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} testobjconfig { - catch {destroy .foo} +} -result {} +test config-9.12 {Tk_FreeConfigOptions/FreeResources - not special} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -integer [format 27] destroy .foo -} {} -test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} testobjconfig { +} -result {} +test config-9.13 {Tk_FreeConfigOptions/FreeResources - custom internal form} -constraints { + testobjconfig +} -body { catch {destroy .fpp} testobjconfig internal .foo .foo configure -custom "foobar" destroy .foo -} {} +} -result {} +if {[testConstraint testobjconfig]} { + killTables +} + -test config-10.1 {Tk_GetOptionInfo - one item} testobjconfig { - catch {destroy .foo} +test config-10.1 {Tk_GetOptionInfo - one item} -constraints testobjconfig -body { testobjconfig alltypes .foo .foo configure -relief groove .foo configure -relief -} {-relief relief Relief raised groove} -test config-10.2 {Tk_GetOptionInfo - one item, synonym} testobjconfig { - catch {destroy .foo} +} -cleanup { + destroy .foo +} -result {-relief relief Relief raised groove} +test config-10.2 {Tk_GetOptionInfo - one item, synonym} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo .foo configure -color black .foo configure -synonym -} {-color color Color red black} -test config-10.3 {Tk_GetOptionInfo - all items} testobjconfig { - catch {destroy .foo} +} -cleanup { + destroy .foo +} -result {-color color Color red black} +test config-10.3 {Tk_GetOptionInfo - all items} -constraints { + testobjconfig +} -body { testobjconfig alltypes .foo -font {Helvetica 18} -integer 13563 .foo configure -} {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}} -test config-10.4 {Tk_GetOptionInfo - chaining through tables} testobjconfig { - catch {destroy .foo} +} -cleanup { + destroy .foo +} -result {{-boolean boolean Boolean 1 1} {-integer integer Integer 7 13563} {-double double Double 3.14159 3.14159} {-string string String foo foo} {-stringtable StringTable stringTable one one} {-color color Color red red} {-font font Font {Helvetica 12} {Helvetica 18}} {-bitmap bitmap Bitmap gray50 gray50} {-border border Border blue blue} {-relief relief Relief raised raised} {-cursor cursor Cursor xterm xterm} {-justify {} {} left left} {-anchor anchor Anchor {} {}} {-pixel pixel Pixel 1 1} {-custom {} {} {} {}} {-synonym -color}} +test config-10.4 {Tk_GetOptionInfo - chaining through tables} -constraints testobjconfig -body { testobjconfig chain2 .foo -one asdf -three xyzzy .foo configure -} {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} +} -cleanup { + destroy .foo +} -result {{-three three Three three xyzzy} {-four four Four four four} {-two two Two {two and a half} {two and a half}} {-oneAgain oneAgain OneAgain {one again} {one again}} {-one one One one asdf} {-two two Two two {two and a half}}} +if {[testConstraint testobjconfig]} { + killTables +} + -deleteWindows if {[testConstraint testobjconfig]} { testobjconfig alltypes .a } -test config-11.1 {GetConfigList - synonym} testobjconfig { +test config-11.1 {GetConfigList - synonym} -constraints testobjconfig -body { lindex [.a configure] end -} {-synonym -color} -test config-11.2 {GetConfigList - null database names} testobjconfig { +} -result {-synonym -color} +test config-11.2 {GetConfigList - null database names} -constraints { + testobjconfig +} -body { .a configure -justify -} {-justify {} {} left left} -test config-11.3 {GetConfigList - null default and current value} testobjconfig { +} -result {-justify {} {} left left} +test config-11.3 {GetConfigList - null default and current value} -constraints { + testobjconfig +} -body { .a configure -anchor -} {-anchor anchor Anchor {} {}} +} -result {-anchor anchor Anchor {} {}} +if {[testConstraint testobjconfig]} { + killTables +} + -deleteWindows if {[testConstraint testobjconfig]} { testobjconfig internal .a } -test config-12.1 {GetObjectForOption - boolean} testobjconfig { +test config-12.1 {GetObjectForOption - boolean} -constraints testobjconfig -body { .a configure -boolean 0 .a cget -boolean -} {0} -test config-12.2 {GetObjectForOption - integer} testobjconfig { +} -result {0} +test config-12.2 {GetObjectForOption - integer} -constraints testobjconfig -body { .a configure -integer 1247 .a cget -integer -} {1247} -test config-12.3 {GetObjectForOption - double} testobjconfig { +} -result {1247} +test config-12.3 {GetObjectForOption - double} -constraints testobjconfig -body { .a configure -double -88.82 .a cget -double -} {-88.82} -test config-12.4 {GetObjectForOption - string} testobjconfig { +} -result {-88.82} +test config-12.4 {GetObjectForOption - string} -constraints testobjconfig -body { .a configure -string "test value" .a cget -string -} {test value} -test config-12.5 {GetObjectForOption - stringTable} testobjconfig { +} -result {test value} +test config-12.5 {GetObjectForOption - stringTable} -constraints { + testobjconfig +} -body { .a configure -stringtable "two" .a cget -stringtable -} {two} -test config-12.6 {GetObjectForOption - color} testobjconfig { +} -result {two} +test config-12.6 {GetObjectForOption - color} -constraints testobjconfig -body { .a configure -color "green" .a cget -color -} {green} -test config-12.7 {GetObjectForOption - font} testobjconfig { +} -result {green} +test config-12.7 {GetObjectForOption - font} -constraints testobjconfig -body { .a configure -font {Times 36} .a cget -font -} {Times 36} -test config-12.8 {GetObjectForOption - bitmap} testobjconfig { +} -result {Times 36} +test config-12.8 {GetObjectForOption - bitmap} -constraints testobjconfig -body { .a configure -bitmap "questhead" .a cget -bitmap -} {questhead} -test config-12.9 {GetObjectForOption - border} testobjconfig { +} -result {questhead} +test config-12.9 {GetObjectForOption - border} -constraints testobjconfig -body { .a configure -border #33217c .a cget -border -} {#33217c} -test config-12.10 {GetObjectForOption - relief} testobjconfig { +} -result {#33217c} +test config-12.10 {GetObjectForOption - relief} -constraints { + testobjconfig +} -body { .a configure -relief groove .a cget -relief -} {groove} -test config-12.11 {GetObjectForOption - cursor} testobjconfig { +} -result {groove} +test config-12.11 {GetObjectForOption - cursor} -constraints { + testobjconfig +} -body { .a configure -cursor watch .a cget -cursor -} {watch} -test config-12.12 {GetObjectForOption - justify} testobjconfig { +} -result {watch} +test config-12.12 {GetObjectForOption - justify} -constraints { + testobjconfig +} -body { .a configure -justify right .a cget -justify -} {right} -test config-12.13 {GetObjectForOption - anchor} testobjconfig { +} -result {right} +test config-12.13 {GetObjectForOption - anchor} -constraints testobjconfig -body { .a configure -anchor e .a cget -anchor -} {e} -test config-12.14 {GetObjectForOption - pixels} testobjconfig { +} -result {e} +test config-12.14 {GetObjectForOption - pixels} -constraints testobjconfig -body { .a configure -pixel 193.2 .a cget -pixel -} {193} -test config-12.15 {GetObjectForOption - window} testobjconfig { +} -result {193} +test config-12.15 {GetObjectForOption - window} -constraints testobjconfig -body { .a configure -window .a .a cget -window -} {.a} -test config-12.16 {GetObjectForOption -custom} testobjconfig { +} -result {.a} +test config-12.16 {GetObjectForOption -custom} -constraints testobjconfig -body { .a configure -custom foobar .a cget -custom -} {FOOBAR} -test config-12.17 {GetObjectForOption - null values} testobjconfig { +} -result {FOOBAR} +test config-12.17 {GetObjectForOption - null values} -constraints { + testobjconfig +} -body { .a configure -string {} -color {} -font {} -bitmap {} -border {} \ -cursor {} -window {} -custom {} list [.a cget -string] [.a cget -color] [.a cget -font] \ [.a cget -bitmap] [.a cget -border] [.a cget -cursor] \ [.a cget -window] [.a cget -custom] -} {{} {} {} {} {} {} {} {}} - -test config-13.1 {proper cleanup of options with widget destroy} { - foreach type { - button canvas entry frame listbox menu menubutton message - scale scrollbar text radiobutton checkbutton - } { - destroy .w - $type .w -cursor crosshair - destroy .w - } -} {} +} -result {{} {} {} {} {} {} {} {}} +if {[testConstraint testobjconfig]} { + killTables +} -deleteWindows -test config-14.1 {Tk_CreateOptionTable - use with namespace import} { +test config-13.1 {proper cleanup of options with widget destroy} -body { + button .w -cursor crosshair + destroy .w +} -result {} +test config-13.2 {proper cleanup of options with widget destroy} -body { + canvas .w -cursor crosshair + destroy .w +} -result {} +test config-13.3 {proper cleanup of options with widget destroy} -body { + entry .w -cursor crosshair + destroy .w +} -result {} +test config-13.4 {proper cleanup of options with widget destroy} -body { + frame .w -cursor crosshair + destroy .w +} -result {} +test config-13.5 {proper cleanup of options with widget destroy} -body { + listbox .w -cursor crosshair + destroy .w +} -result {} +test config-13.6 {proper cleanup of options with widget destroy} -body { + menu .w -cursor crosshair + destroy .w +} -result {} +test config-13.7 {proper cleanup of options with widget destroy} -body { + menubutton .w -cursor crosshair + destroy .w +} -result {} +test config-13.8 {proper cleanup of options with widget destroy} -body { + message .w -cursor crosshair + destroy .w +} -result {} +test config-13.9 {proper cleanup of options with widget destroy} -body { + scale .w -cursor crosshair + destroy .w +} -result {} +test config-13.10 {proper cleanup of options with widget destroy} -body { + scrollbar .w -cursor crosshair + destroy .w +} -result {} +test config-13.11 {proper cleanup of options with widget destroy} -body { + text .w -cursor crosshair + destroy .w +} -result {} +test config-13.12 {proper cleanup of options with widget destroy} -body { + radiobutton .w -cursor crosshair + destroy .w +} -result {} +test config-13.13 {proper cleanup of options with widget destroy} -body { + checkbutton .w -cursor crosshair + destroy .w +} -result {} + +test config-14.1 {Tk_CreateOptionTable - use with namespace import} -setup { namespace export -clear * - foreach type { - button canvas entry frame listbox menu menubutton message - scale scrollbar spinbox text radiobutton checkbutton - } { - namespace eval ::foo [subst { - namespace import -force ::$type - ::foo::$type .a - ::foo::$type .b - } - ] - destroy .a .b - } -} {} +} -body { + namespace eval ::foo [subst { + namespace import -force ::button + ::foo::button .a + ::foo::button .b + } + ] + destroy .a .b +} -result {} +test config-14.2 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::canvas + ::foo::canvas .a + ::foo::canvas .b + } + ] + destroy .a .b +} -result {} +test config-14.3 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::entry + ::foo::entry .a + ::foo::entry .b + } + ] + destroy .a .b +} -result {} +test config-14.4 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::frame + ::foo::frame .a + ::foo::frame .b + } + ] + destroy .a .b +} -result {} +test config-14.5 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::listbox + ::foo::listbox .a + ::foo::listbox .b + } + ] + destroy .a .b +} -result {} +test config-14.6 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::menu + ::foo::menu .a + ::foo::menu .b + } + ] + destroy .a .b +} -result {} +test config-14.7 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::menubutton + ::foo::menubutton .a + ::foo::menubutton .b + } + ] + destroy .a .b +} -result {} +test config-14.8 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::message + ::foo::message .a + ::foo::message .b + } + ] + destroy .a .b +} -result {} +test config-14.9 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::scale + ::foo::scale .a + ::foo::scale .b + } + ] + destroy .a .b +} -result {} +test config-14.10 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::scrollbar + ::foo::scrollbar .a + ::foo::scrollbar .b + } + ] + destroy .a .b +} -result {} +test config-14.11 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::spinbox + ::foo::spinbox .a + ::foo::spinbox .b + } + ] + destroy .a .b +} -result {} +test config-14.12 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::text + ::foo::text .a + ::foo::text .b + } + ] + destroy .a .b +} -result {} +test config-14.13 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::radiobutton + ::foo::radiobutton .a + ::foo::radiobutton .b + } + ] + destroy .a .b +} -result {} +test config-14.14 {Tk_CreateOptionTable - use with namespace import} -setup { + namespace export -clear * +} -body { + namespace eval ::foo [subst { + namespace import -force ::checkbutton + ::foo::checkbutton .a + ::foo::checkbutton .b + } + ] + destroy .a .b +} -result {} + # cleanup deleteWindows @@ -888,3 +1919,11 @@ if {[testConstraint testobjconfig]} { } cleanupTests return + + + + + + + + diff --git a/tests/constraints.tcl b/tests/constraints.tcl index 843ee4d..ac32852 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -138,6 +138,42 @@ namespace eval tk { focus -force .focus.e destroy .focus } + + + namespace export imageInit imageFinish imageCleanup imageNames + variable ImageNames + proc imageInit {} { + variable ImageNames + if {![info exists ImageNames]} { + set ImageNames [lsort [image names]] + } + imageCleanup + if {[lsort [image names]] ne $ImageNames} { + return -code error "IMAGE NAMES mismatch: [image names] != $ImageNames" + } + } + proc imageFinish {} { + variable ImageNames + if {[lsort [image names]] ne $ImageNames} { + return -code error "images remaining: [image names] != $ImageNames" + } + imageCleanup + } + proc imageCleanup {} { + variable ImageNames + foreach img [image names] { + if {$img ni $ImageNames} {image delete $img} + } + } + proc imageNames {} { + variable ImageNames + set r {} + foreach img [image names] { + if {$img ni $ImageNames} {lappend r $img} + } + return $r + } + } } @@ -182,7 +218,7 @@ testConstraint testwrapper [llength [info commands testwrapper]] # constraint to see what sort of fonts are available testConstraint fonts 1 destroy .e -entry .e -width 0 -font {Helvetica -12} -bd 1 +entry .e -width 0 -font {Helvetica -12} -bd 1 -highlightthickness 1 .e insert end a.bcd if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} { testConstraint fonts 0 @@ -242,7 +278,6 @@ namespace import -force tcltest::removeDirectory namespace import -force tcltest::interpreter namespace import -force tcltest::testsDirectory namespace import -force tcltest::cleanupTests -namespace import -force tcltest::bytestring deleteWindows wm geometry . {} diff --git a/tests/cursor.test b/tests/cursor.test index 539e933..1039b52 100644 --- a/tests/cursor.test +++ b/tests/cursor.test @@ -6,96 +6,133 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} {testcursor} { + +# Tests 2.3 and 2.4 need a helper file with a very specific name and +# controlled format. +proc setWincur {wincurName} { + upvar $wincurName wincur + set wincur(data_octal) { + 000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001 + 000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000 + 000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000 + 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 + 000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000 + 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 + 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 + 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 + 000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036 + 000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360 + 000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370 + 000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016 + 000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377 + 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 + 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 + 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 + 377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300 + 377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007 + 377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003 + 377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340 + 377 377 017 360 377 377 + } + set wincur(data_binary) {} + foreach wincur(num) $wincur(data_octal) { + append wincur(data_binary) [binary format c [scan $wincur(num) %o]] + } + set wincur(dir) [makeDirectory {dir with spaces}] + set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] +} + + +test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints { + testcursor +} -body { set x watch lindex $x 0 - destroy .b1 - button .b1 -cursor $x + button .b -cursor $x lindex $x 0 testcursor watch -} {{1 0}} -test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} {testcursor} { +} -cleanup { + destroy .b +} -result {{1 0}} +test cursor-1.2 {Tk_AllocCursorFromObj - discard stale cursor} -constraints { + testcursor +} -body { set x watch - destroy .b1 .b2 + set result {} button .b1 -cursor $x destroy .b1 - set result {} lappend result [testcursor watch] button .b2 -cursor $x lappend result [testcursor watch] -} {{} {{1 1}}} -test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} {testcursor} { +} -cleanup { + destroy .b2 +} -result {{} {{1 1}}} +test cursor-1.3 {Tk_AllocCursorFromObj - reuse existing cursor} -constraints { + testcursor +} -body { set x watch - destroy .b1 .b2 - button .b1 -cursor $x set result {} + button .b1 -cursor $x lappend result [testcursor watch] button .b2 -cursor $x pack .b1 .b2 -side top lappend result [testcursor watch] -} {{{1 1}} {{2 1}}} +} -cleanup { + destroy .b1 .b2 +} -result {{{1 1}} {{2 1}}} -test cursor-2.1 {Tk_GetCursor procedure} { - destroy .b1 - list [catch {button .b1 -cursor bad_name} msg] $msg -} {1 {bad cursor spec "bad_name"}} -test cursor-2.2 {Tk_GetCursor procedure} { - destroy .b1 - list [catch {button .b1 -cursor @xyzzy} msg] $msg -} {1 {bad cursor spec "@xyzzy"}} -# Next two tests need a helper file with a very specific name and -# controlled format. -set wincur(data_octal) { - 000 000 002 000 001 000 040 040 000 000 007 000 007 000 060 001 - 000 000 026 000 000 000 050 000 000 000 040 000 000 000 100 000 - 000 000 001 000 001 000 000 000 000 000 000 000 000 000 000 000 - 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 - 000 000 377 377 377 000 000 000 000 000 000 000 000 000 000 000 - 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 - 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 - 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 000 - 000 000 000 000 000 000 000 000 000 000 160 016 000 000 170 036 - 000 000 174 076 000 000 076 174 000 000 037 370 000 000 017 360 - 000 000 007 340 000 000 007 340 000 000 017 360 000 000 037 370 - 000 000 076 174 000 000 174 076 000 000 170 036 000 000 160 016 - 000 000 000 000 000 000 377 377 377 377 377 377 377 377 377 377 - 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 - 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 - 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 377 - 377 377 377 377 377 377 017 360 377 377 007 340 377 377 003 300 - 377 377 001 200 377 377 200 001 377 377 300 003 377 377 340 007 - 377 377 360 017 377 377 360 017 377 377 340 007 377 377 300 003 - 377 377 200 001 377 377 001 200 377 377 003 300 377 377 007 340 - 377 377 017 360 377 377 -} -set wincur(data_binary) {} -foreach wincur(num) $wincur(data_octal) { - append wincur(data_binary) [binary format c [scan $wincur(num) %o]] -} -set wincur(dir) [makeDirectory {dir with spaces}] -set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] -test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} win { - destroy .b1 - button .b1 -cursor [list @$wincur(file)] -} {.b1} -test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} win { - destroy .b1 - button .b1 -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}] -} {.b1} -removeDirectory $wincur(dir) -unset wincur +test cursor-2.1 {Tk_GetCursor procedure} -body { + button .b -cursor bad_name +} -cleanup { + destroy .b +} -returnCodes error -result {bad cursor spec "bad_name"} +test cursor-2.2 {Tk_GetCursor procedure} -body { + button .b -cursor @xyzzy +} -cleanup { + destroy .b +} -returnCodes error -result {bad cursor spec "@xyzzy"} -test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} { +test cursor-2.3 {Tk_GetCursor procedure: cursor specs are lists} -constraints { + win +} -setup { + unset -nocomplain wincur + set wincur(file) "" +} -body { + setWincur wincur + button .b -cursor [list @$wincur(file)] +} -cleanup { + destroy .b + removeDirectory $wincur(dir) + unset wincur +} -result {.b} +test cursor-2.4 {Tk_GetCursor procedure: cursor specs are lists} -constraints { + win +} -setup { + unset -nocomplain wincur + set wincur(file) "" +} -body { + setWincur wincur + button .b -cursor @[regsub -all {[][ \\{}""$#]} $wincur(file) {\\&}] +} -cleanup { + destroy .b + removeDirectory $wincur(dir) + unset wincur +} -result {.b} + +test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} -constraints { + testcursor +} -setup { set x heart - destroy .b1 .b2 .b3 + set result {} +} -body { button .b1 -cursor $x button .b3 -cursor $x button .b2 -cursor $x - set result {} lappend result [testcursor heart] destroy .b1 lappend result [testcursor heart] @@ -103,10 +140,11 @@ test cursor-3.1 {Tk_FreeCursorFromObj - reference counts} {testcursor} { lappend result [testcursor heart] destroy .b3 lappend result [testcursor heart] -} {{{3 1}} {{2 1}} {{1 1}} {}} +} -result {{{3 1}} {{2 1}} {{1 1}} {}} -test cursor-4.1 {FreeCursorObjProc} {testcursor} { - destroy .b +test cursor-4.1 {FreeCursorObjProc} -constraints { + testcursor +} -body { set x [format heart] button .b -cursor $x set y [format heart] @@ -123,10 +161,11 @@ test cursor-4.1 {FreeCursorObjProc} {testcursor} { lappend result [testcursor heart] set y bogus set result -} {{{1 3}} {{1 2}} {{1 1}} {}} +} -cleanup { + destroy .b +} -result {{{1 3}} {{1 2}} {{1 1}} {}} # ------------------------------------------------------------------------- - test cursor-5.1 {assert consistent cursor configuration command} -setup { button .b } -body { @@ -137,101 +176,551 @@ test cursor-5.1 {assert consistent cursor configuration command} -setup { # ------------------------------------------------------------------------- # Check for the standard set of cursors. - -foreach {testName cursor} { - cursor-6.1 X_cursor - cursor-6.2 arrow - cursor-6.3 based_arrow_down - cursor-6.4 based_arrow_up - cursor-6.5 boat - cursor-6.6 bogosity - cursor-6.7 bottom_left_corner - cursor-6.8 bottom_right_corner - cursor-6.9 bottom_side - cursor-6.10 bottom_tee - cursor-6.11 box_spiral - cursor-6.12 center_ptr - cursor-6.13 circle - cursor-6.14 clock - cursor-6.15 coffee_mug - cursor-6.16 cross - cursor-6.17 cross_reverse - cursor-6.18 crosshair - cursor-6.19 diamond_cross - cursor-6.20 dot - cursor-6.21 dotbox - cursor-6.22 double_arrow - cursor-6.23 draft_large - cursor-6.24 draft_small - cursor-6.25 draped_box - cursor-6.26 exchange - cursor-6.27 fleur - cursor-6.28 gobbler - cursor-6.29 gumby - cursor-6.30 hand1 - cursor-6.31 hand2 - cursor-6.32 heart - cursor-6.33 icon - cursor-6.34 iron_cross - cursor-6.35 left_ptr - cursor-6.36 left_side - cursor-6.37 left_tee - cursor-6.38 leftbutton - cursor-6.39 ll_angle - cursor-6.40 lr_angle - cursor-6.41 man - cursor-6.42 middlebutton - cursor-6.43 mouse - cursor-6.44 pencil - cursor-6.45 pirate - cursor-6.46 plus - cursor-6.47 question_arrow - cursor-6.48 right_ptr - cursor-6.49 right_side - cursor-6.50 right_tee - cursor-6.51 rightbutton - cursor-6.52 rtl_logo - cursor-6.53 sailboat - cursor-6.54 sb_down_arrow - cursor-6.55 sb_h_double_arrow - cursor-6.56 sb_left_arrow - cursor-6.57 sb_right_arrow - cursor-6.58 sb_up_arrow - cursor-6.59 sb_v_double_arrow - cursor-6.60 shuttle - cursor-6.61 sizing - cursor-6.62 spider - cursor-6.63 spraycan - cursor-6.64 star - cursor-6.65 target - cursor-6.66 tcross - cursor-6.67 top_left_arrow - cursor-6.68 top_left_corner - cursor-6.69 top_right_corner - cursor-6.70 top_side - cursor-6.71 top_tee - cursor-6.72 trek - cursor-6.73 ul_angle - cursor-6.74 umbrella - cursor-6.75 ur_angle - cursor-6.76 watch - cursor-6.77 xterm -} { - test $testName "check cursor-font cursor $cursor" -setup { - button .b -text $cursor - } -body { - .b configure -cursor $cursor - } -cleanup { - destroy .b - } -result {} -} +test cursor-6.1 {check cursor-font cursor X_cursor} -setup { + button .b -text X_cursor +} -body { + .b configure -cursor X_cursor +} -cleanup { + destroy .b +} -result {} +test cursor-6.2 {check cursor-font cursor arrow} -setup { + button .b -text arrow +} -body { + .b configure -cursor arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.3 {check cursor-font cursor based_arrow_down} -setup { + button .b -text based_arrow_down +} -body { + .b configure -cursor based_arrow_down +} -cleanup { + destroy .b +} -result {} +test cursor-6.4 {check cursor-font cursor based_arrow_up} -setup { + button .b -text based_arrow_up +} -body { + .b configure -cursor based_arrow_up +} -cleanup { + destroy .b +} -result {} +test cursor-6.5 {check cursor-font cursor boat} -setup { + button .b -text boat +} -body { + .b configure -cursor boat +} -cleanup { + destroy .b +} -result {} +test cursor-6.6 {check cursor-font cursor bogosity} -setup { + button .b -text bogosity +} -body { + .b configure -cursor bogosity +} -cleanup { + destroy .b +} -result {} +test cursor-6.7 {check cursor-font cursor bottom_left_corner} -setup { + button .b -text bottom_left_corner +} -body { + .b configure -cursor bottom_left_corner +} -cleanup { + destroy .b +} -result {} +test cursor-6.8 {check cursor-font cursor bottom_right_corner} -setup { + button .b -text bottom_right_corner +} -body { + .b configure -cursor bottom_right_corner +} -cleanup { + destroy .b +} -result {} +test cursor-6.9 {check cursor-font cursor bottom_side} -setup { + button .b -text bottom_side +} -body { + .b configure -cursor bottom_side +} -cleanup { + destroy .b +} -result {} +test cursor-6.10 {check cursor-font cursor bottom_tee} -setup { + button .b -text bottom_tee +} -body { + .b configure -cursor bottom_tee +} -cleanup { + destroy .b +} -result {} +test cursor-6.11 {check cursor-font cursor box_spiral} -setup { + button .b -text box_spiral +} -body { + .b configure -cursor box_spiral +} -cleanup { + destroy .b +} -result {} +test cursor-6.12 {check cursor-font cursor center_ptr} -setup { + button .b -text center_ptr +} -body { + .b configure -cursor center_ptr +} -cleanup { + destroy .b +} -result {} +test cursor-6.13 {check cursor-font cursor circle} -setup { + button .b -text circle +} -body { + .b configure -cursor circle +} -cleanup { + destroy .b +} -result {} +test cursor-6.14 {check cursor-font cursor clock} -setup { + button .b -text clock +} -body { + .b configure -cursor clock +} -cleanup { + destroy .b +} -result {} +test cursor-6.15 {check cursor-font cursor coffee_mug} -setup { + button .b -text coffee_mug +} -body { + .b configure -cursor coffee_mug +} -cleanup { + destroy .b +} -result {} +test cursor-6.16 {check cursor-font cursor cross} -setup { + button .b -text cross +} -body { + .b configure -cursor cross +} -cleanup { + destroy .b +} -result {} +test cursor-6.17 {check cursor-font cursor cross_reverse} -setup { + button .b -text cross_reverse +} -body { + .b configure -cursor cross_reverse +} -cleanup { + destroy .b +} -result {} +test cursor-6.18 {check cursor-font cursor crosshair} -setup { + button .b -text crosshair +} -body { + .b configure -cursor crosshair +} -cleanup { + destroy .b +} -result {} +test cursor-6.19 {check cursor-font cursor diamond_cross} -setup { + button .b -text diamond_cross +} -body { + .b configure -cursor diamond_cross +} -cleanup { + destroy .b +} -result {} +test cursor-6.20 {check cursor-font cursor dot} -setup { + button .b -text dot +} -body { + .b configure -cursor dot +} -cleanup { + destroy .b +} -result {} +test cursor-6.21 {check cursor-font cursor dotbox} -setup { + button .b -text dotbox +} -body { + .b configure -cursor dotbox +} -cleanup { + destroy .b +} -result {} +test cursor-6.22 {check cursor-font cursor double_arrow} -setup { + button .b -text double_arrow +} -body { + .b configure -cursor double_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.23 {check cursor-font cursor draft_large} -setup { + button .b -text draft_large +} -body { + .b configure -cursor draft_large +} -cleanup { + destroy .b +} -result {} +test cursor-6.24 {check cursor-font cursor draft_small} -setup { + button .b -text draft_small +} -body { + .b configure -cursor draft_small +} -cleanup { + destroy .b +} -result {} +test cursor-6.25 {check cursor-font cursor draped_box} -setup { + button .b -text draped_box +} -body { + .b configure -cursor draped_box +} -cleanup { + destroy .b +} -result {} +test cursor-6.26 {check cursor-font cursor exchange} -setup { + button .b -text exchange +} -body { + .b configure -cursor exchange +} -cleanup { + destroy .b +} -result {} +test cursor-6.27 {check cursor-font cursor fleur} -setup { + button .b -text fleur +} -body { + .b configure -cursor fleur +} -cleanup { + destroy .b +} -result {} +test cursor-6.28 {check cursor-font cursor gobbler} -setup { + button .b -text gobbler +} -body { + .b configure -cursor gobbler +} -cleanup { + destroy .b +} -result {} +test cursor-6.29 {check cursor-font cursor gumby} -setup { + button .b -text gumby +} -body { + .b configure -cursor gumby +} -cleanup { + destroy .b +} -result {} +test cursor-6.30 {check cursor-font cursor hand1} -setup { + button .b -text hand1 +} -body { + .b configure -cursor hand1 +} -cleanup { + destroy .b +} -result {} +test cursor-6.31 {check cursor-font cursor hand2} -setup { + button .b -text hand2 +} -body { + .b configure -cursor hand2 +} -cleanup { + destroy .b +} -result {} +test cursor-6.32 {check cursor-font cursor heart} -setup { + button .b -text heart +} -body { + .b configure -cursor heart +} -cleanup { + destroy .b +} -result {} +test cursor-6.33 {check cursor-font cursor icon} -setup { + button .b -text icon +} -body { + .b configure -cursor icon +} -cleanup { + destroy .b +} -result {} +test cursor-6.34 {check cursor-font cursor iron_cross} -setup { + button .b -text iron_cross +} -body { + .b configure -cursor iron_cross +} -cleanup { + destroy .b +} -result {} +test cursor-6.35 {check cursor-font cursor left_ptr} -setup { + button .b -text left_ptr +} -body { + .b configure -cursor left_ptr +} -cleanup { + destroy .b +} -result {} +test cursor-6.36 {check cursor-font cursor left_side} -setup { + button .b -text left_side +} -body { + .b configure -cursor left_side +} -cleanup { + destroy .b +} -result {} +test cursor-6.37 {check cursor-font cursor left_tee} -setup { + button .b -text left_tee +} -body { + .b configure -cursor left_tee +} -cleanup { + destroy .b +} -result {} +test cursor-6.38 {check cursor-font cursor leftbutton} -setup { + button .b -text leftbutton +} -body { + .b configure -cursor leftbutton +} -cleanup { + destroy .b +} -result {} +test cursor-6.39 {check cursor-font cursor ll_angle} -setup { + button .b -text ll_angle +} -body { + .b configure -cursor ll_angle +} -cleanup { + destroy .b +} -result {} +test cursor-6.40 {check cursor-font cursor lr_angle} -setup { + button .b -text lr_angle +} -body { + .b configure -cursor lr_angle +} -cleanup { + destroy .b +} -result {} +test cursor-6.41 {check cursor-font cursor man} -setup { + button .b -text man +} -body { + .b configure -cursor man +} -cleanup { + destroy .b +} -result {} +test cursor-6.42 {check cursor-font cursor middlebutton} -setup { + button .b -text middlebutton +} -body { + .b configure -cursor middlebutton +} -cleanup { + destroy .b +} -result {} +test cursor-6.43 {check cursor-font cursor mouse} -setup { + button .b -text mouse +} -body { + .b configure -cursor mouse +} -cleanup { + destroy .b +} -result {} +test cursor-6.44 {check cursor-font cursor pencil} -setup { + button .b -text pencil +} -body { + .b configure -cursor pencil +} -cleanup { + destroy .b +} -result {} +test cursor-6.45 {check cursor-font cursor pirate} -setup { + button .b -text pirate +} -body { + .b configure -cursor pirate +} -cleanup { + destroy .b +} -result {} +test cursor-6.46 {check cursor-font cursor plus} -setup { + button .b -text plus +} -body { + .b configure -cursor plus +} -cleanup { + destroy .b +} -result {} +test cursor-6.47 {check cursor-font cursor question_arrow} -setup { + button .b -text question_arrow +} -body { + .b configure -cursor question_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.48 {check cursor-font cursor right_ptr} -setup { + button .b -text right_ptr +} -body { + .b configure -cursor right_ptr +} -cleanup { + destroy .b +} -result {} +test cursor-6.49 {check cursor-font cursor right_side} -setup { + button .b -text right_side +} -body { + .b configure -cursor right_side +} -cleanup { + destroy .b +} -result {} +test cursor-6.50 {check cursor-font cursor right_tee} -setup { + button .b -text right_tee +} -body { + .b configure -cursor right_tee +} -cleanup { + destroy .b +} -result {} +test cursor-6.51 {check cursor-font cursor rightbutton} -setup { + button .b -text rightbutton +} -body { + .b configure -cursor rightbutton +} -cleanup { + destroy .b +} -result {} +test cursor-6.52 {check cursor-font cursor rtl_logo} -setup { + button .b -text rtl_logo +} -body { + .b configure -cursor rtl_logo +} -cleanup { + destroy .b +} -result {} +test cursor-6.53 {check cursor-font cursor sailboat} -setup { + button .b -text sailboat +} -body { + .b configure -cursor sailboat +} -cleanup { + destroy .b +} -result {} +test cursor-6.54 {check cursor-font cursor sb_down_arrow} -setup { + button .b -text sb_down_arrow +} -body { + .b configure -cursor sb_down_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.55 {check cursor-font cursor sb_h_double_arrow} -setup { + button .b -text sb_h_double_arrow +} -body { + .b configure -cursor sb_h_double_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.56 {check cursor-font cursor sb_left_arrow} -setup { + button .b -text sb_left_arrow +} -body { + .b configure -cursor sb_left_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.57 {check cursor-font cursor sb_right_arrow} -setup { + button .b -text sb_right_arrow +} -body { + .b configure -cursor sb_right_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.58 {check cursor-font cursor sb_up_arrow} -setup { + button .b -text sb_up_arrow +} -body { + .b configure -cursor sb_up_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.59 {check cursor-font cursor sb_v_double_arrow} -setup { + button .b -text sb_v_double_arrow +} -body { + .b configure -cursor sb_v_double_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.60 {check cursor-font cursor shuttle} -setup { + button .b -text shuttle +} -body { + .b configure -cursor shuttle +} -cleanup { + destroy .b +} -result {} +test cursor-6.61 {check cursor-font cursor sizing} -setup { + button .b -text sizing +} -body { + .b configure -cursor sizing +} -cleanup { + destroy .b +} -result {} +test cursor-6.62 {check cursor-font cursor spider} -setup { + button .b -text spider +} -body { + .b configure -cursor spider +} -cleanup { + destroy .b +} -result {} +test cursor-6.63 {check cursor-font cursor spraycan} -setup { + button .b -text spraycan +} -body { + .b configure -cursor spraycan +} -cleanup { + destroy .b +} -result {} +test cursor-6.64 {check cursor-font cursor star} -setup { + button .b -text star +} -body { + .b configure -cursor star +} -cleanup { + destroy .b +} -result {} +test cursor-6.65 {check cursor-font cursor target} -setup { + button .b -text target +} -body { + .b configure -cursor target +} -cleanup { + destroy .b +} -result {} +test cursor-6.66 {check cursor-font cursor tcross} -setup { + button .b -text tcross +} -body { + .b configure -cursor tcross +} -cleanup { + destroy .b +} -result {} +test cursor-6.67 {check cursor-font cursor top_left_arrow} -setup { + button .b -text top_left_arrow +} -body { + .b configure -cursor top_left_arrow +} -cleanup { + destroy .b +} -result {} +test cursor-6.68 {check cursor-font cursor top_left_corner} -setup { + button .b -text top_left_corner +} -body { + .b configure -cursor top_left_corner +} -cleanup { + destroy .b +} -result {} +test cursor-6.69 {check cursor-font cursor top_right_corner} -setup { + button .b -text top_right_corner +} -body { + .b configure -cursor top_right_corner +} -cleanup { + destroy .b +} -result {} +test cursor-6.70 {check cursor-font cursor top_side} -setup { + button .b -text top_side +} -body { + .b configure -cursor top_side +} -cleanup { + destroy .b +} -result {} +test cursor-6.71 {check cursor-font cursor top_tee} -setup { + button .b -text top_tee +} -body { + .b configure -cursor top_tee +} -cleanup { + destroy .b +} -result {} +test cursor-6.72 {check cursor-font cursor trek} -setup { + button .b -text trek +} -body { + .b configure -cursor trek +} -cleanup { + destroy .b +} -result {} +test cursor-6.73 {check cursor-font cursor ul_angle} -setup { + button .b -text ul_angle +} -body { + .b configure -cursor ul_angle +} -cleanup { + destroy .b +} -result {} +test cursor-6.74 {check cursor-font cursor umbrella} -setup { + button .b -text umbrella +} -body { + .b configure -cursor umbrella +} -cleanup { + destroy .b +} -result {} +test cursor-6.75 {check cursor-font cursor ur_angle} -setup { + button .b -text ur_angle +} -body { + .b configure -cursor ur_angle +} -cleanup { + destroy .b +} -result {} +test cursor-6.76 {check cursor-font cursor watch} -setup { + button .b -text watch +} -body { + .b configure -cursor watch +} -cleanup { + destroy .b +} -result {} +test cursor-6.77 {check cursor-font cursor xterm} -setup { + button .b -text xterm +} -body { + .b configure -cursor xterm +} -cleanup { + destroy .b +} -result {} # Test cursor named "none", it is not defined in # the X cursor table. It is defined in a Tk specific # table of named cursors and should be available on # all platforms. - -test cursor-6.80 {} -setup { +test cursor-6.78 {test cursor named "none"} -setup { button .b -text CButton } -body { .b configure -cursor none @@ -240,7 +729,7 @@ test cursor-6.80 {} -setup { destroy .b } -result none -test cursor-6.81 {} -setup { +test cursor-6.79 {test cursor named "none"} -setup { button .b -text CButton } -body { .b configure -cursor none @@ -250,7 +739,7 @@ test cursor-6.81 {} -setup { destroy .b } -result {} -test cursor-6.82 {} -setup { +test cursor-6.80 {test cursor named "none"} -setup { button .b -text CButton } -body { .b configure -cursor none @@ -261,7 +750,7 @@ test cursor-6.82 {} -setup { destroy .b } -result none -test cursor-6.83 {} -setup { +test cursor-6.81 {test cursor named "none"} -setup { button .b -text CButton } -body { # Setting fg and bg does nothing for the none cursor @@ -283,31 +772,72 @@ test cursor-6.83 {} -setup { # ------------------------------------------------------------------------- # Check the Windows specific cursors - -foreach {testName cursor} { - cursor-7.1 no - cursor-7.2 starting - cursor-7.3 size - cursor-7.4 size_ne_sw - cursor-7.5 size_ns - cursor-7.6 size_nw_se - cursor-7.7 size_we - cursor-7.8 uparrow - cursor-7.9 wait -} { - test $testName "check Windows cursor $cursor" -constraints win -setup { - button .b -text $cursor - } -body { - .b configure -cursor $cursor - } -cleanup { - destroy .b - } -result {} -} +test cursor-7.1 {check Windows cursor no} -constraints win -setup { + button .b -text no +} -body { + .b configure -cursor no +} -cleanup { + destroy .b +} -result {} +test cursor-7.2 {check Windows cursor starting} -constraints win -setup { + button .b -text starting +} -body { + .b configure -cursor starting +} -cleanup { + destroy .b +} -result {} +test cursor-7.3 {check Windows cursor size} -constraints win -setup { + button .b -text size +} -body { + .b configure -cursor size +} -cleanup { + destroy .b +} -result {} +test cursor-7.4 {check Windows cursor size_ne_sw} -constraints win -setup { + button .b -text size_ne_sw +} -body { + .b configure -cursor size_ne_sw +} -cleanup { + destroy .b +} -result {} +test cursor-7.5 {check Windows cursor size_ns} -constraints win -setup { + button .b -text size_ns +} -body { + .b configure -cursor size_ns +} -cleanup { + destroy .b +} -result {} +test cursor-7.6 {check Windows cursor size_nw_se} -constraints win -setup { + button .b -text size_nw_se +} -body { + .b configure -cursor size_nw_se +} -cleanup { + destroy .b +} -result {} +test cursor-7.7 {check Windows cursor size_we} -constraints win -setup { + button .b -text size_we +} -body { + .b configure -cursor size_we +} -cleanup { + destroy .b +} -result {} +test cursor-7.8 {check Windows cursor uparrow} -constraints win -setup { + button .b -text uparrow +} -body { + .b configure -cursor uparrow +} -cleanup { + destroy .b +} -result {} +test cursor-7.9 {check Windows cursor wait} -constraints win -setup { + button .b -text wait +} -body { + .b configure -cursor wait +} -cleanup { + destroy .b +} -result {} # ------------------------------------------------------------------------- -destroy .t - # cleanup cleanupTests return diff --git a/tests/dialog.test b/tests/dialog.test index f47296e..78b6620 100644 --- a/tests/dialog.test +++ b/tests/dialog.test @@ -1,58 +1,67 @@ # This file is a Tcl script to test out Tk's "tk_dialog" command. # It is organized in the standard fashion for Tcl tests. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test test dialog-1.1 {tk_dialog command} -body { - list [catch {tk_dialog} msg] $msg -} -match glob -result {1 {wrong # args: should be "tk_dialog w title text bitmap default *"}} -test dialog-1.2 {tk_dialog command} { - list [catch {tk_dialog foo foo foo foo foo} msg] $msg -} {1 {bad window path name "foo"}} -test dialog-1.3 {tk_dialog command} { - set res [list [catch {tk_dialog .d foo foo foo foo} msg] $msg] + tk_dialog +} -match glob -returnCodes error -result {wrong # args: should be "tk_dialog w title text bitmap default *"} +test dialog-1.2 {tk_dialog command} -body { + tk_dialog foo foo foo foo foo +} -returnCodes error -result {bad window path name "foo"} +test dialog-1.3 {tk_dialog command} -body { + tk_dialog .d foo foo fooBitmap foo +} -cleanup { destroy .d - set res -} {1 {bitmap "foo" not defined}} +} -returnCodes error -result {bitmap "fooBitmap" not defined} -proc PressButton {btn} { - if {![winfo ismapped $btn]} { - update - } - event generate $btn <Enter> - event generate $btn <1> -x 5 -y 5 - event generate $btn <ButtonRelease-1> -x 5 -y 5 -} - -proc HitReturn {w} { - event generate $w <Enter> - focus -force $w - event generate $w <KeyPress> -keysym Return -} -test dialog-2.0 {tk_dialog operation} { +test dialog-2.1 {tk_dialog operation} -setup { + proc PressButton {btn} { + if {![winfo ismapped $btn]} { + update + } + event generate $btn <Enter> + event generate $btn <1> -x 5 -y 5 + event generate $btn <ButtonRelease-1> -x 5 -y 5 + } +} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 PressButton .d.button0 set res [tk_dialog .d foo foo info 0 click] after cancel $x - set res -} {0} -test dialog-2.1 {tk_dialog operation} { + return $res +} -cleanup { + destroy .d +} -result {0} +test dialog-2.2 {tk_dialog operation} -setup { + proc HitReturn {w} { + event generate $w <Enter> + focus -force $w + event generate $w <KeyPress> -keysym Return + } +} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 HitReturn .d set res [tk_dialog .d foo foo info 1 click default] after cancel $x - set res -} {1} -test dialog-2.2 {tk_dialog operation} { + return $res +} -cleanup { + destroy .d +} -result {1} +test dialog-2.3 {tk_dialog operation} -body { set x [after 5000 [list set tk::Priv(button) "no response"]] after 100 destroy .d set res [tk_dialog .d foo foo info 0 click] after cancel $x - set res -} {-1} + return $res +} -cleanup { + destroy .b +} -result {-1} cleanupTests return + diff --git a/tests/embed.test b/tests/embed.test index bac2675..8a29862 100644 --- a/tests/embed.test +++ b/tests/embed.test @@ -4,67 +4,85 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -global tcl_platform -test embed-1.1 {TkpUseWindow procedure, bad window identifier} { +test embed-1.1 {TkpUseWindow procedure, bad window identifier} -setup { deleteWindows - list [catch {toplevel .t -use xyz} msg] $msg -} {1 {expected integer but got "xyz"}} +} -body { + toplevel .t -use xyz +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "xyz"} -test embed-1.2 {CreateFrame procedure, bad window identifier} { +test embed-1.2 {CreateFrame procedure, bad window identifier} -setup { + deleteWindows +} -body { + toplevel .t -container xyz +} -cleanup { deleteWindows - list [catch {toplevel .t -container xyz} msg] $msg -} {1 {expected boolean value but got "xyz"}} +} -returnCodes error -result {expected boolean value but got "xyz"} -test embed-1.3 {CreateFrame procedure, both -use and - -container is invalid } { +test embed-1.3 {CreateFrame procedure, both -use and -container is invalid} -setup { deleteWindows +} -body { toplevel .container -container 1 - list [catch {toplevel .t -use [winfo id .container] \ - -container 1} msg] $msg -} {1 {A window cannot have both the -use and the -container option set.}} - -if {$tcl_platform(platform) == "windows"} { - -# testing window embedding for Windows platform + toplevel .t -use [winfo id .container] -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {A window cannot have both the -use and the -container option set.} -test embed-1.4.win {TkpUseWindow procedure, -container must be set} { +# testing window embedding for win platforms +test embed-1.4.win {TkpUseWindow procedure, -container must be set} -constraints { + win +} -setup { deleteWindows +} -body { toplevel .container - list [catch {toplevel .embd -use [winfo id .container]} err] $err -} {1 {the window to use is not a Tk container}} - -test embed-1.5.win {TkpUseWindow procedure, -container must be set} { + toplevel .embd -use [winfo id .container] +} -cleanup { deleteWindows +} -returnCodes error -result {the window to use is not a Tk container} +# testing window embedding for win platforms +test embed-1.5.win {TkpUseWindow procedure, -container must be set} -constraints { + win +} -setup { + deleteWindows +} -body { frame .container - list [catch {toplevel .embd -use [winfo id .container]} err] $err -} {1 {the window to use is not a Tk container}} - -} else { - -# testing window embedding for other platforms + toplevel .embd -use [winfo id .container] +} -cleanup { + deleteWindows +} -returnCodes error -result {the window to use is not a Tk container} -test embed-1.4.nonwin {TkpUseWindow procedure, -container must be set} { +# testing window embedding for other than win platforms +test embed-1.4.nonwin {TkpUseWindow procedure, -container must be set} -constraints { + nonwin +} -setup { deleteWindows +} -body { toplevel .container - list [catch {toplevel .embd -use [winfo id .container]} err] $err -} {1 {window ".container" doesn't have -container option set}} - -test embed-1.5.nonwin {TkpUseWindow procedure, -container must be set} { + toplevel .embd -use [winfo id .container] +} -cleanup { + deleteWindows +} -returnCodes error -result {window ".container" doesn't have -container option set} +# testing window embedding for other than win platforms +test embed-1.5.nonwin {TkpUseWindow procedure, -container must be set} -constraints { + nonwin +} -setup { deleteWindows +} -body { frame .container - list [catch {toplevel .embd -use [winfo id .container]} err] $err -} {1 {window ".container" doesn't have -container option set}} - -} + toplevel .embd -use [winfo id .container] +} -cleanup { + deleteWindows +} -returnCodes error -result {window ".container" doesn't have -container option set} -# FIXME: test cases common to unixEmbed.test and macEmbed.test should -# be moved here. cleanupTests return + diff --git a/tests/entry.test b/tests/entry.test index ffdbf45..11408ac 100644 --- a/tests/entry.test +++ b/tests/entry.test @@ -6,221 +6,880 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# For xscrollcommand proc scroll args { - global scrollInfo - set scrollInfo $args + global scrollInfo + set scrollInfo $args +} +# For trace variable +proc override args { + global x + set x 12345 } -# Create additional widget that's used to hold the selection at times. - -entry .sel -.sel insert end "This is some sample text" - -# Font names - -set big -adobe-helvetica-medium-r-normal--24-240-75-75-p-*-iso8859-1 -set fixed -adobe-courier-medium-r-normal--12-120-75-75-m-*-iso8859-1 - -# Create entries in the option database to be sure that geometry options -# like border width have predictable values. - -option add *Entry.borderWidth 2 -option add *Entry.highlightThickness 2 -option add *Entry.font {Helvetica -12} - -entry .e -bd 2 -relief sunken -pack .e -update - -set i 1 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-disabledbackground green green non-existent - {unknown color name "non-existent"}} - {-disabledforeground blue blue non-existent - {unknown color name "non-existent"}} - {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {} - {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightbackground #123456 #123456 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} - {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} - {-highlightthickness -2 0 {} {}} - {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} - {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} - {-insertontime 100 100 3.2 {expected integer but got "3.2"}} - {-invalidcommand "any string" "any string" {} {}} - {-invcmd "any string" "any string" {} {}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-readonlybackground green green non-existent - {unknown color name "non-existent"}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} - {-show * * {} {}} - {-state n normal bogus - {bad state "bogus": must be disabled, normal, or readonly}} - {-takefocus "any string" "any string" {} {}} - {-textvariable i i {} {}} - {-width 402 402 3p {expected integer but got "3p"}} - {-xscrollcommand {Some command} {Some command} {} {}} -} { - lassign $test name goodValue goodResult badValue badResult - test entry-1.$i {configuration options} { - .e configure $name $goodValue - list [lindex [.e configure $name] 4] [.e cget $name] - } [list $goodResult $goodResult] - incr i - if {$badValue ne ""} { - test entry-1.$i {configuration options} -body { - .e configure $name $badValue - } -returnCodes error -result $badResult - } - .e configure $name [lindex [.e configure $name] 3] - incr i +# Procedures used in widget VALIDATION tests +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 1 +} +proc doval2 {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + set ::e mydata + return 1 +} +proc doval3 {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 0 } -test entry-2.1 {Tk_EntryCmd procedure} { - list [catch {entry} msg] $msg -} {1 {wrong # args: should be "entry pathName ?options?"}} -test entry-2.2 {Tk_EntryCmd procedure} { - list [catch {entry gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test entry-2.3 {Tk_EntryCmd procedure} { - catch {destroy .e} +set cy [font metrics {Courier -12} -linespace] + + +test entry-1.1 {configuration option: "background" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -background #ff0000 + .e cget -background +} -cleanup { + destroy .e +} -result {#ff0000} +test entry-1.2 {configuration option: "background" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -background non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.3 {configuration option: "bd" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -bd 4 + .e cget -bd +} -cleanup { + destroy .e +} -result {4} +test entry-1.4 {configuration option: "bd" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -bd badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test entry-1.5 {configuration option: "bg" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -bg #ff0000 + .e cget -bg +} -cleanup { + destroy .e +} -result {#ff0000} +test entry-1.6 {configuration option: "bg" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -bg non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.7 {configuration option: "borderwidth" for entry} -setup { + entry .e -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -borderwidth 1.3 + .e cget -borderwidth +} -cleanup { + destroy .e +} -result {1} +test entry-1.8 {configuration option: "borderwidth" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -borderwidth badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test entry-1.9 {configuration option: "cursor" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -cursor arrow + .e cget -cursor +} -cleanup { + destroy .e +} -result {arrow} +test entry-1.10 {configuration option: "cursor" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -cursor badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad cursor spec "badValue"} + +test entry-1.11 {configuration option: "disabledbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -disabledbackground green + .e cget -disabledbackground +} -cleanup { + destroy .e +} -result {green} +test entry-1.12 {configuration option: "disabledbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -disabledbackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.13 {configuration option: "disabledforeground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -disabledforeground blue + .e cget -disabledforeground +} -cleanup { + destroy .e +} -result {blue} +test entry-1.14 {configuration option: "disabledforeground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -disabledforeground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.15 {configuration option: "exportselection" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -exportselection yes + .e cget -exportselection +} -cleanup { + destroy .e +} -result {1} +test entry-1.16 {configuration option: "exportselection" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -exportselection xyzzy +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected boolean value but got "xyzzy"} + +test entry-1.17 {configuration option: "fg" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -fg #110022 + .e cget -fg +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.18 {configuration option: "fg" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -fg non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.19 {configuration option: "font" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e configure -font {Helvetica -12} + .e cget -font +} -cleanup { + destroy .e +} -result {Helvetica -12} +test entry-1.20 {configuration option: "font" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e configure -font {} +} -cleanup { + destroy .e +} -returnCodes {error} -result {font "" doesn't exist} + +test entry-1.21 {configuration option: "foreground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -foreground #110022 + .e cget -foreground +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.22 {configuration option: "foreground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -foreground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.23 {configuration option: "highlightbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightbackground #110022 + .e cget -highlightbackground +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.24 {configuration option: "highlightbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightbackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.25 {configuration option: "highlightcolor" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightcolor #110022 + .e cget -highlightcolor +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.26 {configuration option: "highlightcolor" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightcolor non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.27 {configuration option: "highlightthickness" for entry} -setup { + entry .e -borderwidth 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightthickness 6 + .e cget -highlightthickness +} -cleanup { + destroy .e +} -result {6} +test entry-1.28 {configuration option: "highlightthickness" for entry} -setup { + entry .e -borderwidth 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightthickness -2 + .e cget -highlightthickness +} -cleanup { + destroy .e +} -result {0} +test entry-1.29 {configuration option: "highlightthickness" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -highlightthickness badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test entry-1.30 {configuration option: "insertbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertbackground #110022 + .e cget -insertbackground +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.31 {configuration option: "insertbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertbackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.32 {configuration option: "insertborderwidth" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertborderwidth 1.3 + .e cget -insertborderwidth +} -cleanup { + destroy .e +} -result {1} +test entry-1.33 {configuration option: "insertborderwidth" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertborderwidth 2.6x +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "2.6x"} + +test entry-1.34 {configuration option: "insertofftime" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertofftime 100 + .e cget -insertofftime +} -cleanup { + destroy .e +} -result {100} +test entry-1.35 {configuration option: "insertofftime" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertofftime 3.2 +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3.2"} + +test entry-1.36 {configuration option: "insertontime" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertontime 100 + .e cget -insertontime +} -cleanup { + destroy .e +} -result {100} +test entry-1.37 {configuration option: "insertontime" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -insertontime 3.2 +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3.2"} + +test entry-1.38 {configuration option: "invalidcommand" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -invalidcommand "any string" + .e cget -invalidcommand +} -cleanup { + destroy .e +} -result {any string} + +test entry-1.39 {configuration option: "invcmd" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -invcmd "any string" + .e cget -invcmd +} -cleanup { + destroy .e +} -result {any string} + +test entry-1.40 {configuration option: "justify" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -justify right + .e cget -justify +} -cleanup { + destroy .e +} -result {right} +test entry-1.41 {configuration option: "justify" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -justify bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} + +test entry-1.42 {configuration option: "readonlybackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -readonlybackground green + .e cget -readonlybackground +} -cleanup { + destroy .e +} -result {green} +test entry-1.43 {configuration option: "readonlybackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -readonlybackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.44 {configuration option: "relief" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -relief flat + .e cget -relief +} -cleanup { + destroy .e +} -result {flat} + +test entry-1.45 {configuration option: "selectbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -selectbackground #110022 + .e cget -selectbackground +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.46 {configuration option: "selectbackground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -selectbackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.47 {configuration option: "selectborderwidth" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -selectborderwidth 1.3 + .e cget -selectborderwidth +} -cleanup { + destroy .e +} -result {1} +test entry-1.48 {configuration option: "selectborderwidth" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -selectborderwidth badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test entry-1.49 {configuration option: "selectforeground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -selectforeground #110022 + .e cget -selectforeground +} -cleanup { + destroy .e +} -result {#110022} +test entry-1.50 {configuration option: "selectforeground" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -selectforeground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test entry-1.51 {configuration option: "show" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -show * + .e cget -show +} -cleanup { + destroy .e +} -result {*} + +test entry-1.52 {configuration option: "state" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -state n + .e cget -state +} -cleanup { + destroy .e +} -result {normal} +test entry-1.53 {configuration option: "state" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -state bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad state "bogus": must be disabled, normal, or readonly} + +test entry-1.54 {configuration option: "takefocus" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -takefocus "any string" + .e cget -takefocus +} -cleanup { + destroy .e +} -result {any string} + +test entry-1.55 {configuration option: "textvariable" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -textvariable i + .e cget -textvariable +} -cleanup { + destroy .e +} -result {i} + +test entry-1.56 {configuration option: "width" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -width 402 + .e cget -width +} -cleanup { + destroy .e +} -result {402} +test entry-1.57 {configuration option: "width" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -width 3p +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3p"} + +test entry-1.58 {configuration option: "xscrollcommand" for entry} -setup { + entry .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .e + update +} -body { + .e configure -xscrollcommand {Some command} + .e cget -xscrollcommand +} -cleanup { + destroy .e +} -result {Some command} + + + +test entry-2.1 {Tk_EntryCmd procedure} -body { + entry +} -returnCodes error -result {wrong # args: should be "entry pathName ?-option value ...?"} +test entry-2.2 {Tk_EntryCmd procedure} -body { + entry gorp +} -returnCodes error -result {bad window path name "gorp"} +test entry-2.3 {Tk_EntryCmd procedure} -body { entry .e + pack .e + update list [winfo exists .e] [winfo class .e] [info commands .e] -} {1 Entry .e} -test entry-2.4 {Tk_EntryCmd procedure} { - catch {destroy .e} - list [catch {entry .e -gorp foo} msg] $msg [winfo exists .e] \ - [info commands .e] -} {1 {unknown option "-gorp"} 0 {}} -test entry-2.5 {Tk_EntryCmd procedure} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {1 Entry .e} +test entry-2.4 {Tk_EntryCmd procedure} -body { + entry .e -gorp foo +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "-gorp"} +test entry-2.4.1 {Tk_EntryCmd procedure} -body { + catch {entry .e -gorp foo} + list [winfo exists .e] [info commands .e] +} -cleanup { + destroy .e +} -result {0 {}} +test entry-2.5 {Tk_EntryCmd procedure} -body { entry .e -} {.e} - -catch {destroy .e} -entry .e -font $fixed -pack .e -update - -set cx [font measure $fixed a] -set cy [font metrics $fixed -linespace] -set ux [font measure $fixed \u4e4e] - -test entry-3.1 {EntryWidgetCmd procedure} { - list [catch {.e} msg] $msg -} {1 {wrong # args: should be ".e option ?arg arg ...?"}} -test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} { - list [catch {.e bbox} msg] $msg -} {1 {wrong # args: should be ".e bbox index"}} -test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} { - list [catch {.e bbox a b} msg] $msg -} {1 {wrong # args: should be ".e bbox index"}} -test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} { - list [catch {.e bbox bogus} msg] $msg -} {1 {bad entry index "bogus"}} -test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} { - .e delete 0 end - .e bbox 0 -} [list 5 5 0 $cy] -test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): no utf chars +} -cleanup { + destroy .e +} -result {.e} - .e delete 0 end + +test entry-3.1 {EntryWidgetCmd procedure} -setup { + entry .e + pack .e + update +} -body { + .e +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"} +test entry-3.2 {EntryWidgetCmd procedure, "bbox" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e bbox +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e bbox index"} +test entry-3.3 {EntryWidgetCmd procedure, "bbox" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e bbox a b +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e bbox index"} +test entry-3.4 {EntryWidgetCmd procedure, "bbox" widget command} -setup { + entry .e + pack .e + update +} -body { + .e bbox bogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "bogus"} +test entry-3.5 {EntryWidgetCmd procedure, "bbox" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e bbox 0 +} -cleanup { + destroy .e +} -result [list 5 5 0 $cy] + +# Previously the result was count using previousli counted font measurements +# and metrics. It was changed to less verbose solution - the result is the one +# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10) +test entry-3.6 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): no utf chars .e insert 0 "abc" list [.e bbox 3] [.e bbox end] -} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"] -test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): utf at end - .e delete 0 end +} -cleanup { + destroy .e +} -result {{19 5 7 13} {19 5 7 13}} +test entry-3.7 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): utf at end .e insert 0 "ab\u4e4e" .e bbox end -} "[expr 5+2*$cx] 5 $ux $cy" -test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): utf before index - .e delete 0 end +} -cleanup { + destroy .e +} -result {19 5 12 13} +test entry-3.8 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): utf before index .e insert 0 "ab\u4e4ec" .e bbox 3 -} "[expr 5+2*$cx+$ux] 5 $cx $cy" -test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): no chars - .e delete 0 end +} -cleanup { + destroy .e +} -result {31 5 7 13} +test entry-3.9 {EntryWidgetCmd procedure, "bbox" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): no chars .e bbox end -} "5 5 0 $cy" -test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result "5 5 0 $cy" +test entry-3.10 {EntryWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { .e insert 0 "abcdefghij\u4e4eklmnop" list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end] -} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"] -test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} { - list [catch {.e cget} msg] $msg -} {1 {wrong # args: should be ".e cget option"}} -test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} { - list [catch {.e cget a b} msg] $msg -} {1 {wrong # args: should be ".e cget option"}} -test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} { - list [catch {.e cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} { +} -cleanup { + destroy .e +} -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}} +test entry-3.11 {EntryWidgetCmd procedure, "cget" widget command} -setup { + entry .e +} -body { + .e cget +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e cget option"} +test entry-3.12 {EntryWidgetCmd procedure, "cget" widget command} -setup { + entry .e +} -body { + .e cget a b +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e cget option"} +test entry-3.13 {EntryWidgetCmd procedure, "cget" widget command} -setup { + entry .e +} -body { + .e cget -gorp +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "-gorp"} +test entry-3.14 {EntryWidgetCmd procedure, "cget" widget command} -setup { + entry .e +} -body { .e configure -bd 4 .e cget -bd -} {4} -test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} { +} -cleanup { + destroy .e +} -result {4} +test entry-3.15 {EntryWidgetCmd procedure, "configure" widget command} -setup { + entry .e + pack .e + update +} -body { llength [.e configure] -} {36} -test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} { - list [catch {.e configure -foo} msg] $msg -} {1 {unknown option "-foo"}} -test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} { +} -cleanup { + destroy .e +} -result {36} +test entry-3.16 {EntryWidgetCmd procedure, "configure" widget command} -setup { + entry .e +} -body { + .e configure -foo +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "-foo"} +test entry-3.17 {EntryWidgetCmd procedure, "configure" widget command} -setup { + entry .e +} -body { .e configure -bd 4 .e configure -bg #ffffff lindex [.e configure -bd] 4 -} {4} -test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete} msg] $msg -} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete a b c} msg] $msg -} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete foo} msg] $msg -} {1 {bad entry index "foo"}} -test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete 0 bar} msg] $msg -} {1 {bad entry index "bar"}} -test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test entry-3.18 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e +} -body { + .e delete +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} +test entry-3.19 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e +} -body { + .e delete a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} +test entry-3.20 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e +} -body { + .e delete foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "foo"} +test entry-3.21 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e +} -body { + .e delete 0 bar +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "bar"} +test entry-3.22 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e delete 2 4 .e get -} {014567890} -test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {014567890} +test entry-3.23 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e +} -body { .e insert end "01234567890" .e delete 6 .e get -} {0123457890} -test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} { - # UTF +} -cleanup { + destroy .e +} -result {0123457890} +test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e + pack .e + update set x {} - .e delete 0 end +} -body { +# UTF .e insert end "01234\u4e4e67890" .e delete 6 lappend x [.e get] @@ -232,311 +891,659 @@ test entry-3.24 {EntryWidgetCmd procedure, "delete" widget command} { .e insert end "0123456\u4e4e890" .e delete 6 lappend x [.e get] -} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] -test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] +test entry-3.25 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e delete 6 5 .e get -} {01234567890} -test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {01234567890} +test entry-3.26 {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e configure -state disabled .e delete 2 8 .e configure -state normal .e get -} {01234567890} -test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {01234567890} +test entry-3.26a {EntryWidgetCmd procedure, "delete" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e configure -state readonly .e delete 2 8 .e configure -state normal .e get -} {01234567890} -test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} { - list [catch {.e get foo} msg] $msg -} {1 {wrong # args: should be ".e get"}} -test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} { - list [catch {.e icursor} msg] $msg -} {1 {wrong # args: should be ".e icursor pos"}} -test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} { - list [catch {.e icursor foo} msg] $msg -} {1 {bad entry index "foo"}} -test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {01234567890} +test entry-3.27 {EntryWidgetCmd procedure, "get" widget command} -setup { + entry .e +} -body { + .e get foo +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e get"} +test entry-3.28 {EntryWidgetCmd procedure, "icursor" widget command} -setup { + entry .e +} -body { + .e icursor +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e icursor pos"} +test entry-3.29 {EntryWidgetCmd procedure, "icursor" widget command} -setup { + entry .e +} -body { + .e icursor foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "foo"} +test entry-3.30 {EntryWidgetCmd procedure, "icursor" widget command} -setup { + entry .e +} -body { .e insert end "01234567890" .e icursor 4 .e index insert -} {4} -test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} { - list [catch {.e in} msg] $msg -} {1 {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}} -test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} { - list [catch {.e index} msg] $msg -} {1 {wrong # args: should be ".e index string"}} -test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} { - list [catch {.e index foo} msg] $msg -} {1 {bad entry index "foo"}} -test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} { - list [catch {.e index 0} msg] $msg -} {0 0} -test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} { - # UTF - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test entry-3.31 {EntryWidgetCmd procedure, "index" widget command} -setup { + entry .e +} -body { + .e in +} -cleanup { + destroy .e +} -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview} +test entry-3.32 {EntryWidgetCmd procedure, "index" widget command} -setup { + entry .e +} -body { + .e index +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e index string"} +test entry-3.33 {EntryWidgetCmd procedure, "index" widget command} -setup { + entry .e +} -body { + .e index foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "foo"} +test entry-3.34 {EntryWidgetCmd procedure, "index" widget command} -setup { + entry .e + pack .e + update +} -body { + .e index 0 +} -cleanup { + destroy .e +} -returnCodes {ok} -match glob -result {*} +test entry-3.35 {EntryWidgetCmd procedure, "index" widget command} -setup { + entry .e + pack .e + update +} -body { +# UTF .e insert 0 abc\u4e4e\u0153def list [.e index 3] [.e index 4] [.e index end] -} {3 4 8} -test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert a} msg] $msg -} {1 {wrong # args: should be ".e insert index text"}} -test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert a b c} msg] $msg -} {1 {wrong # args: should be ".e insert index text"}} -test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert foo Text} msg] $msg -} {1 {bad entry index "foo"}} -test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 4 8} +test entry-3.36 {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e +} -body { + .e insert a +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e insert index text"} +test entry-3.37 {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e +} -body { + .e insert a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e insert index text"} +test entry-3.38 {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e +} -body { + .e insert foo Text +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "foo"} +test entry-3.39 {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e insert 3 xxx .e get -} {012xxx34567890} -test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {012xxx34567890} +test entry-3.40 {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e configure -state disabled .e insert 3 xxx .e configure -state normal .e get -} {01234567890} -test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {01234567890} +test entry-3.40a {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "01234567890" .e configure -state readonly .e insert 3 xxx .e configure -state normal .e get -} {01234567890} -test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert a b c} msg] $msg -} {1 {wrong # args: should be ".e insert index text"}} -test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan a} msg] $msg -} {1 {wrong # args: should be ".e scan mark|dragto x"}} -test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan a b c} msg] $msg -} {1 {wrong # args: should be ".e scan mark|dragto x"}} -test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan foobar 20} msg] $msg -} {1 {bad scan option "foobar": must be mark or dragto}} -test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan mark 20.1} msg] $msg -} {1 {expected integer but got "20.1"}} -# This test is non-portable because character sizes vary. +} -cleanup { + destroy .e +} -result {01234567890} +test entry-3.41 {EntryWidgetCmd procedure, "insert" widget command} -setup { + entry .e +} -body { + .e insert a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e insert index text"} +test entry-3.42 {EntryWidgetCmd procedure, "scan" widget command} -setup { + entry .e + pack .e + update +} -body { + .e scan a +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"} +test entry-3.43 {EntryWidgetCmd procedure, "scan" widget command} -setup { + entry .e + pack .e + update +} -body { + .e scan a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"} +test entry-3.44 {EntryWidgetCmd procedure, "scan" widget command} -setup { + entry .e + pack .e + update +} -body { + .e scan foobar 20 +} -cleanup { + destroy .e +} -returnCodes error -result {bad scan option "foobar": must be mark or dragto} +test entry-3.45 {EntryWidgetCmd procedure, "scan" widget command} -setup { + entry .e + pack .e + update +} -body { + .e scan mark 20.1 +} -cleanup { + destroy .e +} -returnCodes error -result {expected integer but got "20.1"} -test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} {fonts} { - .e delete 0 end +# This test is non-portable because character sizes vary. +test entry-3.46 {EntryWidgetCmd procedure, "scan" widget command} -constraints { + fonts +} -setup { + entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 + pack .e update +} -body { .e insert end "This is quite a long string, in fact a " .e insert end "very very long string" .e scan mark 30 .e scan dragto 28 .e index @0 -} {2} -test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} { - list [catch {.e select} msg] $msg -} {1 {wrong # args: should be ".e selection option ?index?"}} -test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} { - list [catch {.e select foo} msg] $msg -} {1 {bad selection option "foo": must be adjust, clear, from, present, range, or to}} -test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} { - list [catch {.e select clear gorp} msg] $msg -} {1 {wrong # args: should be ".e selection clear"}} -test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2} +test entry-3.47 {EntryWidgetCmd procedure, "select" widget command} -setup { + entry .e +} -body { + .e select +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection option ?index?"} +test entry-3.48 {EntryWidgetCmd procedure, "select" widget command} -setup { + entry .e +} -body { + .e select foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad selection option "foo": must be adjust, clear, from, present, range, or to} + +test entry-3.49 {EntryWidgetCmd procedure, "select clear" widget command} -setup { + entry .e +} -body { + .e select clear gorp +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection clear"} +test entry-3.50 {EntryWidgetCmd procedure, "select clear" widget command} -setup { + entry .e +} -body { .e insert end "0123456789" .e select from 1 .e select to 4 update .e select clear - list [catch {selection get} msg] $msg [selection own] -} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e} -test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} { - list [catch {.e selection present foo} msg] $msg -} {1 {wrong # args: should be ".e selection present"}} -test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} { - .e delete 0 end + selection get +} -cleanup { + destroy .e +} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test entry-3.50.1 {EntryWidgetCmd procedure, "select clear" widget command} -setup { + entry .e + pack .e + update +} -body { + .e insert end "0123456789" + .e select from 1 + .e select to 4 + update + .e select clear + catch {selection get} + selection own +} -cleanup { + destroy .e +} -result {.e} + +test entry-3.51 {EntryWidgetCmd procedure, "selection present" widget command} -setup { + entry .e +} -body { + .e selection present foo +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection present"} +test entry-3.52 {EntryWidgetCmd procedure, "selection present" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 6 .e selection present -} {1} -test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test entry-3.53 {EntryWidgetCmd procedure, "selection present" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 6 .e configure -exportselection false .e selection present -} {1} -.e configure -exportselection true -test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test entry-3.54 {EntryWidgetCmd procedure, "selection present" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 6 .e delete 0 end .e selection present -} {0} -test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} { - list [catch {.e select adjust x} msg] $msg -} {1 {bad entry index "x"}} -test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} { - list [catch {.e select adjust 2 3} msg] $msg -} {1 {wrong # args: should be ".e selection adjust index"}} -test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0} +test entry-3.55 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup { + entry .e +} -body { + .e select adjust x +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "x"} +test entry-3.56 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup { + entry .e +} -body { + .e select adjust 2 3 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection adjust index"} +test entry-3.57 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "0123456789" .e select from 1 .e select to 5 update .e select adjust 4 selection get -} {123} -test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {123} +test entry-3.58 {EntryWidgetCmd procedure, "selection adjust" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end "0123456789" .e select from 1 .e select to 5 update .e select adjust 2 selection get -} {234} -test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} { - list [catch {.e select from 2 3} msg] $msg -} {1 {wrong # args: should be ".e selection from index"}} -test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} { - list [catch {.e select range 2} msg] $msg -} {1 {wrong # args: should be ".e selection range start end"}} -test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} { - list [catch {.e selection range 2 3 4} msg] $msg -} {1 {wrong # args: should be ".e selection range start end"}} -test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {234} +test entry-3.59 {EntryWidgetCmd procedure, "selection from" widget command} -setup { + entry .e +} -body { + .e select from 2 3 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection from index"} + +test entry-3.60 {EntryWidgetCmd procedure, "selection range" widget command} -setup { + entry .e +} -body { + .e select range 2 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection range start end"} +test entry-3.61 {EntryWidgetCmd procedure, "selection range" widget command} -setup { + entry .e +} -body { + .e selection range 2 3 4 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection range start end"} +test entry-3.62 {EntryWidgetCmd procedure, "selection range" widget command} -setup { + entry .e +} -body { .e insert end 0123456789 .e select from 1 .e select to 5 .e select range 4 4 - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} { - .e delete 0 end + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test entry-3.63 {EntryWidgetCmd procedure, "selection range" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 7 .e select range 2 9 list [.e index sel.first] [.e index sel.last] [.e index anchor] -} {2 9 3} -test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 9 3} +test entry-3.64 {EntryWidgetCmd procedure, "selection" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end 0123456789 .e selection range 0 end .e configure -state disabled .e selection range 2 4 .e configure -state normal list [.e index sel.first] [.e index sel.last] -} {0 10} -test entry-3.64a {EntryWidgetCmd procedure, "selection" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0 10} +test entry-3.64a {EntryWidgetCmd procedure, "selection" widget command} -setup { + entry .e + pack .e + update +} -body { .e insert end 0123456789 .e selection range 0 end .e configure -state readonly .e selection range 2 4 .e configure -state normal list [.e index sel.first] [.e index sel.last] -} {2 4} -.e delete 0 end -.e insert end "This is quite a long text string, so long that it " -.e insert end "runs off the end of the window quite a bit." -test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} { - list [catch {.e select to 2 3} msg] $msg -} {1 {wrong # args: should be ".e selection to index"}} -test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {2 4} +test entry-3.64b {EntryWidgetCmd procedure, "selection to" widget command} -setup { + entry .e + pack .e + update + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." +} -body { + .e select to 2 3 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection to index"} + +test entry-3.65 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview 5 format {%.7f %.7f} {*}[.e xview] -} {0.0537634 0.2688172} -test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview gorp} msg] $msg -} {1 {bad entry index "gorp"}} -test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.0537634 0.2688172} +test entry-3.66 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e xview gorp +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "gorp"} +test entry-3.67 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview 0 .e icursor 10 .e xview insert format {%.6f %.6f} {*}[.e xview] -} {0.107527 0.322581} -test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview moveto foo bar} msg] $msg -} {1 {wrong # args: should be ".e xview moveto fraction"}} -test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview moveto foo} msg] $msg -} {1 {expected floating-point number but got "foo"}} -test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.107527 0.322581} +test entry-3.68 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e xview moveto foo bar +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"} +test entry-3.69 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e xview moveto foo +} -cleanup { + destroy .e +} -returnCodes error -result {expected floating-point number but got "foo"} +test entry-3.70 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview moveto 0.5 format {%.6f %.6f} {*}[.e xview] -} {0.505376 0.720430} -test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview scroll 24} msg] $msg -} {1 {wrong # args: should be ".e xview scroll number units|pages"}} -test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview scroll gorp units} msg] $msg -} {1 {expected integer but got "gorp"}} -test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.505376 0.720430} +test entry-3.71 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + .e xview scroll 24 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"} +test entry-3.72 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update + .e xview scroll gorp units +} -cleanup { + destroy .e +} -returnCodes error -result {expected integer but got "gorp"} +test entry-3.73 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview moveto 0 .e xview scroll 1 pages format {%.6f %.6f} {*}[.e xview] -} {0.193548 0.408602} -test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.193548 0.408602} +test entry-3.74 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview moveto .9 update .e xview scroll -2 p format {%.6f %.6f} {*}[.e xview] -} {0.397849 0.612903} -test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.397849 0.612903} +test entry-3.75 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview 30 update .e xview scroll 2 units .e index @0 -} {32} -test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {32} +test entry-3.76 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview 30 update .e xview scroll -1 units .e index @0 -} {29} -test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview scroll 23 foobars} msg] $msg -} {1 {bad argument "foobars": must be units or pages}} -test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview eat 23 hamburgers} msg] $msg -} {1 {unknown option "eat": must be moveto or scroll}} -test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {29} +test entry-3.77 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update + .e xview scroll 23 foobars +} -cleanup { + destroy .e +} -returnCodes error -result {bad argument "foobars": must be units or pages} +test entry-3.78 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update + .e xview eat 23 hamburgers +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "eat": must be moveto or scroll} +test entry-3.79 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview 0 update .e xview -4 .e index @0 -} {0} -test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0} +test entry-3.80 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview 300 .e index @0 -} {73} -.e insert 10 \u4e4e -test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} { - # UTF - # If Tcl_NumUtfChars wasn't used, wrong answer would be: - # 0.106383 0.117021 0.117021 - +} -cleanup { + destroy .e +} -result {73} +test entry-3.86 {EntryWidgetCmd procedure, "xview" widget command} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + .e insert 10 \u4e4e + update +# UTF +# If Tcl_NumUtfChars wasn't used, wrong answer would be: +# 0.106383 0.117021 0.117021 set x {} .e xview moveto .1 lappend x [format {%.6f} [lindex [.e xview] 0]] @@ -544,261 +1551,382 @@ test entry-3.81 {EntryWidgetCmd procedure, "xview" widget command} { lappend x [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .12 lappend x [format {%.6f} [lindex [.e xview] 0]] -} {0.095745 0.106383 0.117021} -test entry-3.82 {EntryWidgetCmd procedure} { - list [catch {.e gorp} msg] $msg -} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview}} +} -cleanup { + destroy .e +} -result {0.095745 0.106383 0.117021} + +test entry-3.82 {EntryWidgetCmd procedure} -setup { + entry .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e gorp +} -cleanup { + destroy .e +} -returnCodes error -result {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, index, insert, scan, selection, validate, or xview} # The test below doesn't actually check anything directly, but if run # with Purify or some other memory-allocation-checking program it will # ensure that resources get properly freed. -test entry-4.1 {DestroyEntry procedure} { - catch {destroy .e} +test entry-4.1 {DestroyEntry procedure} -body { entry .e -textvariable x -show * pack .e .e insert end "Sample text" update destroy .e -} {} +} -result {} -frame .f -width 200 -height 50 -relief raised -bd 2 -pack .f -side right -test entry-5.1 {ConfigureEntry procedure, -textvariable} { - catch {destroy .e} +test entry-5.1 {ConfigureEntry procedure, -textvariable} -body { set x 12345 entry .e -textvariable x .e get -} {12345} -test entry-5.2 {ConfigureEntry procedure, -textvariable} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {12345} +test entry-5.2 {ConfigureEntry procedure, -textvariable} -body { set x 12345 entry .e -textvariable x set y abcde .e configure -textvariable y set x 54321 .e get -} {abcde} -test entry-5.3 {ConfigureEntry procedure, -textvariable} { - catch {destroy .e} - catch {unset x} +} -cleanup { + destroy .e +} -result {abcde} +test entry-5.3 {ConfigureEntry procedure, -textvariable} -setup { + unset -nocomplain x entry .e +} -body { .e insert 0 "Some text" .e configure -textvariable x - set x -} {Some text} -test entry-5.4 {ConfigureEntry procedure, -textvariable} { - proc override args { - global x - set x 12345 - } - catch {destroy .e} - catch {unset x} - trace variable x w override + return $x +} -cleanup { + destroy .e +} -result {Some text} +test entry-5.4 {ConfigureEntry procedure, -textvariable} -setup { + unset -nocomplain x entry .e +} -body { + trace variable x w override .e insert 0 "Some text" .e configure -textvariable x - set result [list $x [.e get]] - unset x; rename override {} - set result -} {12345 12345} -test entry-5.5 {ConfigureEntry procedure} { - catch {destroy .e} - entry .e -exportselection false - pack .e - .e insert end "0123456789" - .sel select from 0 - .sel select to 10 + list $x [.e get] +} -cleanup { + destroy .e + trace vdelete x w override + unset x; +} -result {12345 12345} + +test entry-5.5 {ConfigureEntry procedure} -setup { set x {} + entry .e1 + entry .e2 +} -body { + .e2 insert end "This is some sample text" + .e1 configure -exportselection false + .e1 insert end "0123456789" + pack .e1 .e2 + .e2 select from 0 + .e2 select to 10 lappend x [selection get] - .e select from 1 - .e select to 5 + .e1 select from 1 + .e1 select to 5 lappend x [selection get] - .e configure -exportselection 1 + .e1 configure -exportselection 1 lappend x [selection get] - set x -} {{This is so} {This is so} 1234} -test entry-5.6 {ConfigureEntry procedure} { - catch {destroy .e} + return $x +} -cleanup { + destroy .e1 .e2 +} -result {{This is so} {This is so} 1234} +test entry-5.6 {ConfigureEntry procedure} -setup { + entry .e + pack .e +} -body { + .e insert end "0123456789" + .e select from 1 + .e select to 5 + .e configure -exportselection 0 + selection get +} -cleanup { + destroy .e +} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test entry-5.6.1 {ConfigureEntry procedure} -setup { entry .e pack .e +} -body { .e insert end "0123456789" .e select from 1 .e select to 5 .e configure -exportselection 0 - list [catch {selection get} msg] $msg [.e index sel.first] \ - [.e index sel.last] -} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 5} -test entry-5.7 {ConfigureEntry procedure} { - catch {destroy .e} - entry .e -font $fixed -width 4 -xscrollcommand scroll + catch {selection get} + list [.e index sel.first] [.e index sel.last] +} -cleanup { + destroy .e +} -result {1 5} + +test entry-5.7 {ConfigureEntry procedure} -setup { + entry .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -width 4 -xscrollcommand scroll .e insert end "01234567890" update .e configure -width 5 format {%.6f %.6f} {*}$scrollInfo -} {0.000000 0.363636} -test entry-5.8 {ConfigureEntry procedure} {fonts} { - catch {destroy .e} - entry .e -width 0 +} -cleanup { + destroy .e +} -result {0.000000 0.363636} + + +test entry-5.8 {ConfigureEntry procedure} -constraints { + fonts +} -setup { + entry .e -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -width 0 -font {Helvetica -12} .e insert end "0123" update - .e configure -font $big + .e configure -font {Helvetica -24} update winfo geom .e -} {62x37+0+0} -test entry-5.9 {ConfigureEntry procedure} {fonts} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised +} -cleanup { + destroy .e +} -result {62x37+0+0} +test entry-5.9 {ConfigureEntry procedure} -constraints { + fonts +} -setup { + entry .e -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised .e insert end "0123" update list [.e index @10] [.e index @11] [.e index @12] [.e index @13] -} {0 0 1 1} -test entry-5.10 {ConfigureEntry procedure} {fonts} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief flat +} -cleanup { + destroy .e +} -result {0 0 1 1} +test entry-5.10 {ConfigureEntry procedure} -constraints { + fonts +} -setup { + entry .e -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief flat .e insert end "0123" update list [.e index @10] [.e index @11] [.e index @12] [.e index @13] -} {0 0 1 1} -test entry-5.11 {ConfigureEntry procedure} { - # If "0" in selected font had 0 width, caused divide-by-zero error. - - catch {destroy .e} - pack [entry .e -font {{open look glyph}}] +} -cleanup { + destroy .e +} -result {0 0 1 1} +test entry-5.11 {ConfigureEntry procedure} -setup { + entry .e -borderwidth 2 -highlightthickness 2 + pack .e +} -body { +# If "0" in selected font had 0 width, caused divide-by-zero error. + .e configure -font {{open look glyph}} .e scan dragto 30 update -} {} +} -cleanup { + destroy .e +} -result {} # No tests for DisplayEntry. -test entry-6.1 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised -width 20 -highlightthickness 3 +test entry-6.1 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \ + -highlightthickness 3 .e insert end 012\t45 update list [.e index @61] [.e index @62] -} {3 4} -test entry-6.2 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised -width 20 -justify center \ - -highlightthickness 3 +} -cleanup { + destroy .e +} -result {3 4} +test entry-6.2 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \ + -justify center -highlightthickness 3 .e insert end 012\t45 update list [.e index @96] [.e index @97] -} {3 4} -test entry-6.3 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised -width 20 -justify right \ - -highlightthickness 3 +} -cleanup { + destroy .e +} -result {3 4} +test entry-6.3 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 20 \ + -justify right -highlightthickness 3 .e insert end 012\t45 update list [.e index @131] [.e index @132] -} {3 4} -test entry-6.4 {EntryComputeGeometry procedure} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised -width 5 +} -cleanup { + destroy .e +} -result {3 4} +test entry-6.4 {EntryComputeGeometry procedure} -setup { + entry .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 5 .e insert end "01234567890" update .e xview 6 .e index @0 -} {6} -test entry-6.5 {EntryComputeGeometry procedure} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised -width 5 +} -cleanup { + destroy .e +} -result {6} +test entry-6.5 {EntryComputeGeometry procedure} -setup { + entry .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 5 .e insert end "01234567890" update .e xview 7 .e index @0 -} {6} -test entry-6.6 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $fixed -bd 2 -relief raised -width 10 +} -cleanup { + destroy .e +} -result {6} +test entry-6.6 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 10 .e insert end "01234\t67890" update .e xview 3 list [.e index @39] [.e index @40] -} {5 6} -test entry-6.7 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $big -bd 3 -relief raised -width 5 +} -cleanup { + destroy .e +} -result {5 6} +test entry-6.7 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 5 .e insert end "01234567" update list [winfo reqwidth .e] [winfo reqheight .e] -} {77 39} -test entry-6.8 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $big -bd 3 -relief raised -width 0 +} -cleanup { + destroy .e +} -result {77 39} +test entry-6.8 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 .e insert end "01234567" update list [winfo reqwidth .e] [winfo reqheight .e] -} {116 39} -test entry-6.9 {EntryComputeGeometry procedure} {fonts} { - catch {destroy .e} - entry .e -font $big -bd 3 -relief raised -width 0 -highlightthickness 2 +} -cleanup { + destroy .e +} -result {116 39} +test entry-6.9 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { + entry .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 update list [winfo reqwidth .e] [winfo reqheight .e] -} {25 39} -test entry-6.10 {EntryComputeGeometry procedure} {unix fonts} { - catch {destroy .e} - entry .e -bd 1 -relief raised -width 0 -show . - .e insert 0 12345 +} -cleanup { + destroy .e +} -result {25 39} +test entry-6.10 {EntryComputeGeometry procedure} -constraints { + unix fonts +} -setup { + entry .e -highlightthickness 2 -font {Helvetica -12} pack .e +} -body { + .e configure -bd 1 -relief raised -width 0 -show . + .e insert 0 12345 update set x [winfo reqwidth .e] .e configure -show X lappend x [winfo reqwidth .e] .e configure -show "" lappend x [winfo reqwidth .e] -} {23 53 43} -test entry-6.11 {EntryComputeGeometry procedure} win { - catch {destroy .e} - entry .e -bd 1 -relief raised -width 0 -show . -font {helvetica 12} - .e insert 0 12345 +} -cleanup { + destroy .e +} -result {23 53 43} +test entry-6.11 {EntryComputeGeometry procedure} -constraints { + win +} -setup { + entry .e -highlightthickness 2 pack .e +} -body { + .e configure -bd 1 -relief raised -width 0 -show . -font {helvetica 12} + .e insert 0 12345 update - set x [winfo reqwidth .e] + set x1 [winfo reqwidth .e] + set x2 [expr {8+5*[font measure {helvetica 12} .]}] + set x [expr {$x1 eq $x2}] .e configure -show X - lappend x [winfo reqwidth .e] + set x1 [winfo reqwidth .e] + set x2 [expr {8+5*[font measure {helvetica 12} X]}] + lappend x [expr {$x1 eq $x2}] .e configure -show "" - lappend x [winfo reqwidth .e] -} [list \ - [expr 8+5*[font measure {helvetica 12} .]] \ - [expr 8+5*[font measure {helvetica 12} X]] \ - [expr 8+[font measure {helvetica 12} 12345]]] - -catch {destroy .e} -entry .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll -pack .e -focus .e -test entry-7.1 {InsertChars procedure} { - .e delete 0 end + set x1 [winfo reqwidth .e] + set x2 [expr {8+[font measure {helvetica 12} 12345]}] + lappend x [expr {$x1 eq $x2}] +} -cleanup { + destroy .e +} -result {1 1 1} + + +test entry-7.1 {InsertChars procedure} -setup { + unset -nocomplain contents + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 2 XXX update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abXXXcde abXXXcde {0.000000 1.000000}} -test entry-7.2 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abXXXcde abXXXcde {0.000000 1.000000}} + +test entry-7.2 {InsertChars procedure} -setup { + unset -nocomplain contents + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 500 XXX update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abcdeXXX abcdeXXX {0.000000 1.000000}} -test entry-7.3 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abcdeXXX abcdeXXX {0.000000 1.000000}} +test entry-7.3 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -806,9 +1934,13 @@ test entry-7.3 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {5 9 5 8} -test entry-7.4 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {5 9 5 8} +test entry-7.4 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -816,9 +1948,13 @@ test entry-7.4 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {2 9 2 8} -test entry-7.5 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 9 2 8} +test entry-7.5 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -826,9 +1962,13 @@ test entry-7.5 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {2 9 2 8} -test entry-7.6 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 9 2 8} +test entry-7.6 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -836,70 +1976,118 @@ test entry-7.6 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 5 lappend x [.e index sel.first] [.e index sel.last] -} {2 6 2 5} -test entry-7.7 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 6 2 5} +test entry-7.7 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -xscrollcommand scroll .e insert 0 0123456789 .e icursor 4 .e insert 4 XXX .e index insert -} {7} -test entry-7.8 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {7} +test entry-7.8 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e icursor 4 .e insert 5 XXX .e index insert -} {4} -test entry-7.9 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test entry-7.9 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 "This is a very long string" update .e xview 4 .e insert 3 XXX .e index @0 -} {7} -test entry-7.10 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {7} +test entry-7.10 {InsertChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 "This is a very long string" update .e xview 4 .e insert 4 XXX .e index @0 -} {4} -.e configure -width 0 -test entry-7.11 {InsertChars procedure} {fonts} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} + +test entry-7.11 {InsertChars procedure} -constraints { + fonts +} -setup { + entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 "xyzzy" update .e insert 2 00 winfo reqwidth .e -} {59} +} -cleanup { + destroy .e +} -result {59} -.e configure -width 10 -test entry-8.1 {DeleteChars procedure} { - .e delete 0 end +test entry-8.1 {DeleteChars procedure} -setup { + unset -nocomplain contents + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 2 4 update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abe abe {0.000000 1.000000}} -test entry-8.2 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abe abe {0.000000 1.000000}} +test entry-8.2 {DeleteChars procedure} -setup { + unset -nocomplain contents + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete -2 2 update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {cde cde {0.000000 1.000000}} -test entry-8.3 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {cde cde {0.000000 1.000000}} +test entry-8.3 {DeleteChars procedure} -setup { + unset -nocomplain contents + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 3 1000 update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abc abc {0.000000 1.000000}} -test entry-8.4 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abc abc {0.000000 1.000000}} +test entry-8.4 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -908,9 +2096,14 @@ test entry-8.4 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 5 lappend x [.e index sel.first] [.e index sel.last] -} {1 6 1 5} -test entry-8.5 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1 6 1 5} +test entry-8.5 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -919,9 +2112,14 @@ test entry-8.5 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 4 lappend x [.e index sel.first] [.e index sel.last] -} {1 5 1 4} -test entry-8.6 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1 5 1 4} +test entry-8.6 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -930,17 +2128,28 @@ test entry-8.6 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 5 lappend x [.e index sel.first] [.e index sel.last] -} {1 2 1 5} -test entry-8.7 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1 2 1 5} +test entry-8.7 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 .e delete 1 8 - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test entry-8.8 {DeleteChars procedure} { - .e delete 0 end + update + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test entry-8.8 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -949,17 +2158,27 @@ test entry-8.8 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {3 4 3 8} -test entry-8.9 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 4 3 8} +test entry-8.9 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 .e delete 3 8 - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test entry-8.10 {DeleteChars procedure} { - .e delete 0 end + update + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test entry-8.10 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 8 .e select to 3 @@ -968,9 +2187,14 @@ test entry-8.10 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {3 5 5 8} -test entry-8.11 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 5 5 8} +test entry-8.11 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 8 .e select to 3 @@ -979,124 +2203,186 @@ test entry-8.11 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 4 lappend x [.e index sel.first] [.e index sel.last] -} {3 8 4 8} -test entry-8.12 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 8 4 8} +test entry-8.12 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e icursor 4 .e delete 1 4 + update .e index insert -} {1} -test entry-8.13 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test entry-8.13 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e icursor 4 .e delete 1 5 + update .e index insert -} {1} -test entry-8.14 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test entry-8.14 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e icursor 4 .e delete 4 6 + update .e index insert -} {4} -test entry-8.15 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test entry-8.15 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "This is a very long string" .e xview 4 .e delete 1 4 + update .e index @0 -} {1} -test entry-8.16 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test entry-8.16 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "This is a very long string" .e xview 4 .e delete 1 5 + update .e index @0 -} {1} -test entry-8.17 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test entry-8.17 {DeleteChars procedure} -setup { + entry .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "This is a very long string" .e xview 4 .e delete 4 6 + update .e index @0 -} {4} -.e configure -width 0 -test entry-8.18 {DeleteChars procedure} {fonts} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test entry-8.18 {DeleteChars procedure} -setup { + entry .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "xyzzy" update .e delete 2 4 winfo reqwidth .e -} {31} +} -cleanup { + destroy .e +} -result {31} -test entry-9.1 {EntryValueChanged procedure} { - catch {destroy .e} - proc override args { - global x - set x 12345 - } - catch {unset x} +test entry-9.1 {EntryValueChanged procedure} -setup { + unset -nocomplain x +} -body { trace variable x w override - entry .e -textvariable x + entry .e -textvariable x -width 0 .e insert 0 foo - set result [list $x [.e get]] - unset x; rename override {} - set result -} {12345 12345} - -catch {destroy .e} -entry .e -pack .e -.e configure -width 0 -test entry-10.1 {EntrySetValue procedure} {fonts} { + list $x [.e get] +} -cleanup { + destroy .e + trace vdelete x w override + unset x +} -result {12345 12345} + + +test entry-10.1 {EntrySetValue procedure} -constraints fonts -body { set x abcde set y ab - .e configure -textvariable x - update + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0 + pack .e + .e configure -textvariable x .e configure -textvariable y update list [.e get] [winfo reqwidth .e] -} {ab 24} -test entry-10.2 {EntrySetValue procedure, updating selection} { - catch {destroy .e} - entry .e -textvariable x +} -cleanup { + destroy .e +} -result {ab 24} +test entry-10.2 {EntrySetValue procedure, updating selection} -setup { + unset -nocomplain x + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -textvariable x .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 set x "a" - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test entry-10.3 {EntrySetValue procedure, updating selection} { - catch {destroy .e} - entry .e -textvariable x + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test entry-10.3 {EntrySetValue procedure, updating selection} -setup { + unset -nocomplain x + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -textvariable x .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 set x "abcdefg" list [.e index sel.first] [.e index sel.last] -} {4 7} -test entry-10.4 {EntrySetValue procedure, updating selection} { - catch {destroy .e} - entry .e -textvariable x +} -cleanup { + destroy .e +} -result {4 7} +test entry-10.4 {EntrySetValue procedure, updating selection} -setup { + unset -nocomplain x + entry .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -textvariable x .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 set x "abcdefghijklmn" list [.e index sel.first] [.e index sel.last] -} {4 10} -test entry-10.5 {EntrySetValue procedure, updating display position} { - catch {destroy .e} - entry .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {4 10} +test entry-10.5 {EntrySetValue procedure, updating display position} -setup { + unset -nocomplain x + entry .e -highlightthickness 2 -bd 2 pack .e +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 update set x "abcdefg" update .e index @0 -} {0} -test entry-10.6 {EntrySetValue procedure, updating display position} { - catch {destroy .e} - entry .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {0} +test entry-10.6 {EntrySetValue procedure, updating display position} -setup { + unset -nocomplain x + entry .e -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 @@ -1104,192 +2390,472 @@ test entry-10.6 {EntrySetValue procedure, updating display position} { set x "1234567890123456789012" update .e index @0 -} {10} -test entry-10.7 {EntrySetValue procedure, updating insertion cursor} { - catch {destroy .e} - entry .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {10} +test entry-10.7 {EntrySetValue procedure, updating insertion cursor} -setup { + unset -nocomplain x + entry .e -highlightthickness 2 -bd 2 + pack .e + update +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 set x "123" .e index insert -} {3} -test entry-10.8 {EntrySetValue procedure, updating insertion cursor} { - catch {destroy .e} - entry .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {3} +test entry-10.8 {EntrySetValue procedure, updating insertion cursor} -setup { + unset -nocomplain x + entry .e -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 set x "123456" .e index insert -} {5} +} -cleanup { + destroy .e +} -result {5} -test entry-11.1 {EntryEventProc procedure} { - catch {destroy .e} - entry .e +test entry-11.1 {EntryEventProc procedure} -setup { + entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12} + pack .e +} -body { .e insert 0 abcdefg destroy .e update -} {} -test entry-11.2 {EntryEventProc procedure} { - deleteWindows +} -cleanup { + destroy .e +} -result {} +test entry-11.2 {EntryEventProc procedure} -setup { + set x {} +} -body { entry .e1 -fg #112233 rename .e1 .e2 - set x {} lappend x [winfo children .] lappend x [.e2 cget -fg] destroy .e1 lappend x [info command .e*] [winfo children .] -} {.e1 #112233 {} {}} - -test entry-12.1 {EntryCmdDeletedProc procedure} { - deleteWindows - button .e1 -text "xyz_123" - rename .e1 {} - list [info command .e*] [winfo children .] -} {{} {}} - -catch {destroy .e} -entry .e -font $fixed -width 5 -bd 2 -relief sunken -pack .e -.e insert 0 012345678901234567890 -.e xview 4 -update -test entry-13.1 {GetEntryIndex procedure} { +} -cleanup { + destroy .e1 +} -result {.e1 #112233 {} {}} + +test entry-12.1 {EntryCmdDeletedProc procedure} -body { + button .b -text "xyz_123" + rename .b {} + list [info command .b*] [winfo children .] +} -cleanup { + destroy .b +} -result {{} {}} + + +test entry-13.1 {GetEntryIndex procedure} -setup { + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e index end -} {21} -test entry-13.2 {GetEntryIndex procedure} { - list [catch {.e index abogus} msg] $msg -} {1 {bad entry index "abogus"}} -test entry-13.3 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {21} +test entry-13.2 {GetEntryIndex procedure} -body { + entry .e + .e index abogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "abogus"} +test entry-13.3 {GetEntryIndex procedure} -setup { + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 1 .e select to 6 .e index anchor -} {1} -test entry-13.4 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {1} +test entry-13.4 {GetEntryIndex procedure} -setup { + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 4 .e select to 1 .e index anchor -} {4} -test entry-13.5 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {4} +test entry-13.5 {GetEntryIndex procedure} -setup { + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 3 .e select to 15 .e select adjust 4 .e index anchor -} {15} -test entry-13.6 {GetEntryIndex procedure} { - list [catch {.e index ebogus} msg] $msg -} {1 {bad entry index "ebogus"}} -test entry-13.7 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {15} +test entry-13.6 {GetEntryIndex procedure} -setup { + entry .e +} -body { + .e index ebogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "ebogus"} +test entry-13.7 {GetEntryIndex procedure} -setup { + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e icursor 2 .e index insert -} {2} -test entry-13.8 {GetEntryIndex procedure} { - list [catch {.e index ibogus} msg] $msg -} {1 {bad entry index "ibogus"}} -test entry-13.9 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {2} +test entry-13.8 {GetEntryIndex procedure} -setup { + entry .e +} -body { + .e index ibogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "ibogus"} +test entry-13.9 {GetEntryIndex procedure} -setup { + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +} -cleanup { + destroy .e +} -result {1 6} + + + + + + +test entry-13.10 {GetEntryIndex procedure} -constraints unix -body { +# On unix, when selection is cleared, entry widget's internal +# selection range is reset. +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} + +test entry-13.11 {GetEntryIndex procedure} -constraints win -body { +# On mac and pc, when selection is cleared, entry widget remembers +# last selected range. When selection ownership is restored to +# entry, the old range will be rehighlighted. +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + catch {selection get} + .e index sel.first +} -cleanup { + destroy .e +} -result {1} + +test entry-13.12 {GetEntryIndex procedure} -constraints unix -body { +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index sbogus +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} + +# why when string in .e index changed to not beginning with s, +# it behaves differently? +test entry-13.12.1 {GetEntryIndex procedure} -constraints unix -body { +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index bogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "bogus"} + +test entry-13.13 {GetEntryIndex procedure} -constraints win -body { +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index sbogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "sbogus"} + +test entry-13.14 {GetEntryIndex procedure} -constraints win -body { +# On mac and pc, when selection is cleared, entry widget remembers +# last selected range. When selection ownership is restored to +# entry, the old range will be rehighlighted. +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + selection get +} -cleanup { + destroy .e +} -returnCodes error -match glob -result {*} + +test entry-13.14.1 {GetEntryIndex procedure} -constraints win -body { +# On mac and pc, when selection is cleared, entry widget remembers +# last selected range. When selection ownership is restored to +# entry, the old range will be rehighlighted. +# Previous settings: + entry .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 1 .e select to 6 list [.e index sel.first] [.e index sel.last] -} {1 6} -selection clear .e -test entry-13.10 {GetEntryIndex procedure} unix { - # On unix, when selection is cleared, entry widget's internal - # selection range is reset. - - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test entry-13.11 {GetEntryIndex procedure} win { - # On mac and pc, when selection is cleared, entry widget remembers - # last selected range. When selection ownership is restored to - # entry, the old range will be rehighlighted. - - list [catch {selection get}] [.e index sel.first] -} {1 1} -test entry-13.12 {GetEntryIndex procedure} unix { - list [catch {.e index sbogus} msg] $msg -} {1 {selection isn't in widget .e}} -test entry-13.13 {GetEntryIndex procedure} win { - list [catch {.e index sbogus} msg] $msg -} {1 {bad entry index "sbogus"}} -test entry-13.14 {GetEntryIndex procedure} win { - list [catch {selection get}] [catch {.e index sbogus}] -} {1 1} -test entry-13.15 {GetEntryIndex procedure} { - list [catch {.e index @xyz} msg] $msg -} {1 {bad entry index "@xyz"}} -test entry-13.16 {GetEntryIndex procedure} {fonts} { +# Testing: + selection clear .e + catch {selection get} + .e index sbogus +} -cleanup { + destroy .e +} -returnCodes error -match glob -result {*} + +test entry-13.15 {GetEntryIndex procedure} -body { + entry .e + selection clear .e + .e index @xyz +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "@xyz"} + +test entry-13.16 {GetEntryIndex procedure} -constraints fonts -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @4 -} {4} -test entry-13.17 {GetEntryIndex procedure} {fonts} { +} -cleanup { + destroy .e +} -result {4} +test entry-13.17 {GetEntryIndex procedure} -constraints fonts -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @11 -} {4} -test entry-13.18 {GetEntryIndex procedure} {fonts} { +} -cleanup { + destroy .e +} -result {4} +test entry-13.18 {GetEntryIndex procedure} -constraints fonts -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @12 -} {5} -test entry-13.19 {GetEntryIndex procedure} {fonts} { - .e index @[expr [winfo width .e] - 6] -} {8} -test entry-13.20 {GetEntryIndex procedure} {fonts} { - .e index @[expr [winfo width .e] - 5] -} {9} -test entry-13.21 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {5} +test entry-13.19 {GetEntryIndex procedure} -constraints fonts -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e index @[expr {[winfo width .e] - 6}] +} -cleanup { + destroy .e +} -result {8} +test entry-13.20 {GetEntryIndex procedure} -constraints fonts -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e index @[expr {[winfo width .e] - 5}] +} -cleanup { + destroy .e +} -result {9} +test entry-13.21 {GetEntryIndex procedure} -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @1000 -} {9} -test entry-13.22 {GetEntryIndex procedure} { - list [catch {.e index 1xyz} msg] $msg -} {1 {bad entry index "1xyz"}} -test entry-13.23 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {9} +test entry-13.22 {GetEntryIndex procedure} -setup { + entry .e + pack .e + update +} -body { + .e index 1xyz +} -cleanup { + destroy .e +} -returnCodes error -result {bad entry index "1xyz"} +test entry-13.23 {GetEntryIndex procedure} -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index -10 -} {0} -test entry-13.24 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {0} +test entry-13.24 {GetEntryIndex procedure} -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index 12 -} {12} -test entry-13.25 {GetEntryIndex procedure} { +} -cleanup { + destroy .e +} -result {12} +test entry-13.25 {GetEntryIndex procedure} -body { + entry .e -width 5 -relief sunken -highlightthickness 2 -bd 2\ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index 49 -} {21} -test entry-13.26 {GetEntryIndex procedure} {fonts} { - catch {destroy .e} - entry .e -show . +} -cleanup { + destroy .e +} -result {21} +test entry-13.26 {GetEntryIndex procedure} -constraints fonts -body { + entry .e -highlightthickness 2 -bd 2 -font {Helvetica -12} + selection clear .e + .e configure -show . .e insert 0 XXXYZZY pack .e update list [.e index @7] [.e index @8] -} {0 1} +} -cleanup { + destroy .e +} -result {0 1} # XXX Still need to write tests for EntryScanTo and EntrySelectTo. -set x {} -for {set i 1} {$i <= 500} {incr i} { - append x "This is line $i, out of 500\n" -} -test entry-14.1 {EntryFetchSelection procedure} { - catch {destroy .e} + +test entry-14.1 {EntryFetchSelection procedure} -body { entry .e .e insert end "This is a test string" .e select from 1 .e select to 18 selection get -} {his is a test str} -test entry-14.2 {EntryFetchSelection procedure} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {his is a test str} +test entry-14.2 {EntryFetchSelection procedure} -body { entry .e -show * .e insert end "This is a test string" .e select from 1 .e select to 18 selection get -} {*****************} -test entry-14.3 {EntryFetchSelection procedure} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {*****************} +test entry-14.3 {EntryFetchSelection procedure} -setup { + set x {} + for {set i 1} {$i <= 500} {incr i} { + append x "This is line $i, out of 500\n" +} +} -body { entry .e - .e insert end $x + .e insert end $x .e select from 0 .e select to end string compare [selection get] $x -} 0 +} -cleanup { + destroy .e +} -result {0} -test entry-15.1 {EntryLostSelection} { - catch {destroy .e} +test entry-15.1 {EntryLostSelection} -body { entry .e .e insert 0 "Text" .e select from 0 @@ -1299,334 +2865,617 @@ test entry-15.1 {EntryLostSelection} { .e select from 0 .e select to 4 lappend result [selection get] -} {Text Text} - -# No tests for EventuallyRedraw. - -catch {destroy .e} -entry .e -width 10 -xscrollcommand scroll -pack .e -update +} -cleanup { + destroy .e +} -result {Text Text} -test entry-16.1 {EntryVisibleRange procedure} {fonts} { - .e delete 0 end - .e insert 0 ............................. +# is scrollcommand needed here?? +test entry-16.1 {EntryVisibleRange procedure} -constraints fonts -body { + entry .e -width 10 -font {Helvetica -12} + pack .e + update + .e insert 0 "............................." format {%.6f %.6f} {*}[.e xview] -} {0.000000 0.827586} -test entry-16.2 {EntryVisibleRange procedure} {unix fonts} { - .e configure -show X - .e delete 0 end - .e insert 0 ............................. +} -cleanup { + destroy .e +} -result {0.000000 0.827586} +test entry-16.2 {EntryVisibleRange procedure} -constraints { + unix fonts +} -body { + entry .e -show X -width 10 -font {Helvetica -12} + pack .e + update + .e insert 0 "............................." format {%.6f %.6f} {*}[.e xview] -} {0.000000 0.275862} -test entry-16.3 {EntryVisibleRange procedure} win { - .e configure -show . - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.000000 0.275862} +test entry-16.3 {EntryVisibleRange procedure} -constraints { + win +} -body { + entry .e -show . -width 10 -font {Helvetica -12} + pack .e + update .e insert 0 XXXXXXXXXXXXXXXXXXXXXXXXXXXXX format {%.6f %.6f} {*}[.e xview] -} {0.000000 0.827586} -.e configure -show "" -test entry-16.4 {EntryVisibleRange procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.000000 0.827586} +test entry-16.4 {EntryVisibleRange procedure} -body { + entry .e -show "" format {%.6f %.6f} {*}[.e xview] -} {0.000000 1.000000} +} -cleanup { + destroy .e +} -result {0.000000 1.000000} + -catch {destroy .e} -entry .e -width 10 -xscrollcommand scroll -font $fixed -pack .e -update -test entry-17.1 {EntryUpdateScrollbar procedure} { +test entry-17.1 {EntryUpdateScrollbar procedure} -body { + entry .e -width 10 -xscrollcommand scroll -font {Courier -12} + pack .e .e delete 0 end .e insert 0 123 update format {%.6f %.6f} {*}$scrollInfo -} {0.000000 1.000000} -test entry-17.2 {EntryUpdateScrollbar procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.000000 1.000000} +test entry-17.2 {EntryUpdateScrollbar procedure} -body { + entry .e -width 10 -xscrollcommand scroll -font {Courier -12} + pack .e .e insert 0 0123456789abcdef .e xview 3 update format {%.6f %.6f} {*}$scrollInfo -} {0.187500 0.812500} -test entry-17.3 {EntryUpdateScrollbar procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.187500 0.812500} +test entry-17.3 {EntryUpdateScrollbar procedure} -body { + entry .e -width 10 -xscrollcommand scroll -font {Courier -12} + pack .e .e insert 0 abcdefghijklmnopqrs .e xview 6 update format {%.6f %.6f} {*}$scrollInfo -} {0.315789 0.842105} -test entry-17.4 {EntryUpdateScrollbar procedure} { +} -cleanup { destroy .e +} -result {0.315789 0.842105} +test entry-17.4 {EntryUpdateScrollbar procedure} -setup { proc bgerror msg { global x set x $msg - } +} +} -body { entry .e -width 5 -xscrollcommand thisisnotacommand pack .e update - rename bgerror {} list $x $errorInfo -} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" +} -cleanup { + destroy .e + rename bgerror {} +} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" while executing "thisisnotacommand 0.0 1.0" (horizontal scrolling command executed by .e)}} -set l [interp hidden] -deleteWindows -test entry-18.1 {Entry widget vs hiding} { - destroy .e +test entry-18.1 {Entry widget vs hiding} -setup { entry .e +} -body { + set l [interp hidden] interp hide {} .e destroy .e - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 == $res2} +} -result {1} ## ## Entry widget VALIDATION tests ## - -destroy .e -catch {unset ::e} -catch {unset ::vVals} -entry .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ - -invalidcommand bell \ - -textvariable ::e \ - -background red -foreground white -pack .e -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 1 -} - # The validation tests build each one upon the previous, so cascading # failures aren't good # -test entry-19.1 {entry widget validation} { + +# 19.* test cases in previous version highly depended on the previous +# test cases. This was replaced by inserting recently set configurations +# that matters for the test case +test entry-19.1 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e .e insert 0 a - set ::vVals -} {.e 1 0 a {} a all key} -test entry-19.2 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e 1 0 a {} a all key} + +test entry-19.2 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 a ;# previous settings .e insert 1 b - set ::vVals -} {.e 1 1 ab a b all key} -test entry-19.3 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e 1 1 ab a b all key} + +test entry-19.3 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 ab ;# previous settings .e insert end c - set ::vVals -} {.e 1 2 abc ab c all key} -test entry-19.4 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e 1 2 abc ab c all key} + +test entry-19.4 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 abc ;# previous settings .e insert 1 123 list $::vVals $::e -} {{.e 1 1 a123bc abc 123 all key} a123bc} -test entry-19.5 {entry widget validation} { +} -cleanup { + destroy .e +} -result {{.e 1 1 a123bc abc 123 all key} a123bc} + +test entry-19.5 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 a123bc ;# previous settings .e delete 2 - set ::vVals -} {.e 0 2 a13bc a123bc 2 all key} -test entry-19.6 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e 0 2 a13bc a123bc 2 all key} + +test entry-19.6 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 a13bc ;# previous settings .e configure -validate key .e delete 1 3 - set ::vVals -} {.e 0 1 abc a13bc 13 key key} -test entry-19.7 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e 0 1 abc a13bc 13 key key} + +test entry-19.7 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focus \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abc ;# previous settings set ::vVals {} - .e configure -validate focus .e insert end d - set ::vVals -} {} -test entry-19.8 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {} + +test entry-19.8 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e configure -validate focus ;# previous settings + .e insert end abcd ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update - set ::vVals -} {.e -1 -1 abcd abcd {} focus focusin} -test entry-19.9 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focus focusin} + +test entry-19.9 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focus \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + focus -force .e ;# previous settings + update ;# previous settings +# update necessary to process FocusIn event focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update - set ::vVals -} {.e -1 -1 abcd abcd {} focus focusout} -.e configure -validate all -test entry-19.10 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focus focusout} + +test entry-19.10 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update - set ::vVals -} {.e -1 -1 abcd abcd {} all focusin} -test entry-19.11 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} all focusin} + +test entry-19.11 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + focus -force .e ;# previous settings +# update necessary to process FocusIn event + update ;# previous settings focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update - set ::vVals -} {.e -1 -1 abcd abcd {} all focusout} -.e configure -validate focusin -test entry-19.12 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} all focusout} + +test entry-19.12 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focusin \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 abcd ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update - set ::vVals -} {.e -1 -1 abcd abcd {} focusin focusin} -test entry-19.13 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focusin focusin} + +test entry-19.13 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focusin \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings set ::vVals {} focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update - set ::vVals -} {} -.e configure -validate focuso -test entry-19.14 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {} + +test entry-19.14 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + set ::vVals {} ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update - set ::vVals -} {} -test entry-19.15 {entry widget validation} { + return $::vVals +} -cleanup { + destroy .e +} -result {} + +test entry-19.15 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + set ::vVals {} ;# previous settings + focus -force .e ;# previous settings +# update necessary to process FocusIn event + update ;# previous settings focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event + update + return $::vVals +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focusout focusout} + +# the same as 19.16 but added [.e validate] to returned list +test entry-19.16 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + set ::vVals {} ;# previous settings + focus -force .e ;# previous settings +# update necessary to process FocusIn event + update ;# previous settings + focus -force . +# update necessary to process FocusOut event update - set ::vVals -} {.e -1 -1 abcd abcd {} focusout focusout} -test entry-19.16 {entry widget validation} { list [.e validate] $::vVals -} {1 {.e -1 -1 abcd abcd {} all forced}} -test entry-19.17 {entry widget validation} { +} -cleanup { + destroy .e +} -result {1 {.e -1 -1 abcd abcd {} all forced}} + + +test entry-19.17 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings set ::e newdata list [.e cget -validate] $::vVals -} {focusout {.e -1 -1 newdata abcd {} focusout forced}} +} -cleanup { + destroy .e +} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}} -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 0 -} -test entry-19.18 {entry widget validation} { +# proc doval changed - returns 0 +test entry-19.18 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + set ::e newdata ;# previous settings .e configure -validate all set ::e nextdata list [.e cget -validate] $::vVals -} {none {.e -1 -1 nextdata newdata {} all forced}} - -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - set ::e mydata - return 1 -} +} -cleanup { + destroy .e +} -result {none {.e -1 -1 nextdata newdata {} all forced}} ## This sets validate to none because it shows that we prevent a possible ## loop condition in the validation, when the entry textvar is also set -test entry-19.19 {entry widget validation} { - .e configure -validate all +# proc doval2 used +test entry-19.19 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + set ::e nextdata ;# previous settings + + .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] .e validate list [.e cget -validate] [.e get] $::vVals -} {none mydata {.e -1 -1 nextdata nextdata {} all forced}} +} -cleanup { + destroy .e +} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}} ## This leaves validate alone because we trigger validation through the ## textvar (a write trace), and the write during validation triggers ## nothing (by definition of avoiding loops on var traces). This is ## one of those "dangerous" conditions where the user will have a ## different value in the entry widget shown as is in the textvar. -test entry-19.20 {entry widget validation} { +test entry-19.20 {entry widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + entry .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + set ::e nextdata ;# previous settings + .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev + .e validate ;# previous settings + .e configure -validate all set ::e testdata list [.e cget -validate] [.e get] $::e $::vVals -} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} - -destroy .e -catch {unset ::e ::vVals} - +} -cleanup { + destroy .e +} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} ## ## End validation tests ## -test entry-20.1 {widget deletion while active} { - destroy .e +test entry-20.1 {widget deletion while active} -body { entry .e -validate all \ -validatecommand { destroy %W ; return 1 } \ -invalidcommand bell update .e insert 0 abc winfo exists .e -} 0 -test entry-20.2 {widget deletion while active} { +} -cleanup { destroy .e +} -result {0} + +test entry-20.2 {widget deletion while active} -body { entry .e -validate all \ -validatecommand { return 0 } \ -invalidcommand { destroy %W } .e insert 0 abc winfo exists .e -} 0 -test entry-20.3 {widget deletion while active} { +} -cleanup { destroy .e +} -result {0} + +test entry-20.3 {widget deletion while active} -body { entry .e -validate all \ -validatecommand { rename .e {} ; return 1 } .e insert 0 abc winfo exists .e -} 0 -test entry-20.4 {widget deletion while active} { +} -cleanup { destroy .e +} -result {0} + +test entry-20.4 {widget deletion while active} -body { entry .e -validate all \ -validatecommand { return 0 } \ -invalidcommand { rename .e {} } .e insert 0 abc winfo exists .e -} 0 -test entry-20.5 {widget deletion while active} { +} -cleanup { destroy .e +} -result {0} + +test entry-20.5 {widget deletion while active} -body { entry .e -validatecommand { destroy .e ; return 0 } .e validate winfo exists .e -} 0 -test entry-20.6 {widget deletion while active} { +} -cleanup { destroy .e +} -result {0} + +test entry-20.6 {widget deletion while active} -body { pack [entry .e] update .e config -xscrollcommand { destroy .e } update idle winfo exists .e -} 0 -test entry-20.7 {widget deletion with textvariable active} { - # SF bugs 607390 and 617446 +} -cleanup { destroy .e +} -result {0} + +test entry-20.7 {widget deletion with textvariable active} -body { +# SF bugs 607390 and 617446 set FOO init entry .e -textvariable FOO -validate all \ -vcmd {%W configure -bg white; format 1} bind .e <Destroy> { set FOO hello } destroy .e winfo exists .e -} 0 - -test entry-21.1 {selection present while disabled, bug 637828} { +} -cleanup { destroy .e +} -result {0} + + +test entry-21.1 {selection present while disabled, bug 637828} -body { entry .e .e insert end 0123456789 .e select from 3 .e select to 6 set out [.e selection present] .e configure -state disabled - # still return 1 when disabled, because 'selection get' will work, - # but selection cannot be changed (new behavior since 8.4) +# still return 1 when disabled, because 'selection get' will work, +# but selection cannot be changed (new behavior since 8.4) .e select to 9 lappend out [.e selection present] [selection get] -} {1 1 345} - -test entry-22.1 {lost namespaced textvar} { +} -cleanup { destroy .e +} -result {1 1 345} + +test entry-22.1 {lost namespaced textvar} -body { namespace eval test { variable foo {a b} } entry .e -textvariable ::test::foo namespace delete test .e insert end "more stuff" .e delete 5 end - catch {set ::test::foo} result - list [.e get] [.e cget -textvar] $result -} [list "a bmo" ::test::foo \ - {can't read "::test::foo": no such variable}] - -destroy .e + set ::test::foo +} -cleanup { + destroy .e +} -returnCodes error -result {can't read "::test::foo": no such variable} +test entry-22.2 {lost namespaced textvar} -body { + namespace eval test { variable foo {a b} } + entry .e -textvariable ::test::foo + namespace delete test + .e insert end "more stuff" + .e delete 5 end + catch {set ::test::foo} + list [.e get] [.e cget -textvar] +} -cleanup { + destroy .e +} -result [list "a bmo" ::test::foo] +# Gathered comments about lacks # XXX Still need to write tests for EntryBlinkProc, EntryFocusProc, # and EntryTextVarProc. +# No tests for DisplayEntry. +# XXX Still need to write tests for EntryScanTo and EntrySelectTo. +# No tests for EventuallyRedraw -option clear - +# option clear # cleanup cleanupTests return + + + diff --git a/tests/event.test b/tests/event.test index fa75610..1548467 100644 --- a/tests/event.test +++ b/tests/event.test @@ -6,9 +6,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # XXX This test file is woefully incomplete. Right now it only tests # a few of the procedures in tkEvent.c. Please add more tests whenever @@ -183,37 +184,49 @@ proc _get_selection {widget} { # Begining of the actual tests -test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} { +test event-1.1 {Tk_HandleEvent procedure, filter events for dead windows} -setup { + deleteWindows + set x {} +} -body { button .b -text Test pack .b bindtags .b .b update bind .b <Destroy> { - lappend x destroy - event generate .b <1> - event generate .b <ButtonRelease-1> + lappend x destroy + event generate .b <1> + event generate .b <ButtonRelease-1> } bind .b <1> { - lappend x button + lappend x button } - set x {} + destroy .b - set x -} {destroy} -test event-1.2 {event generate <Alt-z>} { - catch {destroy .e} - catch {unset ::event12result} + return $x +} -cleanup { + deleteWindows +} -result {destroy} +test event-1.2 {event generate <Alt-z>} -setup { + deleteWindows + catch {unset ::event12result} +} -body { set ::event12result 0 pack [entry .e] update bind .e <Alt-z> {set ::event12result "1"} - focus -force .e ; event generate .e <Alt-z> + + focus -force .e + event generate .e <Alt-z> destroy .e set ::event12result -} 1 +} -cleanup { + deleteWindows +} -result 1 + -test event-2.1(keypress) {type into entry widget and hit Return} { - destroy .t +test event-2.1(keypress) {type into entry widget and hit Return} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -222,9 +235,12 @@ test event-2.1(keypress) {type into entry widget and hit Return} { tkwait visibility $e _keypress_string $e HELLO\n list [$e get] $return_binding -} {HELLO 1} -test event-2.2(keypress) {type into entry widget and then delete some text} { - destroy .t +} -cleanup { + deleteWindows +} -result {HELLO 1} +test event-2.2(keypress) {type into entry widget and then delete some text} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -233,10 +249,13 @@ test event-2.2(keypress) {type into entry widget and then delete some text} { _keypress $e BackSpace _keypress $e BackSpace $e get -} MEL -test event-2.3(keypress) {type into entry widget, triple click,\ - hit Delete key, and then type some more} { - destroy .t +} -cleanup { + deleteWindows +} -result {MEL} +test event-2.3(keypress) {type into entry widget, triple click, hit Delete key, + and then type some more} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -256,9 +275,12 @@ test event-2.3(keypress) {type into entry widget, triple click,\ _keypress $e Delete _keypress_string $e UP lappend result [$e get] -} {JUMP UP} -test event-1.4(keypress) {type into text widget and hit Return} { - destroy .t +} -cleanup { + deleteWindows +} -result {JUMP UP} +test event-2.4(keypress) {type into text widget and hit Return} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -267,9 +289,12 @@ test event-1.4(keypress) {type into text widget and hit Return} { tkwait visibility $e _keypress_string $e HELLO\n list [$e get 1.0 end] $return_binding -} [list "HELLO\n\n" 1] -test event-2.5(keypress) {type into text widget and then delete some text} { - destroy .t +} -cleanup { + deleteWindows +} -result [list "HELLO\n\n" 1] +test event-2.5(keypress) {type into text widget and then delete some text} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -278,10 +303,13 @@ test event-2.5(keypress) {type into text widget and then delete some text} { _keypress $e BackSpace _keypress $e BackSpace $e get 1.0 1.end -} MEL -test event-2.6(keypress) {type into text widget, triple click,\ - hit Delete key, and then type some more} { - destroy .t +} -cleanup { + deleteWindows +} -result {MEL} +test event-2.6(keypress) {type into text widget, triple click, + hit Delete key, and then type some more} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -301,11 +329,14 @@ test event-2.6(keypress) {type into text widget, triple click,\ _keypress $e Delete _keypress_string $e UP lappend result [$e get 1.0 1.end] -} {JUMP UP} - -test event-3.1(click-drag) {click and drag in a text widget, this tests\ - tkTextSelectTo in text.tcl} { - destroy .t +} -cleanup { + deleteWindows +} -result {JUMP UP} + +test event-3.1(click-drag) {click and drag in a text widget, this tests + tkTextSelectTo in text.tcl} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -366,10 +397,13 @@ test event-3.1(click-drag) {click and drag in a text widget, this tests\ # Save the highlighted text lappend result [_get_selection $e] -} {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} -test event-3.2(click-drag) {click and drag in an entry widget, this\ - tests tkEntryMouseSelect in entry.tcl} { - destroy .t +} -cleanup { + deleteWindows +} -result {{A Tcl/Tk selection test!} 1.6 1.18 {Tk selection} 1.2 {Tcl/Tk selection}} + test event-3.2(click-drag) {click and drag in an entry widget, this + tests tkEntryMouseSelect in entry.tcl} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -430,11 +464,15 @@ test event-3.2(click-drag) {click and drag in an entry widget, this\ # Save the highlighted text lappend result [_get_selection $e] -} {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} +} -cleanup { + deleteWindows +} -result {{A Tcl/Tk selection!} 6 18 {Tk selection} 2 {Tcl/Tk selection}} -test event-4.1(double-click-drag) {click down, click up, click down again,\ - then drag in a text widget} { - destroy .t + +test event-4.1(double-click-drag) {click down, click up, click down again, + then drag in a text widget} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -497,11 +535,14 @@ test event-4.1(double-click-drag) {click down, click up, click down again,\ # Insert cursor should be before the r in "Word" lappend result [$e index insert] - set result -} {select 1.5 1.7 select 1.4 { select} {Word select} 1.2} -test event-4.2(double-click-drag) {click down, click up, click down again,\ - then drag in an entry widget} { - destroy .t + return $result +} -cleanup { + deleteWindows +} -result {select 1.5 1.7 select 1.4 { select} {Word select} 1.2} +test event-4.2(double-click-drag) {click down, click up, click down again, + then drag in an entry widget} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -564,12 +605,15 @@ test event-4.2(double-click-drag) {click down, click up, click down again,\ # Insert cursor should be before the r in "Word" lappend result [$e index insert] - set result -} {select 11 7 select 4 { select} {Word select} 2} + return $result +} -cleanup { + deleteWindows +} -result {select 11 7 select 4 { select} {Word select} 2} -test event-5.1(triple-click-drag) {Triple click and drag across lines in\ - a text widget, this should extend the selection to the new line} { - destroy .t +test event-5.1(triple-click-drag) {Triple click and drag across lines in a + text widget, this should extend the selection to the new line} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -620,16 +664,18 @@ test event-5.1(triple-click-drag) {Triple click and drag across lines in\ lappend result [_get_selection $e] - set result - -} [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \ + return $result +} -cleanup { + deleteWindows +} -result [list "LINE THREE\n" "LINE TWO\nLINE THREE\n" \ "LINE ONE\nLINE TWO\nLINE THREE\n"] -test event-6.1(button-state) {button press in a window that is then\ - destroyed, when the mouse is moved into another window it\ - should not generate a <B1-motion> event since the mouse\ - was not pressed down in that window} { - destroy .t +test event-6.1(button-state) {button press in a window that is then + destroyed, when the mouse is moved into another window it + should not generate a <B1-motion> event since the mouse + was not pressed down in that window} -setup { + deleteWindows +} -body { set t [toplevel .t] event generate $t <ButtonPress-1> @@ -638,12 +684,15 @@ test event-6.1(button-state) {button press in a window that is then\ set motion nomotion bind $t <B1-Motion> {set motion inmotion} event generate $t <Motion> - set motion -} nomotion + return $motion +} -cleanup { + deleteWindows +} -result {nomotion} test event-7.1(double-click) {A double click on a lone character - in a text widget should select that character} { - destroy .t + in a text widget should select that character} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [text $t.e] pack $e @@ -702,11 +751,16 @@ test event-7.1(double-click) {A double click on a lone character lappend result [$e index insert] lappend result [_get_selection $e] - set result -} {1.3 A 1.3 A} -test event-7.2(double-click) {A double click on a lone character\ - in an entry widget should select that character} {knownBug} { - destroy .t + return $result +} -cleanup { + deleteWindows +} -result {1.3 A 1.3 A} +test event-7.2(double-click) {A double click on a lone character + in an entry widget should select that character} -constraints { + knownBug +} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -765,13 +819,12 @@ test event-7.2(double-click) {A double click on a lone character\ lappend result [$e index insert] lappend result [_get_selection $e] - set result -} {3 A 4 A} + return $result +} -cleanup { + deleteWindows +} -result {3 A 4 A} # cleanup - -destroy .t - unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} @@ -782,3 +835,5 @@ rename _get_selection {} cleanupTests return + + diff --git a/tests/focus.test b/tests/focus.test index 5cc3abe..45cf73b 100644 --- a/tests/focus.test +++ b/tests/focus.test @@ -6,26 +6,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands - -button .b -text .b -relief raised -bd 2 -pack .b +namespace import -force tcltest::test proc focusSetup {} { - catch {destroy .t} + destroy .t toplevel .t wm geom .t +0+0 foreach i {b1 b2 b3 b4} { - button .t.$i -text .t.$i -relief raised -bd 2 - pack .t.$i + button .t.$i -text .t.$i -relief raised -bd 2 + pack .t.$i } tkwait visibility .t.b4 } proc focusSetupAlt {} { global env - catch {destroy .alt} + destroy .alt toplevel .alt -screen $env(TK_ALT_DISPLAY) foreach i {a b c d} { button .alt.$i -text .alt.$i -relief raised -bd 2 @@ -34,8 +32,6 @@ proc focusSetupAlt {} { tkwait visibility .alt.d } -# Make sure the window manager knows who has focus -catch {fixfocus} # The following procedure ensures that there is no input focus # in this application. It does it by arranging for another @@ -43,7 +39,6 @@ catch {fixfocus} # is needed to wait long enough for pending actions to get through # the X server and possibly also the window manager. -setupbg proc focusClear {} { global x; after 200 {set x 1} @@ -52,12 +47,17 @@ proc focusClear {} { update } -focusSetup -if {[testConstraint altDisplay]} { - focusSetupAlt -} -update +# Button used in some tests in the whole test file +button .b -text .b -relief raised -bd 2 +pack .b + +# Make sure the window manager knows who has focus +catch {fixfocus} + +# cleanupbg will be after 4.3 test +setupbg +update bind all <FocusIn> { append focusInfo "in %W %d\n" } @@ -67,36 +67,48 @@ bind all <FocusOut> { bind all <KeyPress> { append focusInfo "press %W %K" } +focusSetup +if {[testConstraint altDisplay]} { + focusSetupAlt +} -test focus-1.1 {Tk_FocusCmd procedure} unix { + +test focus-1.1 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus -} {} -test focus-1.2 {Tk_FocusCmd procedure} {unix altDisplay} { +} -result {} +test focus-1.2 {Tk_FocusCmd procedure} -constraints { + unix altDisplay +} -body { focus .alt.b focus -} {} -test focus-1.3 {Tk_FocusCmd procedure} unix { +} -result {} +test focus-1.3 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus .t.b3 focus -} {} -test focus-1.4 {Tk_FocusCmd procedure} unix { - list [catch {focus ""} msg] $msg -} {0 {}} -test focus-1.5 {Tk_FocusCmd procedure} unix { +} -result {} +test focus-1.4 {Tk_FocusCmd procedure} -constraints unix -body { + focus "" +} -returnCodes ok -result {} +test focus-1.5 {Tk_FocusCmd procedure} -constraints unix -body { focusClear focus -force .t focus .t.b3 focus -} {.t.b3} -test focus-1.6 {Tk_FocusCmd procedure} unix { - list [catch {focus .gorp} msg] $msg -} {1 {bad window path name ".gorp"}} -test focus-1.7 {Tk_FocusCmd procedure} unix { - list [catch {focus .gorp a} msg] $msg -} {1 {bad option ".gorp": must be -displayof, -force, or -lastfor}} -test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix { +} -result {.t.b3} +test focus-1.6 {Tk_FocusCmd procedure} -constraints unix -body { + focus .gorp +} -returnCodes error -result {bad window path name ".gorp"} +test focus-1.7 {Tk_FocusCmd procedure} -constraints unix -body { + focus .gorp a +} -returnCodes error -result {bad option ".gorp": must be -displayof, -force, or -lastfor} +test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} -constraints { + unix +} -setup { + destroy .t2 +} -body { + focusClear toplevel .t2 wm geom .t2 +10+10 frame .t2.f -width 200 -height 100 -bd 2 -relief raised @@ -113,109 +125,146 @@ test focus-1.8 {Tk_FocusCmd procedure, focussing on dead window} unix { destroy .t2.f lappend x [focus] destroy .t2 - set x -} {.t2.f2 .t2 .t2} -test focus-1.9 {Tk_FocusCmd procedure, -displayof option} unix { - list [catch {focus -displayof} msg] $msg -} {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.10 {Tk_FocusCmd procedure, -displayof option} unix { - list [catch {focus -displayof a b} msg] $msg -} {1 {wrong # args: should be "focus -displayof window"}} -test focus-1.11 {Tk_FocusCmd procedure, -displayof option} unix { - list [catch {focus -displayof .lousy} msg] $msg -} {1 {bad window path name ".lousy"}} -test focus-1.12 {Tk_FocusCmd procedure, -displayof option} unix { + return $x +} -cleanup { + destroy .t2 +} -result {.t2.f2 .t2 .t2} +test focus-1.9 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { + focus -displayof +} -returnCodes error -result {wrong # args: should be "focus -displayof window"} +test focus-1.10 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { + focus -displayof a b +} -returnCodes error -result {wrong # args: should be "focus -displayof window"} +test focus-1.11 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { + focus -displayof .lousy +} -returnCodes error -result {bad window path name ".lousy"} +test focus-1.12 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { focusClear focus .t focus -displayof .t.b3 -} {} -test focus-1.13 {Tk_FocusCmd procedure, -displayof option} unix { +} -result {} +test focus-1.13 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix +} -body { focusClear focus -force .t focus -displayof .t.b3 -} {.t} -test focus-1.14 {Tk_FocusCmd procedure, -displayof option} {unix altDisplay} { +} -result {.t} +test focus-1.14 {Tk_FocusCmd procedure, -displayof option} -constraints { + unix altDisplay +} -body { + focusClear focus -force .alt.c focus -displayof .alt -} {.alt.c} -test focus-1.15 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force} msg] $msg -} {1 {wrong # args: should be "focus -force window"}} -test focus-1.16 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force a b} msg] $msg -} {1 {wrong # args: should be "focus -force window"}} -test focus-1.17 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force foo} msg] $msg -} {1 {bad window path name "foo"}} -test focus-1.18 {Tk_FocusCmd procedure, -force option} unix { - list [catch {focus -force ""} msg] $msg -} {0 {}} -test focus-1.19 {Tk_FocusCmd procedure, -force option} unix { +} -result {.alt.c} +test focus-1.15 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force +} -returnCodes error -result {wrong # args: should be "focus -force window"} +test focus-1.16 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force a b +} -returnCodes error -result {wrong # args: should be "focus -force window"} +test focus-1.17 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force foo +} -returnCodes error -result {bad window path name "foo"} +test focus-1.18 {Tk_FocusCmd procedure, -force option} -constraints unix -body { + focus -force "" +} -returnCodes ok -result {} +test focus-1.19 {Tk_FocusCmd procedure, -force option} -constraints unix -body { focusClear focus .t.b1 set x [list [focus]] focus -force .t.b1 lappend x [focus] -} {{} .t.b1} -test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} unix { - list [catch {focus -lastfor} msg] $msg -} {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} unix { - list [catch {focus -lastfor 1 2} msg] $msg -} {1 {wrong # args: should be "focus -lastfor window"}} -test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} unix { - list [catch {focus -lastfor who_knows?} msg] $msg -} {1 {bad window path name "who_knows?"}} -test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} unix { +} -result {{} .t.b1} +test focus-1.20 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focus -lastfor +} -returnCodes error -result {wrong # args: should be "focus -lastfor window"} +test focus-1.21 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focus -lastfor 1 2 +} -returnCodes error -result {wrong # args: should be "focus -lastfor window"} +test focus-1.22 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focus -lastfor who_knows? +} -returnCodes error -result {bad window path name "who_knows?"} +test focus-1.23 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focusClear + focusSetup focus .b focus .t.b1 list [focus -lastfor .] [focus -lastfor .t.b3] -} {.b .t.b1} -test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} unix { - destroy .t +} -result {.b .t.b1} +test focus-1.24 {Tk_FocusCmd procedure, -lastfor option} -constraints { + unix +} -body { + focusClear focusSetup update focus -lastfor .t.b2 -} {.t} -test focus-1.25 {Tk_FocusCmd procedure} unix { - list [catch {focus -unknown} msg] $msg -} {1 {bad option "-unknown": must be -displayof, -force, or -lastfor}} +} -result {.t} +test focus-1.25 {Tk_FocusCmd procedure} -constraints unix -body { + focus -unknown +} -returnCodes error -result {bad option "-unknown": must be -displayof, -force, or -lastfor} + -test focus-2.1 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { +focusSetup +test focus-2.1 {TkFocusFilterEvent procedure} -constraints { + unix nonPortable testwrapper +} -body { + focusClear focus -force .b - destroy .t focusSetup update set focusInfo {} event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor \ -sendevent 0x54217567 - list $focusInfo -} {{}} -test focus-2.2 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { + return $focusInfo +} -result {} +test focus-2.2 {TkFocusFilterEvent procedure} -constraints { + unix nonPortable testwrapper +} -body { + focusClear focus -force .b - destroy .t focusSetup update set focusInfo {} event gen .t <FocusIn> -detail NotifyAncestor -sendevent 0x547321ac list $focusInfo [focus] -} {{in .t NotifyAncestor +} -result {{in .t NotifyAncestor } .b} -test focus-2.3 {TkFocusFilterEvent procedure} {unix nonPortable testwrapper} { +test focus-2.3 {TkFocusFilterEvent procedure} -constraints { + unix nonPortable testwrapper +} -body { + focusClear focus -force .b - destroy .t focusSetup update set focusInfo {} event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor update list $focusInfo [focus -lastfor .t] -} {{out .b NotifyNonlinear +} -result {{out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinear } .t} -test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ - {unix nonPortable testwrapper} { +test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} -constraints { + unix nonPortable testwrapper +} -body { + focusClear set result {} focus .t.b1 # Important to end with NotifyAncestor, which is an @@ -231,8 +280,8 @@ test focus-2.4 {TkFocusFilterEvent procedure, FocusIn events} \ update lappend result $focusInfo } - set result -} {{out . NotifyNonlinear + return $result +} -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } {out . NotifyNonlinear @@ -245,19 +294,22 @@ in .t.b1 NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear }} -test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} \ - {unix nonPortable testwrapper} { +test focus-2.5 {TkFocusFilterEvent procedure, creating FocusInfo struct} -constraints { + unix nonPortable testwrapper +} -body { focusSetup focus .t.b1 update event gen [testwrapper .t] <FocusIn> -detail NotifyAncestor list $focusInfo [focus] -} {{out . NotifyNonlinear +} -result {{out . NotifyNonlinear in .t NotifyNonlinearVirtual in .t.b1 NotifyNonlinear } .t.b1} -test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ - {unix testwrapper} { + +test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} -constraints { + unix testwrapper +} -body { focus .t.b1 focus . update @@ -266,117 +318,131 @@ test focus-2.6 {TkFocusFilterEvent procedure, FocusIn events} \ set x [focus] event gen . <KeyPress-x> list $x $focusInfo -} {.t.b1 {press .t.b1 x}} -test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} \ - {unix testwrapper} { +} -result {.t.b1 {press .t.b1 x}} +test focus-2.7 {TkFocusFilterEvent procedure, FocusOut events} -constraints { + unix testwrapper +} -body { set result {} foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyPointer NotifyPointerRoot NotifyVirtual} { - focus -force .t.b1 - event gen [testwrapper .t] <FocusOut> -detail $detail - update - lappend result [focus] + focus -force .t.b1 + event gen [testwrapper .t] <FocusOut> -detail $detail + update + lappend result [focus] } - set result -} {{} .t.b1 {} {} .t.b1 .t.b1 {}} -test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} \ - {unix testwrapper} { + return $result +} -result {{} .t.b1 {} {} .t.b1 .t.b1 {}} +test focus-2.8 {TkFocusFilterEvent procedure, FocusOut events} -constraints { + unix testwrapper +} -body { focus -force .t.b1 event gen .t.b1 <FocusOut> -detail NotifyAncestor focus -} {.t.b1} -test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} \ - {unix testwrapper} { +} -result {.t.b1} +test focus-2.9 {TkFocusFilterEvent procedure, FocusOut events} -constraints { + unix testwrapper +} -body { focus .t.b1 event gen [testwrapper .] <FocusOut> -detail NotifyAncestor focus -} {} -test focus-2.10 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { +} -result {} +test focus-2.10 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { set result {} focus .t.b1 focusClear foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear - NotifyNonlinearVirtual NotifyVirtual} { - event gen [testwrapper .t] <Enter> -detail $detail -focus 1 - update - lappend result [focus] - event gen [testwrapper .t] <Leave> -detail NotifyAncestor - update + NotifyNonlinearVirtual NotifyVirtual} { + event gen [testwrapper .t] <Enter> -detail $detail -focus 1 + update + lappend result [focus] + event gen [testwrapper .t] <Leave> -detail NotifyAncestor + update } - set result -} {.t.b1 {} .t.b1 .t.b1 .t.b1} -test focus-2.11 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { + return $result +} -result {.t.b1 {} .t.b1 .t.b1 .t.b1} +test focus-2.11 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { focusClear set focusInfo {} event gen [testwrapper .t] <Enter> -detail NotifyAncestor update - set focusInfo -} {} -test focus-2.12 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { + return $focusInfo +} -result {} +test focus-2.12 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { focus -force .b update set focusInfo {} event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 update - set focusInfo -} {} -test focus-2.13 {TkFocusFilterEvent procedure, Enter events} \ - {unix testwrapper} { + return $focusInfo +} -result {} +test focus-2.13 {TkFocusFilterEvent procedure, Enter events} -constraints { + unix testwrapper +} -body { focus .t.b1 focusClear event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 set focusInfo {} update - set focusInfo -} {in .t NotifyVirtual + return $focusInfo +} -result {in .t NotifyVirtual in .t.b1 NotifyAncestor } -test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} {unix testwrapper} { +test focus-2.14 {TkFocusFilterEvent procedure, Enter events, ignore errors when setting focus due to implicit focus} -constraints { + unix testwrapper +} -setup { + destroy .t2 + set focusInfo {} +} -body { focusClear - catch {destroy .t2} toplevel .t2 wm withdraw .t2 update - set focusInfo {} event gen [testwrapper .t2] <Enter> -detail NotifyAncestor -focus 1 update +} -cleanup { destroy .t2 -} {} -test focus-2.15 {TkFocusFilterEvent procedure, Leave events} \ - {unix testwrapper} { +} -result {} +test focus-2.15 {TkFocusFilterEvent procedure, Leave events} -constraints { + unix testwrapper +} -body { set result {} focus .t.b1 foreach detail {NotifyAncestor NotifyInferior NotifyNonlinear NotifyNonlinearVirtual NotifyVirtual} { - focusClear - event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 - update - event gen [testwrapper .t] <Leave> -detail $detail - update - lappend result [focus] + focusClear + event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 + update + event gen [testwrapper .t] <Leave> -detail $detail + update + lappend result [focus] } - set result -} {{} .t.b1 {} {} {}} -test focus-2.16 {TkFocusFilterEvent procedure, Leave events} \ - {unix testwrapper} { - set result {} + return $result +} -result {{} .t.b1 {} {} {}} +test focus-2.16 {TkFocusFilterEvent procedure, Leave events} -constraints { + unix testwrapper +} -body { + focusClear focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 update set focusInfo {} event gen [testwrapper .t] <Leave> -detail NotifyAncestor update - set focusInfo -} {out .t.b1 NotifyAncestor + return $focusInfo +} -result {out .t.b1 NotifyAncestor out .t NotifyVirtual } -test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ - {unix testwrapper} { - set result {} +test focus-2.17 {TkFocusFilterEvent procedure, Leave events} -constraints { + unix testwrapper +} -body { + focusClear focus .t.b1 event gen [testwrapper .t] <Enter> -detail NotifyAncestor -focus 1 update @@ -385,41 +451,49 @@ test focus-2.17 {TkFocusFilterEvent procedure, Leave events} \ event gen [testwrapper .] <Leave> -detail NotifyAncestor update list $focusInfo [focus] -} {{out .t.b1 NotifyAncestor +} -result {{out .t.b1 NotifyAncestor out .t NotifyVirtual } {}} -test focus-3.1 {SetFocus procedure, create record on focus} \ - {unix testwrapper} { + +test focus-3.1 {SetFocus procedure, create record on focus} -constraints { + unix testwrapper +} -body { toplevel .t2 -width 250 -height 100 wm geometry .t2 +0+0 update focus -force .t2 update focus -} {.t2} -catch {destroy .t2} +} -cleanup { + destroy .t2 +} -result {.t2} # This test produces no result, but it will generate a protocol # error if Tk forgets to make the window exist before focussing # on it. -test focus-3.2 {SetFocus procedure, making window exist} {unix testwrapper} { +test focus-3.2 {SetFocus procedure, making window exist} -constraints { + unix testwrapper +} -body { update button .b2 -text "Another button" focus .b2 update -} {} -catch {destroy .b2} -update +} -cleanup { + destroy .b2 + update +} -result {} # The following test doesn't produce a check-able result, but if # there are bugs it may generate an X protocol error. -test focus-3.3 {SetFocus procedure, delaying claim of X focus} \ - {unix testwrapper} { +test focus-3.3 {SetFocus procedure, delaying claim of X focus} -constraints { + unix testwrapper +} -body { focusSetup focus -force .t.b2 update -} {} -test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ - {unix testwrapper} { +} -result {} +test focus-3.4 {SetFocus procedure, delaying claim of X focus} -constraints { + unix testwrapper +} -body { focusSetup wm withdraw .t focus -force .t.b2 @@ -430,52 +504,62 @@ test focus-3.4 {SetFocus procedure, delaying claim of X focus} \ update wm deiconify .t2 wm deiconify .t -} {} -catch {destroy .t2} -test focus-3.5 {SetFocus procedure, generating events} {unix testwrapper} { +} -cleanup { + destroy .t2 +} -result {} +test focus-3.5 {SetFocus procedure, generating events} -constraints { + unix testwrapper +} -body { focusSetup focusClear set focusInfo {} focus -force .t.b2 update - set focusInfo -} {in .t NotifyVirtual + return $focusInfo +} -result {in .t NotifyVirtual in .t.b2 NotifyAncestor } -test focus-3.6 {SetFocus procedure, generating events} {unix testwrapper} { +test focus-3.6 {SetFocus procedure, generating events} -constraints { + unix testwrapper +} -body { focusSetup focus -force .b update set focusInfo {} focus .t.b2 update - set focusInfo -} {out .b NotifyNonlinear + return $focusInfo +} -result {out .b NotifyNonlinear out . NotifyNonlinearVirtual in .t NotifyNonlinearVirtual in .t.b2 NotifyNonlinear } -test focus-3.7 {SetFocus procedure, generating events} \ - {unix nonPortable testwrapper} { +test focus-3.7 {SetFocus procedure, generating events} -constraints { +unix nonPortable testwrapper +} -body { # Non-portable because some platforms generate extra events. - focusSetup focusClear set focusInfo {} focus .t.b2 update - set focusInfo -} {} + return $focusInfo +} -result {} + -test focus-4.1 {TkFocusDeadWindow procedure} {unix testwrapper} { +test focus-4.1 {TkFocusDeadWindow procedure} -constraints { + unix testwrapper +} -body { focusSetup update focus -force .b update destroy .t focus -} {.b} -test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} { +} -result {.b} +test focus-4.2 {TkFocusDeadWindow procedure} -constraints { + unix testwrapper +} -body { focusSetup update focus -force .t.b2 @@ -484,12 +568,12 @@ test focus-4.2 {TkFocusDeadWindow procedure} {unix testwrapper} { destroy .t.b2 update focus -} {.b} - +} -result {.b} # Non-portable due to wm-specific redirection of input focus when # windows are deleted: - -test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} { +test focus-4.3 {TkFocusDeadWindow procedure} -constraints { + unix nonPortable testwrapper +} -body { focusSetup update focus .t @@ -497,21 +581,27 @@ test focus-4.3 {TkFocusDeadWindow procedure} {unix nonPortable testwrapper} { destroy .t update focus -} {} -test focus-4.4 {TkFocusDeadWindow procedure} {unix testwrapper} { +} -result {} +test focus-4.4 {TkFocusDeadWindow procedure} -constraints { + unix testwrapper +} -body { focusSetup focus -force .t.b2 update destroy .t.b2 focus -} {.t} +} -result {.t} +cleanupbg + # I don't know how to test most of the remaining procedures of this file # explicitly; they've already been exercised by the preceding tests. -setupbg -test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ - {unix testwrapper secureserver} { +# Test 5.1 fails (before and after update) +test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} -constraints { + unix testwrapper secureserver +} -body { + setupbg focusSetup focus -force .t update @@ -521,19 +611,21 @@ test focus-5.1 {ChangeXFocus procedure, don't take focus unless have it} \ focus .t.b2 update lappend result [focus] -} {.t {} {}} - -catch {destroy .t} +} -cleanup { + cleanupbg +} -result {.t {} {}} +destroy .t bind all <FocusIn> {} bind all <FocusOut> {} bind all <KeyPress> {} -cleanupbg -fixfocus -test focus-6.1 {miscellaneous - embedded application in same process} \ - {unix testwrapper} { + +fixfocus +test focus-6.1 {miscellaneous - embedded application in same process} -constraints { + unix testwrapper +} -setup { eval interp delete [interp slaves] - catch {destroy .t} +} -body { toplevel .t wm geometry .t +0+0 frame .t.f1 -container 1 @@ -547,11 +639,11 @@ test focus-6.1 {miscellaneous - embedded application in same process} \ child eval "set argv {-use [winfo id .t.f1]}" load {} Tk child child eval { - entry .e1 -bg lightBlue - pack .e1 - bind all <FocusIn> {lappend x "focus in %W %d"} - bind all <FocusOut> {lappend x "focus out %W %d"} - set x {} + entry .e1 -bg lightBlue + pack .e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + set x {} } # Claim the focus and wait long enough for it to really arrive. @@ -577,13 +669,17 @@ test focus-6.1 {miscellaneous - embedded application in same process} \ after 300 {set timer 1} vwait timer set result [list $x [child eval {set x}]] + return $result +} -cleanup { interp delete child - set result -} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} -test focus-6.2 {miscellaneous - embedded application in different process} \ - {unix testwrapper} { - eval interp delete [interp slaves] - catch {destroy .t} + destroy .t + bind all <FocusIn> {} + bind all <FocusOut> {} +} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} + +test focus-6.2 {miscellaneous - embedded application in different process} -constraints { + unix testwrapper +} -body { setupbg toplevel .t wm geometry .t +0+0 @@ -596,11 +692,11 @@ test focus-6.2 {miscellaneous - embedded application in different process} \ bind all <FocusOut> {lappend x "focus out %W %d"} setupbg -use [winfo id .t.f1] dobg { - entry .e1 -bg lightBlue - pack .e1 - bind all <FocusIn> {lappend x "focus in %W %d"} - bind all <FocusOut> {lappend x "focus out %W %d"} - set x {} + entry .e1 -bg lightBlue + pack .e1 + bind all <FocusIn> {lappend x "focus in %W %d"} + bind all <FocusOut> {lappend x "focus out %W %d"} + set x {} } # Claim the focus and wait long enough for it to really arrive. @@ -626,13 +722,17 @@ test focus-6.2 {miscellaneous - embedded application in different process} \ after 300 {set timer 1} vwait timer set result [list $x [dobg {set x}]] + return $result +} -cleanup { + destroy .t cleanupbg - set result -} {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} + bind all <FocusIn> {} + bind all <FocusOut> {} +} -result {{.t.f2.e1 {} {focus out .t.f2.e1 NotifyNonlinear} {focus out .t.f2 NotifyNonlinearVirtual} {focus in .t.f1 NotifyNonlinear} | {focus out .t.f1 NotifyNonlinear} {focus in .t.f2 NotifyNonlinearVirtual} {focus in .t.f2.e1 NotifyNonlinear}} {{focus in . NotifyVirtual} {focus in .e1 NotifyAncestor} | {focus out .e1 NotifyAncestor} {focus out . NotifyVirtual}}} + + deleteWindows -bind all <FocusIn> {} -bind all <FocusOut> {} # cleanup cleanupTests diff --git a/tests/focusTcl.test b/tests/focusTcl.test index 1f5eed5..ef848bb 100644 --- a/tests/focusTcl.test +++ b/tests/focusTcl.test @@ -7,131 +7,262 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test + +option add *takeFocus 1 +option add *highlightThickness 2 +. configure -takefocus 1 -highlightthickness 2 proc setup1 w { if {$w == "."} { - set w "" + set w "" } foreach i {a b c d} { - frame $w.$i -width 200 -height 50 -bd 2 -relief raised - pack $w.$i + destroy $w.$i + frame $w.$i -width 200 -height 50 -bd 2 -relief raised + pack $w.$i } .b configure -width 0 -height 0 foreach i {x y z} { - button $w.b.$i -text "Button $w.b.$i" - pack $w.b.$i -side left + destroy $w.b.$i + button $w.b.$i -text "Button $w.b.$i" + pack $w.b.$i -side left } if {![winfo ismapped $w.b.z]} { - tkwait visibility $w.b.z + tkwait visibility $w.b.z } } -option add *takeFocus 1 -option add *highlightThickness 2 -. configure -takefocus 1 -highlightthickness 2 -test focusTcl-1.1 {tk_focusNext procedure, no children} { +proc cleanup1 w { + if {$w == "."} { + set w "" + } + foreach i {a b c d} { + destroy $w.$i + } + foreach i {x y z} { + destroy $w.b.$i + } +} + + +test focusTcl-1.1 {tk_focusNext procedure, no children} -body { tk_focusNext . -} {.} -setup1 . -test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} { +} -result {.} + +test focusTcl-1.2 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext . -} {.a} -test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.a} +test focusTcl-1.3 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .a -} {.b} -test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b} +test focusTcl-1.4 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b -} {.b.x} -test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.x} +test focusTcl-1.5 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b.x -} {.b.y} -test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-1.6 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b.y -} {.b.z} -test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-1.7 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .b.z -} {.c} -test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.c} +test focusTcl-1.8 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .c -} {.d} -test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.d} +test focusTcl-1.9 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . tk_focusNext .d -} {.} -foreach w {.b .b.x .b.y .c .d} { - $w configure -takefocus 0 -} -test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.} + +test focusTcl-1.10 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . + foreach w {.b .b.x .b.y .c .d} { + $w configure -takefocus 0 + } tk_focusNext .a -} {.b.z} -test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-1.11 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . + foreach w {.b .b.x .b.y .c .d} { + $w configure -takefocus 0 + } tk_focusNext .b.z -} {.} -test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.} + +test focusTcl-1.12 {tk_focusNext procedure, basic tree traversal} -body { + setup1 . deleteWindows setup1 . update . configure -takefocus 0 tk_focusNext .d -} {.a} -. configure -takefocus 1 +} -cleanup { + . configure -takefocus 1 + cleanup1 . +} -result {.a} + + +test focusTcl-2.1 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a -deleteWindows -setup1 . -toplevel .t -wm geom .t +0+0 -toplevel .t2 -wm geom .t2 -0+0 -raise .t .a -test focusTcl-2.1 {tk_focusNext procedure, toplevels} { tk_focusNext .a -} {.b} -test focusTcl-2.2 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.b} +test focusTcl-2.2 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusNext .d -} {.} -test focusTcl-2.3 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.} +test focusTcl-2.3 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusNext .t -} {.t} -setup1 .t -raise .t.b -test focusTcl-2.4 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.t} +test focusTcl-2.4 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + raise .t.b + tk_focusNext .t -} {.t.a} -test focusTcl-2.5 {tk_focusNext procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.t.a} +test focusTcl-2.5 {tk_focusNext procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + raise .t.b + tk_focusNext .t.b.z -} {.t} +} -cleanup { + deleteWindows +} -result {.t} -deleteWindows -test focusTcl-3.1 {tk_focusPrev procedure, no children} { + +test focusTcl-3.1 {tk_focusPrev procedure, no children} -body { tk_focusPrev . -} {.} -setup1 . -test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} { +} -result {.} + +test focusTcl-3.2 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev . -} {.d} -test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.d} +test focusTcl-3.3 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .d -} {.c} -test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.c} +test focusTcl-3.4 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .c -} {.b.z} -test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-3.5 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b.z -} {.b.y} -test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-3.6 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b.y -} {.b.x} -test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b.x} +test focusTcl-3.7 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b.x -} {.b} -test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.b} +test focusTcl-3.8 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .b -} {.a} -test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} { +} -cleanup { + cleanup1 . +} -result {.a} +test focusTcl-3.9 {tk_focusPrev procedure, basic tree traversal} -body { + setup1 . tk_focusPrev .a -} {.} +} -cleanup { + cleanup1 . +} -result {.} + deleteWindows setup1 . @@ -140,35 +271,95 @@ wm geom .t +0+0 toplevel .t2 wm geom .t2 -0+0 raise .t .a -test focusTcl-4.1 {tk_focusPrev procedure, toplevels} { +test focusTcl-4.1 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusPrev . -} {.d} -test focusTcl-4.2 {tk_focusPrev procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.d} +test focusTcl-4.2 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusPrev .b -} {.a} -test focusTcl-4.3 {tk_focusPrev procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.a} +test focusTcl-4.3 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + tk_focusPrev .t -} {.t} -setup1 .t -update -.t configure -takefocus 0 -raise .t.b -test focusTcl-4.4 {tk_focusPrev procedure, toplevels} { +} -cleanup { + deleteWindows +} -result {.t} + +test focusTcl-4.4 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + update + .t configure -takefocus 0 + raise .t.b + tk_focusPrev .t -} {.t.b.z} -test focusTcl-4.5 {tk_focusPrev procedure, toplevels} { - tk_focusPrev .t.a -} {.t.b.z} +} -cleanup { + deleteWindows +} -result {.t.b.z} +test focusTcl-4.5 {tk_focusPrev procedure, toplevels} -setup { + deleteWindows +} -body { + setup1 . + toplevel .t + wm geom .t +0+0 + toplevel .t2 + wm geom .t2 -0+0 + raise .t .a + setup1 .t + update + .t configure -takefocus 0 + raise .t.b -deleteWindows -test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} { + tk_focusPrev .t.a +} -cleanup { deleteWindows +} -result {.t.b.z} + + +test focusTcl-5.1 {tkFocusOK procedure, -takefocus 0} -body { setup1 . .b.x configure -takefocus 0 tk_focusNext .b -} {.b.y} -test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} -body { setup1 . pack forget .b update @@ -176,103 +367,119 @@ test focusTcl-5.2 {tkFocusOK procedure, -takefocus 1} { .b.y configure -takefocus "" .b.z configure -takefocus "" list [tk_focusNext .a] [tk_focusNext .b.x] -} {.c .c} -test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} { +} -cleanup { + cleanup1 . +} -result {.c .c} +test focusTcl-5.3 {tkFocusOK procedure, -takefocus procedure} -body { proc t w { - if {$w == ".b.x"} { - return 1 - } elseif {$w == ".b.y"} { - return "" - } - return 0 + if {$w == ".b.x"} { + return 1 + } elseif {$w == ".b.y"} { + return "" } - deleteWindows + return 0 + } + setup1 . pack forget .b.y update .b configure -takefocus "" foreach w {.b.x .b.y .b.z .c} { - $w configure -takefocus t + $w configure -takefocus t } list [tk_focusNext .a] [tk_focusNext .b.x] -} {.b.x .d} -test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.x .d} +test focusTcl-5.4 {tkFocusOK procedure, -takefocus ""} -body { setup1 . .b.x configure -takefocus "" update tk_focusNext .b -} {.b.x} -test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.x} +test focusTcl-5.5 {tkFocusOK procedure, -takefocus "", not mapped} -body { setup1 . .b.x configure -takefocus "" pack unpack .b.x update tk_focusNext .b -} {.b.y} -test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.6 {tkFocusOK procedure, -takefocus "", not mapped} -body { setup1 . foreach w {.b.x .b.y .b.z} { - $w configure -takefocus "" + $w configure -takefocus "" } pack unpack .b update tk_focusNext .b -} {.c} -test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.c} +test focusTcl-5.7 {tkFocusOK procedure, -takefocus "", not mapped} -body { setup1 . .b.y configure -takefocus 1 pack unpack .b.y update tk_focusNext .b.x -} {.b.z} -test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} { +} -cleanup { + cleanup1 . +} -result {.b.z} +test focusTcl-5.8 {tkFocusOK procedure, -takefocus "", not mapped} -body { proc always args {return 1} - deleteWindows setup1 . .b.y configure -takefocus always pack unpack .b.y update tk_focusNext .b.x -} {.b.y} -test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.9 {tkFocusOK procedure, -takefocus "", window disabled} -body { setup1 . foreach w {.b.x .b.y .b.z} { - $w configure -takefocus "" + $w configure -takefocus "" } update .b.x configure -state disabled tk_focusNext .b -} {.b.y} -test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.b.y} +test focusTcl-5.10 {tkFocusOK procedure, -takefocus "", check for bindings} -body { setup1 . foreach w {.a .b .c .d} { - $w configure -takefocus "" + $w configure -takefocus "" } update bind .a <Key> {foo} list [tk_focusNext .] [tk_focusNext .a] -} {.a .b.x} -test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} { - deleteWindows +} -cleanup { + cleanup1 . +} -result {.a .b.x} +test focusTcl-5.11 {tkFocusOK procedure, -takefocus "", check for bindings} -body { setup1 . foreach w {.a .b .c .d} { - $w configure -takefocus "" + $w configure -takefocus "" } update bind Frame <Key> {foo} list [tk_focusNext .] [tk_focusNext .a] -} {.a .b} +} -cleanup { + cleanup1 . + bind Frame <Key> {} +} -result {.a .b} + -bind Frame <Key> {} . configure -takefocus 0 -highlightthickness 0 option clear # cleanup cleanupTests return + + + diff --git a/tests/font.test b/tests/font.test index 34e4b83..3a2568c 100644 --- a/tests/font.test +++ b/tests/font.test @@ -6,45 +6,18 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -catch {destroy .b} -toplevel .b -wm geom .b +0+0 -update idletasks - -proc setup {} { - catch {destroy .b.f} - catch {eval font delete [font names]} - label .b.f - pack .b.f - update -} - -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font "Courier -12" -pack .b.l -canvas .b.c -closeenough 0 -.b.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" -pack .b.c -update - -set ax [winfo reqwidth .b.l] -set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} -proc csetup {{str ""}} { - focus -force .b.c - .b.c dchars text 0 end - .b.c insert text 0 $str - .b.c focus text -} - -setup +catch {eval font delete [font names]} +deleteWindows +# Toplevel used (in some tests) of the whole file +toplevel .t +wm geom .t +0+0 +update idletasks case [tk windowingsystem] { x11 {set fixed "fixed"} @@ -54,195 +27,242 @@ case [tk windowingsystem] { } -set times [font actual {times 0} -family] +# Procedure used in tests: 24.15, 26.*, 28.*, 30.*, 31.*, 32.1 +proc csetup {{str ""}} { + focus -force .t.c + .t.c dchars text 0 end + .t.c insert text 0 $str + .t.c focus text +} -test font-1.1 {TkFontPkgInit} { + +test font-1.1 {TkFontPkgInit} -setup { catch {interp delete foo} +} -body { interp create foo foo eval { - load {} Tk - wm geometry . +0+0 - update + load {} Tk + wm geometry . +0+0 + update } interp delete foo -} {} +} -result {} -test font-2.1 {TkFontPkgFree} { + +test font-2.1 {TkFontPkgFree} -setup { catch {interp delete foo} - interp create foo set x {} +} -body { + interp create foo # Makes sure that named font was visible only to child interp. - foo eval { - load {} Tk - wm geometry . +0+0 - button .b -font {times 16} -text "hi" - pack .b - font create wiggles -family courier -underline 1 - update + load {} Tk + wm geometry . +0+0 + button .b -font {times 16} -text "hi" + pack .b + font create wiggles -family courier -underline 1 + update } lappend x [catch {font configure wiggles} msg; set msg] # Tests cancelling the idle handler for TheWorldHasChanged, # because app goes away before idle serviced. - foo eval { - .b config -font wiggles - font config wiggles -size 24 - destroy . + .b config -font wiggles + font config wiggles -size 24 + destroy . } lappend x [foo eval {catch {font families} msg; set msg}] +} -cleanup { + interp delete foo +} -result {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} - interp delete foo - set x -} {{named font "wiggles" doesn't exist} {can't invoke "font" command: application has been destroyed}} +test font-3.1 {font command: general} -body { + font +} -returnCodes error -result {wrong # args: should be "font option ?arg?"} +test font-3.2 {font command: general} -body { + font xyz +} -returnCodes error -result {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names} -test font-3.1 {font command: general} { - list [catch {font} msg] $msg -} {1 {wrong # args: should be "font option ?arg?"}} -test font-3.2 {font command: general} { - list [catch {font xyz} msg] $msg -} {1 {bad option "xyz": must be actual, configure, create, delete, families, measure, metrics, or names}} -test font-4.1 {font command: actual: arguments} { +test font-4.1 {font command: actual: arguments} -body { # (skip < 0) - list [catch {font actual xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-4.2 {font command: actual: arguments} { + font actual xyz -displayof +} -returnCodes error -result {value for "-displayof" missing} +test font-4.2 {font command: actual: arguments} -body { # (objc < 3) - list [catch {font actual} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} -test font-4.3 {font command: actual: arguments} { + font actual +} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} +test font-4.3 {font command: actual: arguments} -body { # (objc - skip > 4) when skip == 0 - list [catch {font actual xyz abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} -test font-4.4 {font command: actual: displayof specified, so skip to next} { + font actual xyz abc def +} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} +test font-4.4 {font command: actual: displayof specified, so skip to next} -body { catch {font actual xyz -displayof . -size} -} {0} -test font-4.5 {font command: actual: displayof specified, so skip to next} { +} -result {0} +test font-4.5 {font command: actual: displayof specified, so skip to next} -body { lindex [font actual xyz -displayof .] 0 -} {-family} -test font-4.6 {font command: actual: arguments} { +} -result {-family} +test font-4.6 {font command: actual: arguments} -body { # (objc - skip > 4) when skip == 2 - list [catch {font actual xyz -displayof . abc def} msg] $msg -} {1 {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"}} -test font-4.7 {font command: actual: arguments} {noExceed} { + font actual xyz -displayof . abc def +} -returnCodes error -result {wrong # args: should be "font actual font ?-displayof window? ?option? ?--? ?char?"} +test font-4.7 {font command: actual: arguments} -constraints noExceed -body { # (tkfont == NULL) - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-4.8 {font command: actual: all attributes} { + font actual "\{xyz" +} -returnCodes error -result "font \"{xyz\" doesn't exist" +test font-4.8 {font command: actual: all attributes} -body { # not (objc > 3) so objPtr = NULL lindex [font actual {-family times}] 0 -} {-family} -test font-4.9 {font command: actual} {unix noExceed} { +} -result {-family} +test font-4.9 {font command: actual} -constraints {unix noExceed} -body { # (objc > 3) so objPtr = objv[3 + skip] string tolower [font actual {-family times} -family] -} {times} -test font-4.10 {font command: actual} win { +} -result {times} +test font-4.10 {font command: actual} -constraints win -body { # (objc > 3) so objPtr = objv[3 + skip] font actual {-family times} -family -} {Times New Roman} -test font-4.11 {font command: bad option} { - list [catch {font actual xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} +} -result {Times New Roman} +test font-4.11 {font command: bad option} -body { + font actual xyz -style +} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike} -test font-5.1 {font command: configure} { + +test font-5.1 {font command: configure} -body { # (objc < 3) - list [catch {font configure} msg] $msg -} {1 {wrong # args: should be "font configure fontname ?options?"}} -test font-5.2 {font command: configure: non-existent font} { + font configure +} -returnCodes error -result {wrong # args: should be "font configure fontname ?-option value ...?"} +test font-5.2 {font command: configure: non-existent font} -body { # (namedHashPtr == NULL) - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-5.3 {font command: configure: "deleted" font} { + font configure xyz +} -returnCodes error -result {named font "xyz" doesn't exist} +test font-5.3 {font command: configure: "deleted" font} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { # (nfPtr->deletePending != 0) - setup font create xyz - .b.f configure -font xyz + .t.f configure -font xyz font delete xyz - list [catch {font configure xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-5.4 {font command: configure: get all options} { + font configure xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {named font "xyz" doesn't exist} +test font-5.4 {font command: configure: get all options} -setup { + catch {font delete xyz} +} -body { # (objc == 3) so objPtr = NULL - setup font create xyz -family xyz lindex [font configure xyz] 1 -} xyz -test font-5.5 {font command: configure: get one option} { +} -cleanup { + font delete xyz +} -result xyz +test font-5.5 {font command: configure: get one option} -setup { + catch {eval font delete [font names]} +} -body { # (objc == 4) so objPtr = objv[3] - setup font create xyz -family xyz font configure xyz -family -} xyz -test font-5.6 {font command: configure: update existing font} { + font names +} -cleanup { + font delete xyz +} -result xyz +test font-5.6 {font command: configure: update existing font} -setup { + catch {font delete xyz} +} -body { # else result = ConfigAttributesObj() - setup font create xyz font configure xyz -family xyz update font configure xyz -family -} xyz -test font-5.7 {font command: configure: bad option} { - setup +} -cleanup { + font delete xyz +} -result xyz +test font-5.7 {font command: configure: bad option} -setup { + catch {font delete xyz} +} -body { font create xyz - list [catch {font configure xyz -style} msg] $msg -} {1 {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike}} + font configure xyz -style +} -cleanup { + font delete xyz +} -returnCodes error -result {bad option "-style": must be -family, -size, -weight, -slant, -underline, or -overstrike} + -test font-6.1 {font command: create: make up name} { +test font-6.1 {font command: create: make up name} -setup { + catch {eval font delete [font names]} +} -body { # (objc < 3) so name = NULL - setup font create font names -} {font1} -test font-6.2 {font command: create: name specified} { +} -cleanup { + font delete font1 +} -result {font1} +test font-6.2 {font command: create: name specified} -setup { + catch {eval font delete [font names]} +} -body { # not (objc < 3) - setup font create xyz font names -} {xyz} -test font-6.3 {font command: create: name not really specified} { +} -cleanup { + font delete xyz +} -result {xyz} +test font-6.3 {font command: create: name not really specified} -setup { + catch {eval font delete [font names]} +} -body { # (name[0] == '-') so name = NULL - setup font create -family xyz font names -} {font1} -test font-6.4 {font command: create: generate name} { +} -cleanup { + font delete font1 +} -result {font1} +test font-6.4 {font command: create: generate name} -setup { + catch {eval font delete [font names]} +} -body { # (name == NULL) - setup font create -family one font create -family two font create -family three font delete font2 font create -family four font configure font2 -family -} {four} -test font-6.5 {font command: create: bad option creating new font} { +} -cleanup { + catch {eval font delete [font names]} +} -result {four} +test font-6.5 {font command: create: bad option creating new font} -setup { + catch {font delete xyz} +} -body { # name was specified so skip = 3 - setup - list [catch {font create xyz -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-6.6 {font command: create: bad option creating new font} { + font create xyz -xyz times +} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} +test font-6.6 {font command: create: bad option creating new font} -setup { + catch {eval font delete [font names]} +} -body { # name was not specified so skip = 2 - setup - list [catch {font create -xyz times} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-6.7 {font command: create: already exists} { + font create -xyz times +} -returnCodes error -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} +test font-6.7 {font command: create: already exists} -setup { + catch {font delete xyz} +} -body { # (CreateNamedFont() != TCL_OK) - setup font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} + font create xyz +} -cleanup { + font delete xyz +} -returnCodes error -result {named font "xyz" already exists} -test font-7.1 {font command: delete: arguments} { +test font-7.1 {font command: delete: arguments} -body { # (objc < 3) - list [catch {font delete} msg] $msg -} {1 {wrong # args: should be "font delete fontname ?fontname ...?"}} -test font-7.2 {font command: delete: loop test} { + font delete +} -returnCodes error -result {wrong # args: should be "font delete fontname ?fontname ...?"} +test font-7.2 {font command: delete: loop test} -setup { + catch {eval font delete [font names]} + set x {} +} -body { # for (i = 2; i < objc; i++) - setup - set x {} font create a -underline 1 font create b -underline 1 font create c -underline 1 @@ -251,11 +271,14 @@ test font-7.2 {font command: delete: loop test} { lappend x [lsort [font names]] font delete a e c b lappend x [lsort [font names]] -} {{a b c d e} d} -test font-7.3 {font command: delete: loop test} { +} -cleanup { + catch {eval font delete [font names]} +} -result {{a b c d e} d} +test font-7.3 {font command: delete: loop test} -setup { + catch {eval font delete [font names]} + set x {} +} -body { # (namedHashPtr == NULL) in middle of loop - setup - set x {} font create a -underline 1 font create b -underline 1 font create c -underline 1 @@ -264,299 +287,440 @@ test font-7.3 {font command: delete: loop test} { lappend x [lsort [font names]] catch {font delete a d q c e b} lappend x [lsort [font names]] -} {{a b c d e} {b c e}} -test font-7.4 {font command: delete: non-existent} { +} -cleanup { + catch {eval font delete [font names]} +} -result {{a b c d e} {b c e}} +test font-7.4 {font command: delete: non-existent} -setup { + catch {font delete xyz} +} -body { # (namedHashPtr == NULL) - setup - list [catch {font delete xyz} msg] $msg -} {1 {named font "xyz" doesn't exist}} -test font-7.5 {font command: delete: mark for later deletion} { + font delete xyz +} -returnCodes error -result {named font "xyz" doesn't exist} +test font-7.5 {font command: delete: mark for later deletion} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { # (nfPtr->refCount != 0) - setup font create xyz - .b.f configure -font xyz + .t.f configure -font xyz font delete xyz font actual xyz - list [catch {font configure xyz} msg] $msg [.b.f cget -font] -} {1 {named font "xyz" doesn't exist} xyz} -test font-7.6 {font command: delete: actually delete} { + font configure xyz +} -cleanup { + destroy .t.f +} -returnCodes error -result {named font "xyz" doesn't exist} +test font-7.6 {font command: delete: mark for later deletion} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { + # (nfPtr->refCount != 0) + font create xyz + .t.f configure -font xyz + font delete xyz + font actual xyz + catch {font configure xyz} + .t.f cget -font +} -cleanup { + destroy .t.f +} -result xyz +test font-7.7 {font command: delete: actually delete} -setup { + catch {font delete xyz} +} -body { # not (nfPtr->refCount != 0) - setup font create xyz -underline 1 font delete xyz - catch {font config xyz} -} {1} -setup + font config xyz +} -returnCodes error -match glob -result {*} -test font-8.1 {font command: families: arguments} { + +test font-8.1 {font command: families: arguments} -body { # (skip < 0) - list [catch {font families -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-8.2 {font command: families: arguments} { + font families -displayof +} -returnCodes error -result {value for "-displayof" missing} +test font-8.2 {font command: families: arguments} -body { # (objc - skip != 2) when skip == 0 - list [catch {font families xyz} msg] $msg -} {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-8.3 {font command: families: arguments} { + font families xyz +} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"} +test font-8.3 {font command: families: arguments} -body { # (objc - skip != 2) when skip == 2 - list [catch {font families -displayof . xyz} msg] $msg -} {1 {wrong # args: should be "font families ?-displayof window?"}} -test font-8.4 {font command: families} { + font families -displayof . xyz +} -returnCodes error -result {wrong # args: should be "font families ?-displayof window?"} +test font-8.4 {font command: families} -body { # TkpGetFontFamilies() regexp -nocase times [font families] -} {1} +} -result 1 + -test font-9.1 {font command: measure: arguments} { +test font-9.1 {font command: measure: arguments} -body { # (skip < 0) - list [catch {expr {[font measure xyz -displayof]>0}} msg] $msg -} {0 1} -test font-9.2 {font command: measure: arguments} { + expr {[font measure xyz -displayof] > 0} +} -returnCodes ok -result 1 +test font-9.2 {font command: measure: arguments} -body { # (objc - skip != 4) - list [catch {font measure} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-9.3 {font command: measure: arguments} { + font measure +} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} +test font-9.3 {font command: measure: arguments} -body { # (objc - skip != 4) - list [catch {font measure xyz abc def} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} -test font-9.4 {font command: measure: arguments} {noExceed} { + font measure xyz abc def +} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} +test font-9.4 {font command: measure: arguments} -constraints noExceed -body { # (tkfont == NULL) - list [catch {font measure "\{xyz" abc} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-9.5 {font command: measure} { + font measure "\{xyz" abc +} -returnCodes error -result "font \"{xyz\" doesn't exist" +test font-9.5 {font command: measure} -body { # Tk_TextWidth() - expr [font measure $fixed "abcdefg"]==[font measure $fixed "a"]*7 -} {1} -test font-9.6 {font command: measure -d} { - list [catch {expr {[font measure $fixed -d] > 0}} msg] $msg -} {0 1} -test font-9.7 {font command: measure -d with -displayof} { - list [catch {expr {[font measure $fixed -displayof . -d] > 0}} msg] $msg -} {0 1} -test font-9.8 {font command: measure: arguments} { - list [catch {font measure $fixed -displayof .} msg] $msg -} {1 {wrong # args: should be "font measure font ?-displayof window? text"}} - -test font-10.1 {font command: metrics: arguments} { - list [catch {font metrics xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-10.2 {font command: metrics: arguments} { + expr {[font measure $fixed "abcdefg"] == [font measure $fixed "a"]*7 } +} -result 1 +test font-9.6 {font command: measure -d} -body { + expr {[font measure $fixed -d] > 0} +} -returnCodes ok -result 1 +test font-9.7 {font command: measure -d with -displayof} -body { + expr {[font measure $fixed -displayof . -d] > 0} +} -returnCodes ok -result 1 +test font-9.8 {font command: measure: arguments} -body { + font measure $fixed -displayof . +} -returnCodes error -result {wrong # args: should be "font measure font ?-displayof window? text"} + + +test font-10.1 {font command: metrics: arguments} -body { + font metrics xyz -displayof +} -returnCodes error -result {value for "-displayof" missing} +test font-10.2 {font command: metrics: arguments} -body { # (skip < 0) - list [catch {font metrics xyz -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test font-10.3 {font command: metrics: arguments} { + font metrics xyz -displayof +} -returnCodes error -result {value for "-displayof" missing} +test font-10.3 {font command: metrics: arguments} -body { # (objc < 3) - list [catch {font metrics} msg] $msg -} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-10.4 {font command: metrics: arguments} { + font metrics +} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} +test font-10.4 {font command: metrics: arguments} -body { # (objc - skip) > 4) when skip == 0 - list [catch {font metrics xyz abc def} msg] $msg -} {1 {wrong # args: should be "font metrics font ?-displayof window? ?option?"}} -test font-10.5 {font command: metrics: arguments} { + font metrics xyz abc def +} -returnCodes error -result {wrong # args: should be "font metrics font ?-displayof window? ?option?"} +test font-10.5 {font command: metrics: arguments} -body { # (objc - skip) > 4) when skip == 2 - list [catch {font metrics xyz -displayof . abc} msg] $msg -} {1 {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed}} -test font-10.6 {font command: metrics: bad font} {noExceed} { + font metrics xyz -displayof . abc +} -returnCodes error -result {bad metric "abc": must be -ascent, -descent, -linespace, or -fixed} +test font-10.6 {font command: metrics: bad font} -constraints noExceed -body { # (tkfont == NULL) - list [catch {font metrics "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-10.7 {font command: metrics: get all metrics} { - # (objc == 3) + font metrics "\{xyz" +} -returnCodes error -result "font \"{xyz\" doesn't exist" +test font-10.7 {font command: metrics: get all metrics} -setup { catch {unset a} +} -body { + # (objc == 3) array set a [font metrics {-family xyz}] - set x [lsort [array names a]] + lsort [array names a] +} -cleanup { unset a - set x -} {-ascent -descent -fixed -linespace} -test font-10.8 {font command: metrics: bad metric} { +} -result {-ascent -descent -fixed -linespace} +test font-10.8 {font command: metrics: bad metric} -body { # (Tcl_GetIndexFromObj() != TCL_OK) - list [catch {font metrics $fixed -xyz} msg] $msg -} {1 {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed}} -test font-10.9 {font command: metrics: get individual metrics} { + font metrics $fixed -xyz +} -returnCodes error -result {bad metric "-xyz": must be -ascent, -descent, -linespace, or -fixed} +test font-10.9 {font command: metrics: get individual metrics} -body { font metrics $fixed -ascent font metrics $fixed -descent font metrics $fixed -linespace font metrics $fixed -fixed -} {1} +} -result 1 + -test font-11.1 {font command: names: arguments} { +test font-11.1 {font command: names: arguments} -body { # (objc != 2) - list [catch {font names xyz} msg] $msg -} {1 {wrong # args: should be "font names"}} -test font-11.2 {font command: names: loop test: no passes} { - setup + font names xyz +} -returnCodes error -result {wrong # args: should be "font names"} +test font-11.2 {font command: names: loop test: no passes} -setup { + catch {eval font delete [font names]} +} -body { font names -} {} -test font-11.3 {font command: names: loop test: one pass} { - setup +} -result {} +test font-11.3 {font command: names: loop test: one pass} -setup { + catch {eval font delete [font names]} +} -body { font create font names -} {font1} -test font-11.4 {font command: names: loop test: multiple passes} { - setup +} -result {font1} +test font-11.4 {font command: names: loop test: multiple passes} -setup { + catch {eval font delete [font names]} +} -body { font create xyz font create abc font create def lsort [font names] -} {abc def xyz} -test font-11.5 {font command: names: skip deletePending fonts} { - # (nfPtr->deletePending == 0) - setup +} -cleanup { + catch {eval font delete [font names]} +} -result {abc def xyz} +test font-11.5 {font command: names: skip deletePending fonts} -setup { + destroy .t.f + catch {eval font delete [font names]} + pack [label .t.f] + update set x {} +} -body { + # (nfPtr->deletePending == 0) font create xyz font create abc lappend x [lsort [font names]] - .b.f config -font xyz + .t.f config -font xyz font delete xyz lappend x [font names] -} {{abc xyz} abc} +} -cleanup { + catch {eval font delete [font names]} +} -result {{abc xyz} abc} -test font-12.1 {UpdateDependantFonts procedure: no users} { + +test font-12.1 {UpdateDependantFonts procedure: no users} -setup { + catch {font delete xyz} +} -body { # (nfPtr->refCount == 0) - setup font create xyz font configure xyz -family times -} {} -test font-12.2 {UpdateDependantFonts procedure: pings the widgets} { - setup +} -cleanup { + font delete xyz +} -result {} +test font-12.2 {UpdateDependantFonts procedure: pings the widgets} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { font create xyz -family times -size 20 - .b.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 + .t.f config -font xyz -text "abcd" -padx 0 -bd 0 -highlightthickness 0 set a1 [font measure xyz "abcd"] update - set b1 [winfo reqwidth .b.f] + set b1 [winfo reqwidth .t.f] font configure xyz -family helvetica -size 20 set a2 [font measure xyz "abcd"] update - set b2 [winfo reqwidth .b.f] + set b2 [winfo reqwidth .t.f] expr {$a1==$b1 && $a2==$b2} -} {1} +} -cleanup { + destroy .t.f + font delete xyz +} -result {1} + -test font-13.1 {CreateNamedFont: new named font} { +test font-13.1 {CreateNamedFont: new named font} -setup { + catch {font delete xyz} + set x {} +} -body { # not (new == 0) - setup - set x {} lappend x [font names] font create xyz lappend x [font names] -} {{} xyz} -test font-13.2 {CreateNamedFont: named font already exists} { +} -cleanup { + font delete xyz +} -result {{} xyz} +test font-13.2 {CreateNamedFont: named font already exists} -setup { + catch {font delete xyz} +} -body { # (new == 0) - setup font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} -test font-13.3 {CreateNamedFont: named font already exists} { + font create xyz +} -cleanup { + font delete xyz +} -returnCodes error -result {named font "xyz" already exists} +test font-13.3 {CreateNamedFont: named font already exists} -setup { + catch {font delete xyz} +} -body { # (nfPtr->deletePending == 0) - setup font create xyz - list [catch {font create xyz} msg] $msg -} {1 {named font "xyz" already exists}} -test font-13.4 {CreateNamedFont: recreate "deleted" font} { + font create xyz +} -cleanup { + font delete xyz +} -returnCodes error -result {named font "xyz" already exists} +test font-13.4 {CreateNamedFont: recreate "deleted" font} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { # not (nfPtr->deletePending == 0) - setup font create xyz -family times - .b.f configure -font xyz + .t.f configure -font xyz font delete xyz font create xyz -family courier font configure xyz -family -} {courier} +} -cleanup { + font delete xyz + destroy .t.f +} -result {courier} + + +test font-14.1 {Tk_GetFont procedure} -body { +} -result {} -test font-14.1 {Tk_GetFont procedure} { -} {} -test font-15.1 {Tk_AllocFontFromObj - converting internal reps} testfont { +test font-15.1 {Tk_AllocFontFromObj - converting internal reps} -constraints { + testfont +} -setup { + destroy .b1 .b2 +} -body { set x {Times 16} lindex $x 0 - destroy .b1 .b2 button .b1 -font $x lindex $x 0 testfont counts {Times 16} -} {{1 0}} -test font-15.2 {Tk_AllocFontFromObj - discard stale font} testfont { - set x {Times 16} +} -cleanup { + destroy .b1 .b2 +} -result {{1 0}} +test font-15.2 {Tk_AllocFontFromObj - discard stale font} -constraints { + testfont +} -setup { destroy .b1 .b2 + set result {} +} -body { + set x {Times 16} button .b1 -font $x destroy .b1 - set result {} lappend result [testfont counts {Times 16}] button .b2 -font $x lappend result [testfont counts {Times 16}] -} {{} {{1 1}}} -test font-15.3 {Tk_AllocFontFromObj - reuse existing font} testfont { - set x {Times 16} +} -cleanup { + destroy .b2 +} -result {{} {{1 1}}} +test font-15.3 {Tk_AllocFontFromObj - reuse existing font} -constraints { + testfont +} -setup { destroy .b1 .b2 - button .b1 -font $x set result {} +} -body { + set x {Times 16} + button .b1 -font $x lappend result [testfont counts {Times 16}] button .b2 -font $x pack .b1 .b2 -side top lappend result [testfont counts {Times 16}] -} {{{1 1}} {{2 1}}} -test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} { +} -cleanup { + destroy .b1 .b2 +} -result {{{1 1}} {{2 1}}} +test font-15.4 {Tk_AllocFontFromObj procedure: bump ref count} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { # (new == 0) - setup - .b.f config -font {-family fixed} + .t.f config -font {-family fixed} lindex [font actual {-family fixed}] 0 -} {-family} -test font-15.5 {Tk_AllocFontFromObj procedure: get named font} { +} -cleanup { + destroy .t.f +} -result {-family} +test font-15.5 {Tk_AllocFontFromObj procedure: get named font} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { # (namedHashPtr != NULL) - setup font create xyz - .b.f config -font xyz -} {} -test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} { + .t.f config -font xyz +} -cleanup { + destroy .t.f + font delete xyz +} -result {} +test font-15.6 {Tk_AllocFontFromObj procedure: not a named font} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { # not (namedHashPtr != NULL) - setup - .b.f config -font {times 20} -} {} -test font-15.7 {Tk_AllocFontFromObj procedure: get native font} unix { + .t.f config -font {times 20} +} -cleanup { + destroy .t.f +} -result {-family} -result {} +test font-15.7 {Tk_AllocFontFromObj procedure: get native font} -constraints { + unix +} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { # not (fontPtr == NULL) - setup - .b.f config -font fixed -} {} -test font-15.8 {Tk_AllocFontFromObj procedure: get native font} win { + .t.f config -font fixed +} -result {} +test font-15.8 {Tk_AllocFontFromObj procedure: get native font} -constraints { + win +} -setup { + destroy .t.f + catch {eval font delete [font names]} + pack [label .t.f] + update +} -body { # not (fontPtr == NULL) - setup - .b.f config -font oemfixed -} {} -test font-15.10 {Tk_AllocFontFromObj procedure: get attribute font} { + .t.f config -font oemfixed +} -cleanup { + destroy .t.f +} -result {} +test font-15.9 {Tk_AllocFontFromObj procedure: get attribute font} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { # (fontPtr == NULL) - list [catch {.b.f config -font {xxx yyy zzz}} msg] $msg -} {1 {expected integer but got "yyy"}} -test font-15.11 {Tk_AllocFontFromObj procedure: no match} {noExceed} { + .t.f config -font {xxx yyy zzz} +} -cleanup { + destroy .t.f +} -returnCodes error -result {expected integer but got "yyy"} +test font-15.10 {Tk_AllocFontFromObj procedure: no match} -constraints noExceed -body { # (ParseFontNameObj() != TCL_OK) - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-15.12 {Tk_AllocFontFromObj procedure: get attribute font} { + font actual "\{xyz" +} -returnCodes error -result "font \"{xyz\" doesn't exist" +test font-15.11 {Tk_AllocFontFromObj procedure: get attribute font} -body { # not (ParseFontNameObj() != TCL_OK) lindex [font actual {plan 9}] 0 -} {-family} -test font-15.13 {Tk_AllocFontFromObj procedure: setup tab width} { +} -result {-family} +test font-15.12 {Tk_AllocFontFromObj procedure: setup tab width} -setup { + destroy .l +} -body { # Tk_MeasureChars(fontPtr, "0", ...) label .l -bd 0 -padx 0 -highlightthickness 0 -font $fixed -text "a\tb" update - set x [winfo reqwidth .l] - destroy .l - set x -} [expr [font measure $fixed "0"]*9] -test font-15.14 {Tk_AllocFontFromObj procedure: underline position} { + set res1 [winfo reqwidth .l] + set res2 [expr [font measure $fixed "0"]*9] + expr {$res1 eq $res2} +} -cleanup { + destroy .l +} -result 1 +test font-15.13 {Tk_AllocFontFromObj procedure: underline position} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { # (fontPtr->underlineHeight == 0) because size was < 10 - setup - .b.f config -text "underline" -font "times -8 underline" + .t.f config -text "underline" -font "times -8 underline" update -} {} +} -cleanup { + destroy .t.f +} -result {} -test font-16.1 {Tk_NameOfFont procedure} { - setup - .b.f config -font -family\ fixed - .b.f cget -font -} {-family fixed} -test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { - set x {Courier 12} +test font-16.1 {Tk_NameOfFont procedure} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { + .t.f config -font -family\ fixed + .t.f cget -font +} -cleanup { + destroy .t.f +} -result {-family fixed} + + +test font-17.1 {Tk_FreeFontFromObj - reference counts} -constraints { + testfont +} -setup { destroy .b1 .b2 .b3 + set result {} +} -body { + set x {Courier 12} button .b1 -font $x button .b3 -font $x button .b2 -font $x - set result {} lappend result [testfont counts {Courier 12}] destroy .b1 lappend result [testfont counts {Courier 12}] @@ -564,61 +728,83 @@ test font-17.1 {Tk_FreeFontFromObj - reference counts} testfont { lappend result [testfont counts {Courier 12}] destroy .b3 lappend result [testfont counts {Courier 12}] -} {{{3 1}} {{2 1}} {{1 1}} {}} -test font-17.2 {Tk_FreeFont procedure: one ref} { +} -result {{{3 1}} {{2 1}} {{1 1}} {}} +test font-17.2 {Tk_FreeFont procedure: one ref} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { # (fontPtr->refCount == 0) - setup - .b.f config -font {-family fixed} - destroy .b.f -} {} -test font-17.3 {Tk_FreeFont procedure: multiple ref} { + .t.f config -font {-family fixed} + destroy .t.f +} -result {} +test font-17.3 {Tk_FreeFont procedure: multiple ref} -setup { + destroy .t.f .t.b + pack [label .t.f] + update +} -body { # not (fontPtr->refCount == 0) - setup - .b.f config -font {-family fixed} - button .b.b -font {-family fixed} - destroy .b.f - set x [.b.b cget -font] - destroy .b.b - set x -} {-family fixed} -test font-17.4 {Tk_FreeFont procedure: named font} { + .t.f config -font {-family fixed} + button .t.b -font {-family fixed} + destroy .t.f + .t.b cget -font +} -cleanup { + destroy .t.b +} -result {-family fixed} +test font-17.4 {Tk_FreeFont procedure: named font} -setup { + destroy .t.f + catch {eval font delete [font names]} + pack [label .t.f] + update +} -body { # (fontPtr->namedHashPtr != NULL) - setup font create xyz - .b.f config -font xyz - destroy .b.f + .t.f config -font xyz + destroy .t.f font names -} {xyz} -test font-17.5 {Tk_FreeFont procedure: named font} { +} -result {xyz} +test font-17.5 {Tk_FreeFont procedure: named font} -setup { + destroy .t.f + catch {font delete xyz} + pack [label .t.f] + update +} -body { # not (fontPtr->refCount == 0) - setup font create xyz -underline 1 - .b.f config -font xyz + .t.f config -font xyz font delete xyz set x [font actual xyz -underline] - destroy .b.f + destroy .t.f list [font actual xyz -underline] $x -} {0 1} -test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} { - setup +} -result {0 1} +test font-17.6 {Tk_FreeFont procedure: named font not deleted yet} -setup { + destroy .t.f .t.b + catch {font delete xyz} + pack [label .t.f] + update +} -body { font create xyz - .b.f config -font xyz - button .b.b -font xyz + .t.f config -font xyz + button .t.b -font xyz font delete xyz set x [font actual xyz] - destroy .b.b + destroy .t.b list [lindex [font actual xyz] 0] [lindex $x 0] -} {-family -family} +} -cleanup { + destroy .t.f +} -result {-family -family} -test font-18.1 {FreeFontObjProc} testfont { + +test font-18.1 {FreeFontObjProc} -constraints testfont -setup { destroy .b1 + set result {} +} -body { set x [format {Courier 12}] button .b1 -font $x set y [format {Courier 12}] .b1 configure -font $y set z [format {Courier 12}] .b1 configure -font $z - set result {} lappend result [testfont counts {Courier 12}] set x red lappend result [testfont counts {Courier 12}] @@ -627,275 +813,864 @@ test font-18.1 {FreeFontObjProc} testfont { destroy .b1 lappend result [testfont counts {Courier 12}] set y bogus - set result -} {{{1 3}} {{1 2}} {{1 1}} {}} + return $result +} -result {{{1 3}} {{1 2}} {{1 1}} {}} + -test font-19.1 {Tk_FontId} { - .b.f config -font "times 20" +test font-19.1 {Tk_FontId} -setup { + destroy .t.f + pack [label .t.f] update -} {} +} -body { + .t.f config -font "times 20" + update +} -cleanup { + destroy .t.f +} -result {} + -test font-20.1 {Tk_GetFontMetrics procedure} { - button .b.w1 -text abc - entry .b.w2 -text abcd +test font-20.1 {Tk_GetFontMetrics procedure} -setup { + destroy .t.w1 .t.w2 +} -body { + button .t.w1 -text abc + entry .t.w2 -text abcd update - destroy .b.w1 .b.w2 -} {} + destroy .t.w1 .t.w2 +} -result {} + +# Procedure used in 21.* tests proc psfontname {name} { - set a [.b.c itemcget text -font] - .b.c itemconfig text -text "We need text" -font $name - set post [.b.c postscript] - .b.c itemconfig text -font $a + destroy .t.c + canvas .t.c -closeenough 0 + .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" + pack .t.c + update + set a [.t.c itemcget text -font] + .t.c itemconfig text -text "We need text" -font $name + set post [.t.c postscript] + .t.c itemconfig text -font $a set end [string first "findfont" $post] incr end -2 set post [string range $post [expr $end-70] $end] set start [string first "gsave" $post] + destroy .t.c return [string range $post [expr $start+7] end] } -test font-21.1 {Tk_PostscriptFontName procedure: native} unix { +test font-21.1 {Tk_PostscriptFontName procedure: native} -constraints { + unix +} -body { set x [font actual {{itc avant garde} 10} -family] if {[string match *avant*garde $x]} { - psfontname "{itc avant garde} 10" + psfontname "{itc avant garde} 10" } else { - set x {AvantGarde-Book} + set x {AvantGarde-Book} } -} {AvantGarde-Book} -test font-21.2 {Tk_PostscriptFontName procedure: native} win { +} -result {AvantGarde-Book} +test font-21.2 {Tk_PostscriptFontName procedure: native} -constraints { + win +} -body { psfontname "arial 10" -} {Helvetica} -test font-21.3 {Tk_PostscriptFontName procedure: native} win { +} -result {Helvetica} +test font-21.3 {Tk_PostscriptFontName procedure: native} -constraints { + win +} -body { psfontname "{times new roman} 10" -} {Times-Roman} -test font-21.4 {Tk_PostscriptFontName procedure: native} win { +} -result {Times-Roman} +test font-21.4 {Tk_PostscriptFontName procedure: native} -constraints { + win +} -body { psfontname "{courier new} 10" -} {Courier} -test font-21.8 {Tk_PostscriptFontName procedure: spaces} unix { +} -result {Courier} +test font-21.5 {Tk_PostscriptFontName procedure: spaces} -constraints { + unix +} -body { set x [font actual {{lucida bright} 10} -family] if {[string match lucida*bright $x]} { - psfontname "{lucida bright} 10" + psfontname "{lucida bright} 10" } else { - set x {LucidaBright} + set x {LucidaBright} } -} {LucidaBright} -test font-21.9 {Tk_PostscriptFontName procedure: spaces} unix { +} -result {LucidaBright} +test font-21.6 {Tk_PostscriptFontName procedure: spaces} -constraints { + unix +} -body { psfontname "{new century schoolbook} 10" -} {NewCenturySchlbk-Roman} -set i 10 -foreach p { - {font-21.10 "avantgarde" - AvantGarde-Book AvantGarde-Demi - AvantGarde-BookOblique AvantGarde-DemiOblique} - {font-21.11 "bookman" - Bookman-Light Bookman-Demi Bookman-LightItalic Bookman-DemiItalic} - {font-21.12 "courier" - Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {font-21.13 "helvetica" - Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {font-21.14 "new century schoolbook" - NewCenturySchlbk-Roman NewCenturySchlbk-Bold - NewCenturySchlbk-Italic NewCenturySchlbk-BoldItalic} - {font-21.15 "palatino" - Palatino-Roman Palatino-Bold Palatino-Italic Palatino-BoldItalic} - {font-21.16 "symbol" - Symbol Symbol Symbol Symbol} - {font-21.17 "times" - Times-Roman Times-Bold Times-Italic Times-BoldItalic} - {font-21.18 "zapfchancery" - ZapfChancery-MediumItalic ZapfChancery-MediumItalic - ZapfChancery-MediumItalic ZapfChancery-MediumItalic} - {font-21.19 "zapfdingbats" - ZapfDingbats ZapfDingbats ZapfDingbats ZapfDingbats} -} { - set values [lassign $p testName family] - test $testName {Tk_PostscriptFontName procedure: exhaustive} unix { - set x {} - set j 0 - foreach slant {roman italic} { - foreach weight {normal bold} { - set name [list $family 12 $slant $weight] - if {[font actual $name -family] == $family} { - lappend x [psfontname $name] - } else { - lappend x [lindex $values $j] - } - incr j - } - } - set x - } $values -} -foreach p { - {font-21.20 "arial" - Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {font-21.21 "courier new" - Courier Courier-Bold Courier-Oblique Courier-BoldOblique} - {font-21.22 "helvetica" - Helvetica Helvetica-Bold Helvetica-Oblique Helvetica-BoldOblique} - {font-21.23 "symbol" - Symbol Symbol-Bold Symbol-Italic Symbol-BoldItalic} - {font-21.24 "times new roman" - Times-Roman Times-Bold Times-Italic Times-BoldItalic} -} { - set values [lassign $p testName family] - test $testName {Tk_PostscriptFontName procedure: exhaustive} win { - set x {} - foreach slant {roman italic} { - foreach weight {normal bold} { - lappend x [psfontname [list $family 12 "$slant $weight"]] - } - } - set x - } $values -} +} -result {NewCenturySchlbk-Roman} + +test font-21.7 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {avantgarde 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x AvantGarde-Book + } +} -result {AvantGarde-Book} +test font-21.8 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {avantgarde 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x AvantGarde-Demi + } +} -result {AvantGarde-Demi} +test font-21.9 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {avantgarde 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x AvantGarde-BookOblique + } +} -result {AvantGarde-BookOblique} +test font-21.10 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {avantgarde 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "avantgarde"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x AvantGarde-DemiOblique + } +} -result {AvantGarde-DemiOblique} + +test font-21.11 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {bookman 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Bookman-Light + } +} -result {Bookman-Light} +test font-21.12 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {bookman 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Bookman-Demi + } +} -result {Bookman-Demi} +test font-21.13 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {bookman 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Bookman-LightItalic + } +} -result {Bookman-LightItalic} +test font-21.14 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {bookman 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "bookman"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Bookman-DemiItalic + } +} -result {Bookman-DemiItalic} + +test font-21.15 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {courier 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Courier + } +} -result {Courier} +test font-21.16 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {courier 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Courier-Bold + } +} -result {Courier-Bold} +test font-21.17 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {courier 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Courier-Oblique + } +} -result {Courier-Oblique} +test font-21.18 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {courier 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "courier"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Courier-BoldOblique + } +} -result {Courier-BoldOblique} + +test font-21.19 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {helvetica 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Helvetica + } +} -result {Helvetica} +test font-21.20 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {helvetica 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Helvetica-Bold + } +} -result {Helvetica-Bold} +test font-21.21 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {helvetica 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Helvetica-Oblique + } +} -result {Helvetica-Oblique} +test font-21.22 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {helvetica 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "helvetica"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Helvetica-BoldOblique + } +} -result {Helvetica-BoldOblique} + +test font-21.23 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {{new century schoolbook} 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x NewCenturySchlbk-Roman + } +} -result {NewCenturySchlbk-Roman} +test font-21.24 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {{new century schoolbook} 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x NewCenturySchlbk-Bold + } +} -result {NewCenturySchlbk-Bold} +test font-21.25 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {{new century schoolbook} 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x NewCenturySchlbk-Italic + } +} -result {NewCenturySchlbk-Italic} +test font-21.26 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {{new century schoolbook} 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "new century schoolbook"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x NewCenturySchlbk-BoldItalic + } +} -result {NewCenturySchlbk-BoldItalic} + +test font-21.27 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {palatino 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Palatino-Roman + } +} -result {Palatino-Roman} +test font-21.28 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {palatino 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Palatino-Bold + } +} -result {Palatino-Bold} +test font-21.29 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {palatino 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Palatino-Italic + } +} -result {Palatino-Italic} +test font-21.30 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {palatino 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "palatino"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Palatino-BoldItalic + } +} -result {Palatino-BoldItalic} + +test font-21.31 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {symbol 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Symbol + } +} -result {Symbol} +test font-21.32 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {symbol 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Symbol + } +} -result {Symbol} +test font-21.33 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {symbol 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Symbol + } +} -result {Symbol} +test font-21.34 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {symbol 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "symbol"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Symbol + } +} -result {Symbol} + +test font-21.35 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {times 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "times"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Times-Roman + } +} -result {Times-Roman} +test font-21.36 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {times 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "times"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Times-Bold + } +} -result {Times-Bold} +test font-21.37 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {times 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "times"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Times-Italic + } +} -result {Times-Italic} +test font-21.38 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {times 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "times"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x Times-BoldItalic + } +} -result {Times-BoldItalic} + +test font-21.39 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfchancery 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfChancery-MediumItalic + } +} -result {ZapfChancery-MediumItalic} +test font-21.40 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfchancery 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfChancery-MediumItalic + } +} -result {ZapfChancery-MediumItalic} +test font-21.41 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfchancery 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfChancery-MediumItalic + } +} -result {ZapfChancery-MediumItalic} +test font-21.42 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfchancery 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfchancery"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfChancery-MediumItalic + } +} -result {ZapfChancery-MediumItalic} + +test font-21.43 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfdingbats 12 roman normal} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfDingbats + } +} -result {ZapfDingbats} +test font-21.44 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfdingbats 12 roman bold} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfDingbats + } +} -result {ZapfDingbats} +test font-21.45 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfdingbats 12 italic normal} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfDingbats + } +} -result {ZapfDingbats} +test font-21.46 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + unix +} -body { + set name {zapfdingbats 12 italic bold} + if {[font actual {avantgarde 12 roman normal} -family] == "zapfdingbats"} { + set x [psfontname avantgarde 12 roman normal] + } else { + set x ZapfDingbats + } +} -result {ZapfDingbats} + +test font-21.47 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {arial 12 roman normal}] +} -result {Helvetica} +test font-21.48 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {arial 12 roman bold}] +} -result {Helvetica-Bold} +test font-21.49 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {arial 12 italic normal}] +} -result {Helvetica-Oblique} +test font-21.50 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {arial 12 italic bold}] +} -result {Helvetica-BoldOblique} + +test font-21.51 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{courier new} 12 roman normal}] +} -result {Courier} +test font-21.52 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{courier new} 12 roman bold}] +} -result {Courier-Bold} +test font-21.53 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{courier new} 12 italic normal}] +} -result {Courier-Oblique} +test font-21.54 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{courier new} 12 italic bold}] +} -result {Courier-BoldOblique} + +test font-21.55 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {helvetica 12 roman normal}] +} -result {Helvetica} +test font-21.56 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {helvetica 12 roman bold}] +} -result {Helvetica-Bold} +test font-21.57 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {helvetica 12 italic normal}] +} -result {Helvetica-Oblique} +test font-21.58 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {helvetica 12 italic bold}] +} -result {Helvetica-BoldOblique} + +test font-21.59 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {symbol 12 roman normal}] +} -result {Symbol} +test font-21.60 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {symbol 12 roman bold}] +} -result {Symbol-Bold} +test font-21.61 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {symbol 12 italic normal}] +} -result {Symbol-Italic} +test font-21.62 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {symbol 12 italic bold}] +} -result {Symbol-BoldItalic} + +test font-21.63 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{times new roman} 12 roman normal}] +} -result {Times-Roman} +test font-21.64 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{times new roman} 12 roman bold}] +} -result {Times-Bold} +test font-21.65 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{times new roman} 12 italic normal}] +} -result {Times-Italic} +test font-21.66 {Tk_PostscriptFontName procedure: exhaustive} -constraints { + win +} -body { + set x [psfontname {{times new roman} 12 italic bold}] +} -result {Times-BoldItalic} + + +test font-22.1 {Tk_TextWidth procedure} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font "Courier -12" + pack .t.l + set ax [winfo reqwidth .t.l] + expr {[font measure [.t.l cget -font] "000"] eq $ax*3} +} -cleanup { + destroy .t.l +} -result 1 + + +test font-23.1 {Tk_UnderlineChars procedure} -setup { + destroy .t.t +} -body { + text .t.t + .t.t insert 1.0 abc\tdefg + .t.t tag config sel -underline 1 + .t.t tag add sel 1.0 end + update +} -cleanup { + destroy .t.t +} -result {} -test font-22.1 {Tk_TextWidth procedure} { - font measure [.b.l cget -font] "000" -} [expr $ax*3] -test font-23.1 {Tk_UnderlineChars procedure} { - text .b.t - .b.t insert 1.0 abc\tdefg - .b.t tag config sel -underline 1 - .b.t tag add sel 1.0 end - update -} {} - -setup -test font-24.1 {Tk_ComputeTextLayout: empty string} { - .b.l config -text "" -} {} -test font-24.2 {Tk_ComputeTextLayout: simple string} { - .b.l config -text "000" - getsize -} "[expr $ax*3] $ay" -test font-24.3 {Tk_ComputeTextLayout: find special chars} { - .b.l config -text "000\n000" - getsize -} "[expr $ax*3] [expr $ay*2]" -test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} { - .b.l config -text "000\n000" - getsize -} "[expr $ax*3] [expr $ay*2]" -test font-24.5 {Tk_ComputeTextLayout: break line} { - .b.l config -text "000\t00000" -wrap [expr 9*$ax] - set x [getsize] - .b.l config -wrap 0 - set x -} "[expr 8*$ax] [expr 2*$ay]" -test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} { - .b.l config -text "000\n000" -} {} -test font-24.7 {Tk_ComputeTextLayout: special char was \n} { - .b.l config -text "000\n0000" - getsize -} "[expr $ax*4] [expr $ay*2]" -test font-24.8 {Tk_ComputeTextLayout: special char was \t} { - .b.l config -text "000\t00" - getsize -} "[expr $ax*10] $ay" -test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} { +# Data used in 24.* tests +destroy .t.l +label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font "Courier -12" +pack .t.l +update +set ax [winfo reqwidth .t.l] +set ay [winfo reqheight .t.l] +test font-24.1 {Tk_ComputeTextLayout: empty string} -body { + .t.l config -text "" +} -result {} +test font-24.2 {Tk_ComputeTextLayout: simple string} -body { + .t.l config -text "000" + update + list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -result {1 1} +test font-24.3 {Tk_ComputeTextLayout: find special chars} -body { + .t.l config -text "000\n000" + update + list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \ + [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] +} -result {1 1} +test font-24.4 {Tk_ComputeTextLayout: calls Tk_MeasureChars} -body { + .t.l config -text "000\n000" + update + list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] \ + [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] +} -result {1 1} +test font-24.5 {Tk_ComputeTextLayout: break line} -body { + .t.l config -text "000\t00000" -wrap [expr 9 * $ax] + update + list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 8}]}] \ + [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] +} -cleanup { + .t.l config -wrap 0 +} -result {1 1} +test font-24.6 {Tk_ComputeTextLayout: normal ended on special char} -body { + .t.l config -text "000\n000" +} -result {} +test font-24.7 {Tk_ComputeTextLayout: special char was \n} -body { + .t.l config -text "000\n0000" + update + list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] \ + [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] +} -result {1 1} +test font-24.8 {Tk_ComputeTextLayout: special char was \t} -body { + .t.l config -text "000\t00" + update + list [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -result {1 1} +test font-24.9 {Tk_ComputeTextLayout: tab didn't cause break} -body { set x {} - .b.l config -text "000\t000" - lappend x [getsize] - .b.l config -text "000\t000" -wrap [expr 100*$ax] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*11] $ay} {[expr $ax*11] $ay}" -test font-24.10 {Tk_ComputeTextLayout: tab caused break} { + .t.l config -text "000\t000" + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}] + lappend x [expr {[winfo reqheight .t.l] eq $ay}] + .t.l config -text "000\t000" -wrap [expr 100 * $ax] + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 11}]}] + lappend x [expr {[winfo reqheight .t.l] eq $ay}] + return $x +} -cleanup { + .t.l config -wrap 0 +} -result {1 1 1 1} +test font-24.10 {Tk_ComputeTextLayout: tab caused break} -body { set x {} - .b.l config -text "000\t" - lappend x [getsize] - .b.l config -text "000\t00" -wrap [expr $ax*6] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*3] $ay} {[expr $ax*3] [expr $ay*2]}" -test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} { + .t.l config -text "000\t" + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + lappend x [expr {[winfo reqheight .t.l] eq $ay}] + .t.l config -text "000\t00" -wrap [expr $ax * 6] + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] + return $x +} -cleanup { + .t.l config -wrap 0 +} -result {1 1 1 1} +test font-24.11 {Tk_ComputeTextLayout: absorb spaces at eol} -body { set x {} - .b.l config -text "000 000" -wrap [expr $ax*5] - lappend x [getsize] - .b.l config -text "000 " - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*3] [expr $ay*2]} {[expr $ax*3] $ay}" -test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} { + .t.l config -text "000 000" -wrap [expr {$ax * 5}] + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] + .t.l config -text "000 " + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 3}]}] + lappend x [expr {[winfo reqheight .t.l] eq $ay}] + return $x +} -cleanup { + .t.l config -wrap 0 +} -result {1 1 1 1} +test font-24.12 {Tk_ComputeTextLayout: append non-printing spaces to chunk} -body { set x {} - .b.l config -text "000 0000" -wrap [expr $ax*5] - lappend x [getsize] - .b.l config -text "000\t00 0000" -wrap [expr $ax*12] - lappend x [getsize] - .b.l config -wrap 0 - set x -} "{[expr $ax*4] [expr $ay*2]} {[expr $ax*10] [expr $ay*2]}" -test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} { - .b.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" - getsize -} "1 [expr $ay*129]" -test font-24.14 {Tk_ComputeTextLayout: text ended with \n} { - list [.b.l config -text "0000"; getsize] [.b.l config -text "0000\n"; getsize] -} "{[expr $ax*4] $ay} {[expr $ax*4] [expr $ay*2]}" -test font-24.15 {Tk_ComputeTextLayout: justification} { - csetup "000\n00000" + .t.l config -text "000 0000" -wrap [expr {$ax * 5}] + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] + lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] + .t.l config -text "000\t00 0000" -wrap [expr {$ax * 12}] + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 10}]}] + lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] + return $x +} -cleanup { + .t.l config -wrap 0 +} -result {1 1 1 1} +test font-24.13 {Tk_ComputeTextLayout: many lines -> realloc line array} -body { + .t.l config -text "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" + update + list [expr {[winfo reqwidth .t.l] eq 1}] \ + [expr {[winfo reqheight .t.l] eq [expr {$ay * 129}]}] +} -result {1 1} +test font-24.14 {Tk_ComputeTextLayout: text ended with \n} -body { + set x {} + .t.l config -text "0000" + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] + lappend x [expr {[winfo reqheight .t.l] eq $ay}] + .t.l config -text "0000\n" + update + lappend x [expr {[winfo reqwidth .t.l] eq [expr {$ax * 4}]}] + lappend x [expr {[winfo reqheight .t.l] eq [expr {$ay * 2}]}] + return $x +} -result {1 1 1 1} +destroy .t.l + +test font-24.15 {Tk_ComputeTextLayout: justification} -setup { set x {} - .b.c itemconfig text -just left - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just center - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just right - lappend x [.b.c index text @[expr $ax*2],0] - .b.c itemconfig text -just left - set x -} {2 1 0} - -test font-25.1 {Tk_FreeTextLayout procedure} { - setup - .b.f config -text foo - .b.f config -text boo -} {} + destroy .t.c + canvas .t.c -closeenough 0 + .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" + pack .t.c + update +} -body { + csetup "000\n00000" + .t.c itemconfig text -just left + lappend x [.t.c index text @[expr $ax*2],0] + .t.c itemconfig text -just center + lappend x [.t.c index text @[expr $ax*2],0] + .t.c itemconfig text -just right + lappend x [.t.c index text @[expr $ax*2],0] + .t.c itemconfig text -just left + return $x +} -cleanup { + destroy .t.c +} -result {2 1 0} + + +test font-25.1 {Tk_FreeTextLayout procedure} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { + .t.f config -text foo + .t.f config -text boo +} -cleanup { + destroy .t.f +} -result {} -test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} { - .b.f config -text foo -} {} -test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} { + +# Canvas created for tests: 26.* +destroy .t.c +canvas .t.c -closeenough 0 +.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" +pack .t.c +update +test font-26.1 {Tk_DrawTextLayout procedure: auto-detect last char} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { + .t.f config -text foo +} -cleanup { + destroy .t.f +} -result {} +test font-26.2 {Tk_DrawTextLayout procedure: multiple chunks} -body { csetup "000\t00\n000" -} {} -test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} { +} -result {} +test font-26.3 {Tk_DrawTextLayout: draw subset of chunk: numDisplay <= 0} -body { csetup "000\t00" - .b.c select from text 3 - .b.c select to text 5 -} {} -test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} { - .b.c select from text 3 - .b.c select to text 5 -} {} -test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} { - .b.c select from text 2 - .b.c select to text 2 -} {} -test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} { - .b.c select from text 4 - .b.c select to text 4 -} {} - -test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} { - .b.f config -text "foo" -under -1 -} {} -test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} { - .b.f config -text "000 00000" -wrap [expr $ax*7] -under 10 -} {} -test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} { - .b.f config -text "000 00000" -wrap [expr $ax*7] -under 5 - .b.f config -wrap -1 -under -1 -} {} - -test font-28.1 {Tk_PointToChar procedure: above all lines} { + .t.c select from text 3 + .t.c select to text 5 +} -result {} +test font-26.4 {Tk_DrawTextLayout: draw subset of chunk: firstChar <= 0} -body { + csetup "000\t00" + .t.c select from text 3 + .t.c select to text 5 +} -result {} +test font-26.5 {Tk_DrawTextLayout: draw subset of chunk: firstChar > 0} -body { + csetup "000\t00" + .t.c select from text 2 + .t.c select to text 2 +} -result {} +test font-26.6 {Tk_DrawTextLayout: draw subset of chunk: lastChar < numChars} -body { + csetup "000\t00" + .t.c select from text 4 + .t.c select to text 4 +} -result {} +destroy .t.c + +# Label used in 27.* tests +destroy .t.f +pack [label .t.f] +update +test font-27.1 {Tk_UnderlineTextLayout procedure: no underline chosen} -body { + .t.f config -text "foo" -under -1 +} -result {} +test font-27.2 {Tk_UnderlineTextLayout procedure: underline not visible} -body { + .t.f config -text "000 00000" -wrap [expr $ax*7] -under 10 +} -result {} +test font-27.3 {Tk_UnderlineTextLayout procedure: underline is visible} -body { + .t.f config -text "000 00000" -wrap [expr $ax*7] -under 5 + .t.f config -wrap -1 -under -1 +} -result {} +destroy .t.f + + + +# Canvas created for tests: 28.* +destroy .t.c +canvas .t.c -closeenough 0 +.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" +pack .t.c +update +test font-28.1 {Tk_PointToChar procedure: above all lines} -body { csetup "000" - .b.c index text @-1,0 -} {0} -test font-28.2 {Tk_PointToChar procedure: no chars} { + .t.c index text @-1,0 +} -result {0} +test font-28.2 {Tk_PointToChar procedure: no chars} -body { # After fixing the following bug: # # In canvas text item, it was impossible to click to position the @@ -905,206 +1680,277 @@ test font-28.2 {Tk_PointToChar procedure: no chars} { # index of 1 if TextLayout contained 0 characters. csetup "" - .b.c index text @100,100 -} {0} -test font-28.3 {Tk_PointToChar procedure: loop test} { + .t.c index text @100,100 +} -result {0} +test font-28.3 {Tk_PointToChar procedure: loop test} -body { csetup "000\n000\n000\n000" - .b.c index text @10000,0 -} {3} -test font-28.4 {Tk_PointToChar procedure: intersect line} { + .t.c index text @10000,0 +} -result {3} +test font-28.4 {Tk_PointToChar procedure: intersect line} -body { csetup "000\n000\n000" - .b.c index text @0,$ay -} {4} -test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} { - .b.c index text @-100,$ay -} {4} -test font-28.6 {Tk_PointToChar procedure: past any possible chunk} { - .b.c index text @100000,$ay -} {7} -test font-28.7 {Tk_PointToChar procedure: which chunk on this line} { + .t.c index text @0,$ay +} -result {4} +test font-28.5 {Tk_PointToChar procedure: to the left of all chunks} -body { + csetup "000\n000\n000" + .t.c index text @-100,$ay +} -result {4} +test font-28.6 {Tk_PointToChar procedure: past any possible chunk} -body { + csetup "000\n000\n000" + .t.c index text @100000,$ay +} -result {7} +test font-28.7 {Tk_PointToChar procedure: which chunk on this line} -body { csetup "000\n000\t000\t000\n000" - .b.c index text @[expr $ax*2],$ay -} {6} -test font-28.8 {Tk_PointToChar procedure: which chunk on this line} { + .t.c index text @[expr $ax*2],$ay +} -result {6} +test font-28.8 {Tk_PointToChar procedure: which chunk on this line} -body { csetup "000\n000\t000\t000\n000" - .b.c index text @[expr $ax*10],$ay -} {10} -test font-28.9 {Tk_PointToChar procedure: in special chunk} { + .t.c index text @[expr $ax*10],$ay +} -result {10} +test font-28.9 {Tk_PointToChar procedure: in special chunk} -body { csetup "000\n000\t000\t000\n000" - .b.c index text @[expr $ax*6],$ay -} {7} -test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} { + .t.c index text @[expr $ax*6],$ay +} -result {7} +test font-28.10 {Tk_PointToChar procedure: past all chars in chunk} -body { csetup "000 0000000" - .b.c itemconfig text -width [expr $ax*5] - set x [.b.c index text @[expr $ax*5],0] - .b.c itemconfig text -width 0 - set x -} {3} -test font-28.11 {Tk_PointToChar procedure: below all chunks} { + .t.c itemconfig text -width [expr $ax*5] + set x [.t.c index text @[expr $ax*5],0] + .t.c itemconfig text -width 0 + return $x +} -result {3} +test font-28.11 {Tk_PointToChar procedure: below all chunks} -body { csetup "000 0000000" - .b.c index text @0,1000000 -} {11} - -test font-29.1 {Tk_CharBBox procedure: index < 0} { - .b.f config -text "000" -underline -1 -} {} -test font-29.2 {Tk_CharBBox procedure: loop} { - .b.f config -text "000\t000\t000\t000" -underline 9 -} {} -test font-29.3 {Tk_CharBBox procedure: special char} { - .b.f config -text "000\t000\t000" -underline 7 -} {} -test font-29.4 {Tk_CharBBox procedure: normal char} { - .b.f config -text "000" -underline 1 -} {} -test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} { - .b.f config -text "0 0000" -wrap [expr $ax*4] -under 2 - .b.f config -wrap 0 -} {} -test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} { - .b.f config -text "0 0000" -wrap [expr $ax*4] -under 3 - .b.f config -wrap 0 -} {} - -.b.c bind all <Enter> {lappend x [.b.c index current @%x,%y]} - -test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} { + .t.c index text @0,1000000 +} -result {11} +destroy .t.c + + +# Label used in 29.* tests +destroy .t.f +pack [label .t.f] +update +test font-29.1 {Tk_CharBBox procedure: index < 0} -body { + .t.f config -text "000" -underline -1 +} -result {} +test font-29.2 {Tk_CharBBox procedure: loop} -body { + .t.f config -text "000\t000\t000\t000" -underline 9 +} -result {} +test font-29.3 {Tk_CharBBox procedure: special char} -body { + .t.f config -text "000\t000\t000" -underline 7 +} -result {} +test font-29.4 {Tk_CharBBox procedure: normal char} -body { + .t.f config -text "000" -underline 1 +} -result {} +test font-29.5 {Tk_CharBBox procedure: right edge of bbox truncated} -body { + .t.f config -text "0 0000" -wrap [expr $ax*4] -under 2 + .t.f config -wrap 0 +} -result {} +test font-29.6 {Tk_CharBBox procedure: bbox pegged to right edge} -body { + .t.f config -text "0 0000" -wrap [expr $ax*4] -under 3 + .t.f config -wrap 0 +} -result {} +destroy .t.f + + + +# Canvas created for tests: 30.* +destroy .t.c +canvas .t.c -closeenough 0 +.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" +pack .t.c +update +test font-30.1 {Tk_DistanceToTextLayout procedure: loop once} -body { csetup "000\n000\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {0} -test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x 0 -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {0} +test font-30.2 {Tk_DistanceToTextLayout procedure: loop multiple} -body { csetup "000\n000\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y $ay - set x -} {5} -test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x $ax -y $ay + return $x +} -cleanup { + bind all <Enter> {} +} -result {5} +test font-30.3 {Tk_DistanceToTextLayout procedure: loop to end} -body { csetup "000\n0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y $ay - set x -} {} -test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x [expr $ax*2] -y $ay + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +test font-30.4 {Tk_DistanceToTextLayout procedure: hit a special char (tab)} -body { csetup "000\t000\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*6] -y 0 - set x -} {3} -test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x [expr $ax*6] -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {3} +test font-30.5 {Tk_DistanceToTextLayout procedure: ignore newline} -body { csetup "000\n0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y $ay - set x -} {} -test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x [expr $ax*2] -y $ay + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +test font-30.6 {Tk_DistanceToTextLayout procedure: ignore spaces at eol} -body { csetup "000\n000 000000000" - .b.c itemconfig text -width [expr $ax*10] + .t.c itemconfig text -width [expr $ax*10] + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*5] -y $ay - .b.c itemconfig text -width 0 - set x -} {} -.b.c itemconfig text -justify center -test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x [expr $ax*5] -y $ay + .t.c itemconfig text -width 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +.t.c itemconfig text -justify center +test font-30.7 {Tk_DistanceToTextLayout procedure: on left side} -body { csetup "0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {} -test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x 0 -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +test font-30.8 {Tk_DistanceToTextLayout procedure: on right side} -body { csetup "0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x [expr $ax*2] -y 0 - set x -} {} -test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x [expr $ax*2] -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +test font-30.9 {Tk_DistanceToTextLayout procedure: inside line} -body { csetup "0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y 0 - set x -} {0} -test font-30.10 {Tk_DistanceToTextLayout procedure: above line} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x $ax -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {0} +test font-30.10 {Tk_DistanceToTextLayout procedure: above line} -body { csetup "0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y 0 - set x -} {} -test font-30.11 {Tk_DistanceToTextLayout procedure: below line} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x 0 -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +test font-30.11 {Tk_DistanceToTextLayout procedure: below line} -body { csetup "000\n0" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x 0 -y $ay - set x -} {} -test font-30.12 {Tk_DistanceToTextLayout procedure: in line} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x 0 -y $ay + return $x +} -cleanup { + bind all <Enter> {} +} -result {} +test font-30.12 {Tk_DistanceToTextLayout procedure: in line} -body { csetup "0\n000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y $ay - set x -} {3} -.b.c itemconfig text -justify left -test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x $ax -y $ay + return $x +} -cleanup { + bind all <Enter> {} +} -result {3} +.t.c itemconfig text -justify left +test font-30.13 {Tk_DistanceToTextLayout procedure: exact hit} -body { csetup "000" + .t.c bind all <Enter> {lappend x [.t.c index current @%x,%y]} set x {} - event generate .b.c <Leave> - event generate .b.c <Enter> -x $ax -y 0 - set x -} {1} - -test font-31.1 {Tk_IntersectTextLayout procedure: loop once} { + event generate .t.c <Leave> + event generate .t.c <Enter> -x $ax -y 0 + return $x +} -cleanup { + bind all <Enter> {} +} -result {1} +destroy .t.c + + +# Canvas created for tests 31.* +destroy .t.c +canvas .t.c -closeenough 0 +.t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" +pack .t.c +update +test font-31.1 {Tk_IntersectTextLayout procedure: loop once} -body { csetup "000\n000\n000" - .b.c find overlapping 0 0 0 0 -} [.b.c find withtag text] -test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} { + .t.c find overlapping 0 0 0 0 +} -result [.t.c find withtag text] +test font-31.2 {Tk_IntersectTextLayout procedure: loop multiple} -body { csetup "000\t000\t000" - .b.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 -} [.b.c find withtag text] -test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} { + .t.c find overlapping [expr $ax*10] 0 [expr $ax*10] 0 +} -result [.t.c find withtag text] +test font-31.3 {Tk_IntersectTextLayout procedure: loop to end} -body { csetup "0\n000" - .b.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 -} {} -test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} { + .t.c find overlapping [expr $ax*2] 0 [expr $ax*2] 0 +} -result {} +test font-31.4 {Tk_IntersectTextLayout procedure: hit a special char (tab)} -body { csetup "000\t000" - .b.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 -} [.b.c find withtag text] -test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} { + .t.c find overlapping [expr $ax*6] 0 [expr $ax*6] 0 +} -result [.t.c find withtag text] +test font-31.5 {Tk_IntersectTextLayout procedure: ignore newlines} -body { csetup "000\n0\n000" - .b.c find overlapping $ax $ay $ax $ay -} {} -test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} { + .t.c find overlapping $ax $ay $ax $ay +} -result {} +test font-31.6 {Tk_IntersectTextLayout procedure: ignore spaces at eol} -body { csetup "000\n000 000000000" - .b.c itemconfig text -width [expr $ax*10] - set x [.b.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] - .b.c itemconfig text -width 0 - set x -} {} - -test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { + .t.c itemconfig text -width [expr $ax*10] + set x [.t.c find overlapping [expr $ax*5] $ay [expr $ax*5] $ay] + .t.c itemconfig text -width 0 + return $x +} -result {} +destroy .t.c + + +test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} -setup { + destroy .t.c + canvas .t.c -closeenough 0 + .t.c create text 0 0 -tags text -anchor nw -just left -font "Courier -12" + pack .t.c + update +} -body { # If there were a whole bunch of returns or tabs in a row, then the # temporary buffer could overflow and write on the stack. - csetup "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" - .b.c itemconfig text -width 800 - .b.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" - .b.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" - .b.c insert text end "end" - set x [.b.c postscript] + .t.c itemconfig text -width 800 + .t.c insert text end "qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm\n" + .t.c insert text end "\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n\n" + .t.c insert text end "end" + set x [.t.c postscript] set i [string first "(qwerty" $x] string range $x $i [expr {$i + 278}] -} {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] +} -cleanup { + destroy .t.c +} -result {(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] [(qwertyuiopasdfghjklzxcvbnm1234qwertyuiopasdfghjklzxcvbnm)] [()] [()] @@ -1139,248 +1985,372 @@ test font-32.1 {Tk_TextLayoutToPostscript: ensure buffer doesn't overflow} { [(end)] } -test font-33.1 {Tk_TextWidth procedure} { -} {} -test font-34.1 {ConfigAttributesObj procedure: arguments} { +test font-33.1 {Tk_TextWidth procedure} -body { +} -result {} + + +test font-34.1 {ConfigAttributesObj procedure: arguments} -setup { + catch {font delete xyz} +} -body { # (Tcl_GetIndexFromObj() != TCL_OK) - setup - list [catch {font create xyz -xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} -test font-34.2 {ConfigAttributesObj procedure: arguments} { + font create xyz -xyz +} -returnCodes { + error +} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} +test font-34.2 {ConfigAttributesObj procedure: arguments} -setup { + catch {font delete xyz} +} -body { # (objc & 1) - setup - list [catch {font create xyz -family} msg] $msg -} {1 {value for "-family" option missing}} -foreach p { - {font-34.3 family xyz times} - {font-34.4 size 20 40} - {font-34.5 weight normal bold} - {font-34.6 slant roman italic} - {font-34.7 underline 0 1} - {font-34.8 overstrike 0 1} -} { - lassign $p testName opt val1 val2 - test $testName "ConfigAttributesObj procedure: $opt" { - setup - set x {} - font create xyz -$opt $val1 - lappend x [font config xyz -$opt] - font config xyz -$opt $val2 - lappend x [font config xyz -$opt] - } [list $val1 $val2] -} -foreach p { - {font-34.9 size xyz {expected integer but got "xyz"}} - {font-34.10 weight xyz {bad -weight value "xyz": must be normal, or bold}} - {font-34.11 slant xyz {bad -slant value "xyz": must be roman, or italic}} - {font-34.12 underline xyz {expected boolean value but got "xyz"}} - {font-34.13 overstrike xyz {expected boolean value but got "xyz"}} -} { - lassign $p testName opt val result - test $testName "ConfigAttributesObj procedure: $opt" -setup { - setup - } -body { - font create xyz -$opt $val - } -returnCodes error -result $result -} + font create xyz -family +} -returnCodes error -result {value for "-family" option missing} -test font-35.1 {GetAttributeInfoObj procedure: one attribute} { +test font-34.3 {ConfigAttributesObj procedure: family} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -family xyz + lappend x [font config xyz -family] + font config xyz -family times + lappend x [font config xyz -family] +} -cleanup { + font delete xyz +} -result {xyz times} +test font-34.4 {ConfigAttributesObj procedure: size} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -size 20 + lappend x [font config xyz -size] + font config xyz -size 40 + lappend x [font config xyz -size] +} -cleanup { + font delete xyz +} -result {20 40} +test font-34.5 {ConfigAttributesObj procedure: weight} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -weight normal + lappend x [font config xyz -weight] + font config xyz -weight bold + lappend x [font config xyz -weight] +} -cleanup { + font delete xyz +} -result {normal bold} +test font-34.6 {ConfigAttributesObj procedure: slant} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -slant roman + lappend x [font config xyz -slant] + font config xyz -slant italic + lappend x [font config xyz -slant] +} -cleanup { + font delete xyz +} -result {roman italic} +test font-34.7 {ConfigAttributesObj procedure: underline} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -underline 0 + lappend x [font config xyz -underline] + font config xyz -underline 1 + lappend x [font config xyz -underline] +} -cleanup { + font delete xyz +} -result {0 1} +test font-34.8 {ConfigAttributesObj procedure: overstrike} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -overstrike 0 + lappend x [font config xyz -overstrike] + font config xyz -overstrike 1 + lappend x [font config xyz -overstrike] +} -cleanup { + font delete xyz +} -result {0 1} + +test font-34.9 {ConfigAttributesObj procedure: size} -body { + font create xyz -size xyz +} -returnCodes error -result {expected integer but got "xyz"} +test font-34.10 {ConfigAttributesObj procedure: weight} -body { + font create xyz -weight xyz +} -returnCodes error -result {bad -weight value "xyz": must be normal, or bold} +test font-34.11 {ConfigAttributesObj procedure: slant} -body { + font create xyz -slant xyz +} -returnCodes error -result {bad -slant value "xyz": must be roman, or italic} +test font-34.12 {ConfigAttributesObj procedure: underline} -body { + font create xyz -underline xyz +} -returnCodes error -result {expected boolean value but got "xyz"} +test font-34.13 {ConfigAttributesObj procedure: overstrike} -body { + font create xyz -overstrike xyz +} -returnCodes error -result {expected boolean value but got "xyz"} + + +test font-35.1 {GetAttributeInfoObj procedure: one attribute} -setup { + catch {font delete xyz} +} -body { # (objPtr != NULL) - setup font create xyz -family xyz font config xyz -family -} {xyz} +} -cleanup { + font delete xyz +} -result {xyz} + -test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} { +test font-36.1 {GetAttributeInfoObj procedure: unknown attribute} -setup { + catch {font delete xyz} +} -body { # (Tcl_GetIndexFromObj() != TCL_OK) - setup font create xyz - list [catch {font config xyz -xyz} msg] $msg -} {1 {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike}} - -test font-37.1 {GetAttributeInfoObj procedure: all attributes} { - # not (objPtr != NULL) - setup + font config xyz -xyz +} -cleanup { + font delete xyz +} -returnCodes { + error +} -result {bad option "-xyz": must be -family, -size, -weight, -slant, -underline, or -overstrike} + + +test font-37.1 {GetAttributeInfoObj procedure: all attributes} -setup { + catch {font delete xyz} +} -body { + # not (objPtr != NULL) font create xyz -family xyz font config xyz -} {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} -set i 4 -foreach p { - {font-37.2 family xyz xyz} - {font-37.3 size 20 20} - {font-37.4 weight normal normal} - {font-37.5 slant italic italic} - {font-37.6 underline yes 1} - {font-37.7 overstrike false 0} -} { - lassign $p testName opt val expected - test $testName "GetAttributeInfo procedure: $opt" -setup { - setup - } -body { - font create xyz -$opt $val - font config xyz -$opt - } -result $expected -} +} -cleanup { + font delete xyz +} -result {-family xyz -size 0 -weight normal -slant roman -underline 0 -overstrike 0} +test font-37.2 {GetAttributeInfo procedure: family} -setup { + catch {font delete xyz} +} -body { + font create xyz -family xyz + font config xyz -family +} -cleanup { + font delete xyz +} -result {xyz} +test font-37.3 {GetAttributeInfo procedure: size} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -size 20 + font config xyz -size +} -cleanup { + font delete xyz +} -result {20} +test font-37.4 {GetAttributeInfo procedure: weight} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -weight normal + font config xyz -weight +} -cleanup { + font delete xyz +} -result {normal} +test font-37.5 {GetAttributeInfo procedure: slant} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -slant italic + font config xyz -slant +} -cleanup { + font delete xyz +} -result {italic} +test font-37.6 {GetAttributeInfo procedure: underline} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -underline yes + font config xyz -underline +} -cleanup { + font delete xyz +} -result {1} +test font-37.7 {GetAttributeInfo procedure: overstrike} -setup { + catch {font delete xyz} + set x {} +} -body { + font create xyz -overstrike no + font config xyz -overstrike +} -cleanup { + font delete xyz +} -result {0} + # In tests below, one field is set to "xyz" so that font name doesn't # look like a native X font, so that ParseFontNameObj or TkParseXLFD will # be called. -setup - -test font-38.1 {ParseFontNameObj procedure: begins with -} { +test font-38.1 {ParseFontNameObj procedure: begins with -} -body { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.2 {ParseFontNameObj procedure: begins with -*} { +} -result [font actual {times 0} -family] +test font-38.2 {ParseFontNameObj procedure: begins with -*} -body { lindex [font actual -*-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} { +} -result [font actual {times 0} -family] +test font-38.3 {ParseFontNameObj procedure: begins with -, doesn't look like list} -body { lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} { +} -result [font actual {times 0} -family] +test font-38.4 {ParseFontNameObj procedure: begins with -, looks like list} -body { lindex [font actual {-family times}] 1 -} $times -test font-38.5 {ParseFontNameObj procedure: begins with *} { +} -result [font actual {times 0} -family] +test font-38.5 {ParseFontNameObj procedure: begins with *} -body { lindex [font actual *-times-xyz-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times -test font-38.6 {ParseFontNameObj procedure: begins with *} { +} -result [font actual {times 0} -family] +test font-38.6 {ParseFontNameObj procedure: begins with *} -body { font actual *-times-xyz -family -} $times -test font-38.7 {ParseFontNameObj procedure: arguments} {noExceed} { - list [catch {font actual "\{xyz"} msg] $msg -} [list 1 "font \"{xyz\" doesn't exist"] -test font-38.8 {ParseFontNameObj procedure: arguments} {noExceed} { - list [catch {font actual ""} msg] $msg -} {1 {font "" doesn't exist}} -test font-38.9 {ParseFontNameObj procedure: arguments} { - list [catch {font actual {times 20 xyz xyz}} msg] $msg -} {1 {unknown font style "xyz"}} -test font-38.10 {ParseFontNameObj procedure: arguments} { - list [catch {font actual {times xyz xyz}} msg] $msg -} {1 {expected integer but got "xyz"}} -test font-38.12 {ParseFontNameObj procedure: stylelist loop} {unixOrPc} { +} -result [font actual {times 0} -family] +test font-38.7 {ParseFontNameObj procedure: arguments} -constraints noExceed -body { + font actual "\{xyz" +} -returnCodes error -result "font \"{xyz\" doesn't exist" +test font-38.8 {ParseFontNameObj procedure: arguments} -constraints noExceed -body { + font actual "" +} -returnCodes error -result {font "" doesn't exist} +test font-38.9 {ParseFontNameObj procedure: arguments} -body { + font actual {times 20 xyz xyz} +} -returnCodes error -result {unknown font style "xyz"} +test font-38.10 {ParseFontNameObj procedure: arguments} -body { + font actual {times xyz xyz} +} -returnCodes error -result {expected integer but got "xyz"} +test font-38.11 {ParseFontNameObj procedure: stylelist loop} -constraints { + unixOrPc +} -body { lrange [font actual {times 12 bold italic overstrike underline}] 4 end -} {-weight bold -slant italic -underline 1 -overstrike 1} -test font-38.13 {ParseFontNameObj procedure: stylelist error} { - list [catch {font actual {times 12 bold xyz}} msg] $msg -} {1 {unknown font style "xyz"}} -test font-38.14 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body { +} -result {-weight bold -slant italic -underline 1 -overstrike 1} +test font-38.12 {ParseFontNameObj procedure: stylelist error} -body { + font actual {times 12 bold xyz} +} -returnCodes error -result {unknown font style "xyz"} +test font-38.13 "ParseFontNameObj: options with hyphenated family: bug #2791352" -body { font actual {-family sans-serif -size 12 -weight bold -slant roman -underline 0 -overstrike 0} } -returnCodes ok -result [font actual {sans-serif 12 bold}] -test font-38.15 "ParseFontNameObj: bug #2791352" -body { +test font-38.14 "ParseFontNameObj: bug #2791352" -body { font actual {-invalidfont 8 bold} } -returnCodes error -match glob -result {bad option "-invalidfont": *} -test font-39.1 {NewChunk procedure: test realloc} { - .b.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" -} {} -test font-40.1 {TkFontParseXLFD procedure: initial dash} { +test font-39.1 {NewChunk procedure: test realloc} -setup { + destroy .t.f + pack [label .t.f] + update +} -body { + .t.f config -text "xxx\nxxx\txxx\nxxx\t\t\t" +} -cleanup { + destroy .t.f +} -result {} + + +test font-40.1 {TkFontParseXLFD procedure: initial dash} -body { font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-* -family -} $times -test font-40.2 {TkFontParseXLFD procedure: no initial dash} { +} -result [font actual {times 0} -family] +test font-40.2 {TkFontParseXLFD procedure: no initial dash} -body { font actual *-times-*-*-*-*-*-*-*-*-*-*-*-xyz -family -} $times -test font-40.3 {TkFontParseXLFD procedure: not enough fields} { +} -result [font actual {times 0} -family] +test font-40.3 {TkFontParseXLFD procedure: not enough fields} -body { font actual -xyz-times-*-*-* -family -} $times -test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} { +} -result [font actual {times 0} -family] +test font-40.4 {TkFontParseXLFD procedure: all fields unspecified} -body { lindex [font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-*] 0 -} {-family} -test font-40.5 {TkFontParseXLFD procedure: all fields specified} { - lindex [font actual -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 -} $times -test font-41.1 {TkParseXLFD procedure: arguments} { +} -result {-family} +test font-40.5 {TkFontParseXLFD procedure: all fields specified} -body { + lindex [font actual \ + -foundry-times-weight-slant-setwidth-addstyle-10-10-10-10-spacing-avgwidth-registry-encoding] 1 +} -result [font actual {times 0} -family] + + +test font-41.1 {TkParseXLFD procedure: arguments} -body { # XLFD with bad pointsize: fallback to some system font. font actual -*-*-*-*-*-*-xyz-*-*-*-*-*-*-* set x {} -} {} -test font-42.1 {TkFontParseXLFD procedure: arguments} { +} -result {} + + +test font-42.1 {TkFontParseXLFD procedure: arguments} -body { # XLFD with bad pixelsize: fallback to some system font. font actual -*-*-*-*-*-*-*-xyz-*-*-*-*-*-* set x {} -} {} -test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} { +} -result {} +test font-42.2 {TkFontParseXLFD procedure: pixelsize specified} -body { font metrics -xyz-times-*-*-*-*-12-*-*-*-*-*-*-* -linespace set x {} -} {} -test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} { +} -result {} +test font-42.3 {TkFontParseXLFD procedure: weird pixelsize specified} -body { font metrics {-xyz-times-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*-*} -linespace set x {} -} {} -test font-42.4 {TkFontParseXLFD procedure: pointsize specified} { +} -result {} +test font-42.4 {TkFontParseXLFD procedure: pointsize specified} -body { font metrics -xyz-times-*-*-*-*-*-120-*-*-*-*-*-* -linespace set x {} -} {} -test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} { +} -result {} +test font-42.5 {TkFontParseXLFD procedure: weird pointsize specified} -body { font metrics {-xyz-times-*-*-*-*-*-[ 12.0 0 12.0 0]-*-*-*-*-*-*} -linespace set x {} -} {} +} -result {} -test font-43.1 {FieldSpecified procedure: specified vs. non-specified} { + +test font-43.1 {FieldSpecified procedure: specified vs. non-specified} -body { font actual -xyz--*-*-*-*-*-*-*-*-*-*-*-* font actual -xyz-*-*-*-*-*-*-*-*-*-*-*-*-* font actual -xyz-?-*-*-*-*-*-*-*-*-*-*-*-* lindex [font actual -xyz-times-*-*-*-*-*-*-*-*-*-*-*-*] 1 -} $times +} -result [font actual {times 0} -family] + -set oldscale [tk scaling] -tk scaling 0.5 -test font-44.1 {TkFontGetPixels: size < 0} { +test font-44.1 {TkFontGetPixels: size < 0} -setup { + set oldscale [tk scaling] +} -body { + tk scaling 0.5 font actual {times -12} -size -} {24} -test font-44.2 {TkFontGetPoints: size >= 0} {noExceed} { +} -cleanup { + tk scaling $oldscale +} -result {24} +test font-44.2 {TkFontGetPoints: size >= 0} -constraints noExceed -setup { + set oldscale [tk scaling] +} -body { + tk scaling 0.5 font actual {times 12} -size -} {12} +} -cleanup { + tk scaling $oldscale +} -result {12} -tk scaling $oldscale -test font-45.1 {TkFontGetAliasList: no match} { +test font-45.1 {TkFontGetAliasList: no match} -body { font actual {snarky 10} -family -} [font actual {-size 10} -family] -test font-45.3 {TkFontGetAliasList: match} win { +} -result [font actual {-size 10} -family] +test font-45.2 {TkFontGetAliasList: match} -constraints win -body { font actual {times 10} -family -} {Times New Roman} -test font-45.4 {TkFontGetAliasList: match} {unix noExceed} { +} -result {Times New Roman} +test font-45.3 {TkFontGetAliasList: match} -constraints {unix noExceed} -body { # can fail on Unix systems that have a real "times new roman" font font actual {{times new roman} 10} -family -} [font actual {times 10} -family] +} -result [font actual {times 10} -family] -test font-46.1 {font actual, with character, no option, no --} \ - -body { + +test font-46.1 {font actual, with character, no option, no --} -body { font actual {times 10} a - } \ - -match glob \ - -result [list -family [font actual {times 10} -family] -size *\ +} -match glob -result [list -family [font actual {times 10} -family] -size *\ -slant roman -underline 0 -overstrike 0] -test font-46.2 {font actual, with character introduced by --} \ - -body { +test font-46.2 {font actual, with character introduced by --} -body { font actual {times 10} -- - - } \ - -match glob \ - -result [list -family [font actual {times 10} -family] -size *\ +} -match glob -result [list -family [font actual {times 10} -family] -size *\ -slant roman -underline 0 -overstrike 0] -test font-46.3 {font actual, with character and option} { +test font-46.3 {font actual, with character and option} -body { font actual {times 10} -family a -} [font actual {times 10} -family] +} -result [font actual {times 10} -family] -test font-46.4 {font actual, with character, option and --} { +test font-46.4 {font actual, with character, option and --} -body { font actual {times 10} -family -- - -} [font actual {times 10} -family] - -test font-46.5 {font actual, too many chars} { - list [catch { - font actual {times 10} 123456789012345678901234567890123456789012345678901 - } result] $result -} {1 {expected a single character but got "1234567890123456789012345678901234567..."}} +} -result [font actual {times 10} -family] -setup +test font-46.5 {font actual, too many chars} -body { + font actual {times 10} 123456789012345678901234567890123456789012345678901 +} -returnCodes error -result {expected a single character but got "1234567890123456789012345678901234567..."} -destroy .b # cleanup cleanupTests return + + + + diff --git a/tests/fontchooser.test b/tests/fontchooser.test new file mode 100644 index 0000000..4dad5da --- /dev/null +++ b/tests/fontchooser.test @@ -0,0 +1,201 @@ +# Test the "tk::fontchooser" command +# +# Copyright (c) 2008 Pat Thoyts + +package require tcltest 2.1 +eval tcltest::configure $argv +tcltest::loadTestedCommands + +# the following helper functions are related to the functions used +# in winDialog.test where they are used to send messages to the win32 +# dialog (hence the wierdness). + +proc start {cmd} { + set ::tk_dialog {} + set ::iter_after 0 + after 1 $cmd +} +proc then {cmd} { + set ::command $cmd + set ::dialogresult {} + set ::testfont {} + afterbody + vwait ::dialogresult + return $::dialogresult +} +proc afterbody {} { + if {$::tk_dialog == {}} { + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting for tk_dialog" + return + } + after 150 {afterbody} + return + } + uplevel #0 {set dialogresult [eval $command]} +} +proc Click {button} { + switch -exact -- $button { + ok { $::tk_dialog.ok invoke } + cancel { $::tk_dialog.cancel invoke } + apply { $::tk_dialog.apply invoke } + default { return -code error "invalid button name \"$button\"" } + } +} +proc ApplyFont {font} { +# puts stderr "apply: $font" + set ::testfont $font +} + +# ------------------------------------------------------------------------- + +test fontchooser-1.1 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser -z +} -result {unknown or ambiguous subcommand "-z": must be configure, hide, or show} + +test fontchooser-1.2 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -z +} -match glob -result {bad option "-z":*} + +test fontchooser-1.3 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -parent . -font +} -result {value for "-font" missing} + +test fontchooser-1.4 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -parent . -title +} -result {value for "-title" missing} + +test fontchooser-1.5 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -parent . -command +} -result {value for "-command" missing} + +test fontchooser-1.6 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -title . -parent +} -result {value for "-parent" missing} + +test fontchooser-1.7 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -parent abc +} -result {bad window path name "abc"} + +test fontchooser-1.8 {tk fontchooser: usage} -returnCodes ok -body { + tk fontchooser configure -visible +} -result {0} + +test fontchooser-1.9 {tk fontchooser: usage} -returnCodes error -body { + tk fontchooser configure -visible 1 +} -match glob -result {*} + +# ------------------------------------------------------------------------- +# +# The remaining tests in this file are only relevant for the script +# implementation. They can be tested by sourcing the script file but +# the Tk tests are run with -singleproc 1 and doing this affects the +# result of later attempts to test the native implementations. +# +testConstraint scriptImpl [llength [info proc ::tk::fontchooser::Configure]] + +test fontchooser-2.0 {fontchooser -title} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -title "Hello" + tk::fontchooser::Show + } + then { + set x [wm title $::tk_dialog] + Click cancel + } + set x +} -result {Hello} + +test fontchooser-2.1 {fontchooser -title (cyrillic)} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure \ + -title "\u041f\u0440\u0438\u0432\u0435\u0442" + tk::fontchooser::Show + } + then { + set x [wm title $::tk_dialog] + Click cancel + } + set x +} -result "\u041f\u0440\u0438\u0432\u0435\u0442" + +test fontchooser-3.0 {fontchooser -parent} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -parent . + tk::fontchooser::Show + } + then { + set x [winfo parent $::tk_dialog] + Click cancel + } + set x +} -result {.} + +test fontchooser-3.1 {fontchooser -parent (invalid)} -constraints scriptImpl -body { + tk::fontchooser::Configure -parent junk +} -returnCodes error -match glob -result {bad window path *} + +test fontchooser-4.0 {fontchooser -font} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -command ApplyFont -font courier + tk::fontchooser::Show + } + then { + Click cancel + } + set ::testfont +} -result {} + +test fontchooser-4.1 {fontchooser -font} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -command ApplyFont -font courier + tk::fontchooser::Show + } + then { + Click ok + } + expr {$::testfont ne {}} +} -result {1} + +test fontchooser-4.2 {fontchooser -font} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -command ApplyFont -font TkDefaultFont + tk::fontchooser::Show + } + then { + Click ok + } + expr {$::testfont ne {}} +} -result {1} + +test fontchooser-4.3 {fontchooser -font} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -command ApplyFont -font {times 14 bold} + tk::fontchooser::Show + } + then { + Click ok + } + expr {$::testfont ne {}} +} -result {1} + +test fontchooser-4.4 {fontchooser -font} -constraints scriptImpl -body { + start { + tk::fontchooser::Configure -command ApplyFont -font {times 14 bold} + tk::fontchooser::Show + } + then { + Click ok + } + lrange $::testfont 1 end +} -result {14 bold} + +# ------------------------------------------------------------------------- + +cleanupTests +return + +# Local Variables: +# mode: tcl +# indent-tabs-mode: nil +# End: diff --git a/tests/frame.test b/tests/frame.test index affdac6..35b9605 100644 --- a/tests/frame.test +++ b/tests/frame.test @@ -7,7 +7,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -51,40 +52,98 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } -test frame-1.1 {frame configuration options} { + +test frame-1.1 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -class NewFrame + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class Frame NewFrame} +test frame-1.2 {frame configuration options} -setup { + deleteWindows +} -body { frame .f -class NewFrame - list [.f configure -class] [catch {.f configure -class Different} msg] $msg -} {{-class class Class Frame NewFrame} 1 {can't modify -class option after widget is created}} -catch {destroy .f} -test frame-1.2 {frame configuration options} { + .f configure -class Different +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -class option after widget is created} + +test frame-1.3 {frame configuration options} -setup { + deleteWindows +} -body { frame .f -colormap new - list [.f configure -colormap] [catch {.f configure -colormap .} msg] $msg -} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} -catch {destroy .f} -test frame-1.3 {frame configuration options} { + .f configure -colormap +} -cleanup { + deleteWindows +} -result {-colormap colormap Colormap {} new} +test frame-1.4 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -colormap new + .f configure -colormap . +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -colormap option after widget is created} + +test frame-1.5 {frame configuration options} -setup { + deleteWindows +} -body { frame .f -visual default - list [.f configure -visual] [catch {.f configure -visual best} msg] $msg -} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} -catch {destroy .f} -test frame-1.4 {frame configuration options} { - list [catch {frame .f -screen bogus} msg] $msg -} {1 {unknown option "-screen"}} -test frame-1.5 {frame configuration options} { - set result [list [catch {frame .f -container true} msg] $msg \ - [.f configure -container]] - destroy .f - set result -} {0 .f {-container container Container 0 1}} -test frame-1.6 {frame configuration options} { - list [catch {frame .f -container bogus} msg] $msg -} {1 {expected boolean value but got "bogus"}} -test frame-1.7 {frame configuration options} { + .f configure -visual +} -cleanup { + deleteWindows +} -result {-visual visual Visual {} default} +test frame-1.6 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -visual default + .f configure -visual best +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -visual option after widget is created} + +test frame-1.7 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-screen"} +test frame-1.8 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -container true +} -cleanup { + deleteWindows +} -result {.f} +test frame-1.9 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -container true + .f configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 1} +test frame-1.10 {frame configuration options} -setup { + deleteWindows +} -body { + frame .f -container bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {expected boolean value but got "bogus"} +test frame-1.11 {frame configuration options} -setup { + deleteWindows +} -body { frame .f - set result [list [catch {.f configure -container 1} msg] $msg] - destroy .f - set result -} {1 {can't modify -container option after widget is created}} -test frame-1.8 {frame configuration options} { + .f configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -container option after widget is created} +test frame-1.12 {frame configuration options} -setup { + deleteWindows +} -body { # Make sure all options can be set to the default value frame .f set opts {} @@ -95,120 +154,327 @@ test frame-1.8 {frame configuration options} { } eval frame .g $opts destroy .f .g -} {} +} -cleanup { + deleteWindows +} -result {} +destroy .f frame .f -set i 9 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #00ff00 #00ff00 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-height 100 100 not_a_number {bad screen distance "not_a_number"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} - {-padx 3 3 badValue {bad screen distance "badValue"}} - {-pady 4 4 badValue {bad screen distance "badValue"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-takefocus "any string" "any string" {} {}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - lassign $test opt goodValue goodResult badValue badResult - test frame-1.$i {frame configuration options} { - .f configure $opt $goodValue - lindex [.f configure $opt] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test frame-1.$i {frame configuration options} -body { - .f configure $opt $badValue - } -returnCodes error -result $badResult - } - .f configure $opt [lindex [.f configure $opt] 3] - incr i -} +test frame-1.13 {frame configuration options} -body { + .f configure -background #ff0000 + lindex [.f configure -background] 4 +} -cleanup { + .f configure -background [lindex [.f configure -background] 3] +} -result {#ff0000} +test frame-1.14 {frame configuration options} -body { + .f configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-1.15 {frame configuration options} -body { + .f configure -bd 4 + lindex [.f configure -bd] 4 +} -cleanup { + .f configure -bd [lindex [.f configure -bd] 3] +} -result {4} +test frame-1.16 {frame configuration options} -body { + .f configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.17 {frame configuration options} -body { + .f configure -bg #00ff00 + lindex [.f configure -bg] 4 +} -cleanup { + .f configure -bg [lindex [.f configure -bg] 3] +} -result {#00ff00} +test frame-1.18 {frame configuration options} -body { + .f configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-1.19 {frame configuration options} -body { + .f configure -borderwidth 1.3 + lindex [.f configure -borderwidth] 4 +} -cleanup { + .f configure -borderwidth [lindex [.f configure -borderwidth] 3] +} -result {1} +test frame-1.20 {frame configuration options} -body { + .f configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.21 {frame configuration options} -body { + .f configure -cursor arrow + lindex [.f configure -cursor] 4 +} -cleanup { + .f configure -cursor [lindex [.f configure -cursor] 3] +} -result {arrow} +test frame-1.22 {frame configuration options} -body { + .f configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test frame-1.23 {frame configuration options} -body { + .f configure -height 100 + lindex [.f configure -height] 4 +} -cleanup { + .f configure -height [lindex [.f configure -height] 3] +} -result {100} +test frame-1.24 {frame configuration options} -body { + .f configure -height not_a_number +} -returnCodes error -result {bad screen distance "not_a_number"} +test frame-1.25 {frame configuration options} -body { + .f configure -highlightbackground #112233 + lindex [.f configure -highlightbackground] 4 +} -cleanup { + .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] +} -result {#112233} +test frame-1.26 {frame configuration options} -body { + .f configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test frame-1.27 {frame configuration options} -body { + .f configure -highlightcolor #123456 + lindex [.f configure -highlightcolor] 4 +} -cleanup { + .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] +} -result {#123456} +test frame-1.28 {frame configuration options} -body { + .f configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-1.29 {frame configuration options} -body { + .f configure -highlightthickness 6 + lindex [.f configure -highlightthickness] 4 +} -cleanup { + .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] +} -result {6} +test frame-1.30 {frame configuration options} -body { + .f configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.31 {frame configuration options} -body { + .f configure -padx 3 + lindex [.f configure -padx] 4 +} -cleanup { + .f configure -padx [lindex [.f configure -padx] 3] +} -result {3} +test frame-1.32 {frame configuration options} -body { + .f configure -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.33 {frame configuration options} -body { + .f configure -pady 4 + lindex [.f configure -pady] 4 +} -cleanup { + .f configure -pady [lindex [.f configure -pady] 3] +} -result {4} +test frame-1.34 {frame configuration options} -body { + .f configure -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-1.35 {frame configuration options} -body { + .f configure -relief ridge + lindex [.f configure -relief] 4 +} -cleanup { + .f configure -relief [lindex [.f configure -relief] 3] +} -result {ridge} +test frame-1.36 {frame configuration options} -body { + .f configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-1.37 {frame configuration options} -body { + .f configure -takefocus {any string} + lindex [.f configure -takefocus] 4 +} -cleanup { + .f configure -takefocus [lindex [.f configure -takefocus] 3] +} -result {any string} +test frame-1.38 {frame configuration options} -body { + .f configure -width 32 + lindex [.f configure -width] 4 +} -cleanup { + .f configure -width [lindex [.f configure -width] 3] +} -result {32} +test frame-1.39 {frame configuration options} -body { + .f configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} destroy .f -test frame-2.1 {toplevel configuration options} { - catch {destroy .t} + +test frame-2.1 {toplevel configuration options} -setup { + deleteWindows +} -body { toplevel .t -width 200 -height 100 -class NewClass wm geometry .t +0+0 - list [.t configure -class] [catch {.t configure -class Another} msg] $msg -} {{-class class Class Toplevel NewClass} 1 {can't modify -class option after widget is created}} -test frame-2.2 {toplevel configuration options} { - catch {destroy .t} + .t configure -class +} -cleanup { + deleteWindows +} -result {-class class Class Toplevel NewClass} +test frame-2.2 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -class NewClass + wm geometry .t +0+0 + .t configure -class Another +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -class option after widget is created} + +test frame-2.3 {toplevel configuration options} -setup { + deleteWindows +} -body { toplevel .t -width 200 -height 100 -colormap new wm geometry .t +0+0 - list [.t configure -colormap] [catch {.t configure -colormap .} msg] $msg -} {{-colormap colormap Colormap {} new} 1 {can't modify -colormap option after widget is created}} -test frame-2.3 {toplevel configuration options} { + .t configure -colormap +} -cleanup { + deleteWindows +} -result {-colormap colormap Colormap {} new} +test frame-2.4 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -colormap new + wm geometry .t +0+0 + .t configure -colormap . +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -colormap option after widget is created} + +test frame-2.5 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + .t configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -container option after widget is created} +test frame-2.6 {toplevel configuration options} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 - list [catch {.t configure -container 1} msg] $msg [.t configure -container] -} {1 {can't modify -container option after widget is created} {-container container Container 0 0}} -test frame-2.4 {toplevel configuration options} { + catch {.t configure -container 1} + .t configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 0} + +test frame-2.7 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -colormap bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {bad window path name "bogus"} + + +test frame-2.8 {toplevel configuration options} -constraints { + win +} -setup { + deleteWindows +} -body { catch {destroy .t} - list [catch {toplevel .t -width 200 -height 100 -colormap bogus} msg] $msg -} {1 {bad window path name "bogus"}} -set default "[winfo visual .] [winfo depth .]" -if {$tcl_platform(platform) == "windows"} { -test frame-2.5 {toplevel configuration options} { + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + .t configure -use 0x44022 +} -cleanup { + deleteWindows +} -returnCodes error -result {window "0x44022" doesn't exist} +test frame-2.9 {toplevel configuration options} -constraints { + win +} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 - list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] -} {1 {window "0x44022" doesn't exist} {-use use Use {} {}}} -} else { -test frame-2.5 {toplevel configuration options} { + catch {.t configure -use 0x44022} + .t configure -use +} -cleanup { + deleteWindows +} -result {-use use Use {} {}} + +test frame-2.10 {toplevel configuration options} -constraints { + nonwin +} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 wm geometry .t +0+0 - list [catch {.t configure -use 0x44022} msg] $msg [.t configure -use] -} {1 {can't modify -use option after widget is created} {-use use Use {} {}}} -} + .t configure -use 0x44022 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -use option after widget is created} +test frame-2.11 {toplevel configuration options} -constraints { + nonwin +} -setup { + deleteWindows +} -body { + catch {destroy .t} + toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + catch {.t configure -use 0x44022} + .t configure -use +} -cleanup { + deleteWindows +} -result {-use use Use {} {}} -test frame-2.6 {toplevel configuration options} { +test frame-2.12 {toplevel configuration options} -setup { + deleteWindows +} -body { catch {destroy .t} toplevel .t -width 200 -height 100 -visual default wm geometry .t +0+0 - list [.t configure -visual] [catch {.t configure -visual best} msg] $msg -} {{-visual visual Visual {} default} 1 {can't modify -visual option after widget is created}} -test frame-2.7 {toplevel configuration options} { - catch {destroy .t} - list [catch {toplevel .t -width 200 -height 100 -visual who_knows?} msg] $msg -} {1 {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test frame-2.8 {toplevel configuration options} haveDISPLAY { + .t configure -visual +} -cleanup { + deleteWindows +} -result {-visual visual Visual {} default} +test frame-2.13 {toplevel configuration options} -setup { + deleteWindows +} -body { catch {destroy .t} + toplevel .t -width 200 -height 100 -visual default + wm geometry .t +0+0 + .t configure -visual best +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -visual option after widget is created} + +test frame-2.14 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -visual who_knows? +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup { + deleteWindows +} -body { toplevel .t -width 200 -height 100 -screen $env(DISPLAY) wm geometry .t +0+0 - set cfg [string compare [.t configure -screen] \ - "-screen screen Screen {} $env(DISPLAY)"] - list $cfg [catch {.t configure -screen another} msg] $msg -} {0 1 {can't modify -screen option after widget is created}} -test frame-2.9 {toplevel configuration options} { - catch {destroy .t} - list [catch {toplevel .t -width 200 -height 100 -screen bogus} msg] $msg -} {1 {couldn't connect to display "bogus"}} -test frame-2.10 {toplevel configuration options} { - catch {destroy .t} - catch {destroy .x} + string compare [.t configure -screen] "-screen screen Screen {} $env(DISPLAY)" +} -cleanup { + deleteWindows +} -result {0} +test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -screen $env(DISPLAY) + wm geometry .t +0+0 + .t configure -screen another +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -screen option after widget is created} + +test frame-2.17 {toplevel configuration options} -setup { + deleteWindows +} -body { + toplevel .t -width 200 -height 100 -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't connect to display "bogus"} +test frame-2.18 {toplevel configuration options} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 - set result [list \ - [catch {toplevel .x -container 1 -use [winfo id .t]} msg] $msg] - destroy .t .x - set result -} {1 {A window cannot have both the -use and the -container option set.}} -test frame-2.11 {toplevel configuration options} { + toplevel .x -container 1 -use [winfo id .t] +} -cleanup { + deleteWindows +} -returnCodes error -result {A window cannot have both the -use and the -container option set.} +test frame-2.19 {toplevel configuration options} -setup { + deleteWindows + set opts {} +} -body { # Make sure all options can be set to the default value toplevel .f - set opts {} foreach opt [.f configure] { if {[llength $opt] == 5} { lappend opts [lindex $opt 0] [lindex $opt 4] @@ -216,112 +482,184 @@ test frame-2.11 {toplevel configuration options} { } eval toplevel .g $opts destroy .f .g -} {} +} -cleanup { + deleteWindows +} -result {} + -catch {destroy .t} +destroy .t toplevel .t -width 300 -height 150 wm geometry .t +0+0 update -set i 12 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #00ff00 #00ff00 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-height 100 100 not_a_number {bad screen distance "not_a_number"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 3 3 badValue {bad screen distance "badValue"}} - {-padx 3 3 badValue {bad screen distance "badValue"}} - {-pady 4 4 badValue {bad screen distance "badValue"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - lassign $test opt goodValue goodResult badValue badResult - test frame-2.$i {toplevel configuration options} { - .t configure $opt $goodValue - lindex [.t configure $opt] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test frame-2.$i {toplevel configuration options} -body { - .t configure $opt $badValue - } -returnCodes error -result $badResult - } - .t configure $opt [lindex [.t configure $opt] 3] - incr i -} +test frame-2.20 {toplevel configuration options} -body { + .t configure -background #ff0000 + lindex [.t configure -background] 4 +} -result {#ff0000} +test frame-2.21 {toplevel configuration options} -body { + .t configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-2.22 {toplevel configuration options} -body { + .t configure -bd 4 + lindex [.t configure -bd] 4 +} -result {4} +test frame-2.23 {toplevel configuration options} -body { + .t configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.24 {toplevel configuration options} -body { + .t configure -bg #00ff00 + lindex [.t configure -bg] 4 +} -result {#00ff00} +test frame-2.25 {toplevel configuration options} -body { + .t configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-2.26 {toplevel configuration options} -body { + .t configure -borderwidth 1.3 + lindex [.t configure -borderwidth] 4 +} -result {1} +test frame-2.27 {toplevel configuration options} -body { + .t configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.28 {toplevel configuration options} -body { + .t configure -cursor arrow + lindex [.t configure -cursor] 4 +} -result {arrow} +test frame-2.29 {toplevel configuration options} -body { + .t configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test frame-2.30 {toplevel configuration options} -body { + .t configure -height 100 + lindex [.t configure -height] 4 +} -result {100} +test frame-2.31 {toplevel configuration options} -body { + .t configure -height not_a_number +} -returnCodes error -result {bad screen distance "not_a_number"} +test frame-2.32 {toplevel configuration options} -body { + .t configure -highlightcolor #123456 + lindex [.t configure -highlightcolor] 4 +} -result {#123456} +test frame-2.33 {toplevel configuration options} -body { + .t configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-2.34 {toplevel configuration options} -body { + .t configure -highlightthickness 3 + lindex [.t configure -highlightthickness] 4 +} -result {3} +test frame-2.35 {toplevel configuration options} -body { + .t configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.36 {toplevel configuration options} -body { + .t configure -padx 3 + lindex [.t configure -padx] 4 +} -result {3} +test frame-2.37 {toplevel configuration options} -body { + .t configure -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.38 {toplevel configuration options} -body { + .t configure -pady 4 + lindex [.t configure -pady] 4 +} -result {4} +test frame-2.39 {toplevel configuration options} -body { + .t configure -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-2.40 {toplevel configuration options} -body { + .t configure -relief ridge + lindex [.t configure -relief] 4 +} -result {ridge} +test frame-2.41 {toplevel configuration options} -body { + .t configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-2.42 {toplevel configuration options} -body { + .t configure -width 32 + lindex [.t configure -width] 4 +} -result {32} +test frame-2.43 {toplevel configuration options} -body { + .t configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} +destroy .t + test frame-3.1 {TkCreateFrame procedure} -body { frame -} -returnCodes error -result {wrong # args: should be "frame pathName ?options?"} +} -returnCodes error -result {wrong # args: should be "frame pathName ?-option value ...?"} test frame-3.2 {TkCreateFrame procedure} -setup { - catch {destroy .f} + deleteWindows frame .f } -body { .f configure -class } -cleanup { - destroy .f + deleteWindows } -result {-class class Class Frame Frame} test frame-3.3 {TkCreateFrame procedure} -setup { - catch {destroy .t} + deleteWindows toplevel .t wm geometry .t +0+0 } -body { .t configure -class } -cleanup { - destroy .t + deleteWindows } -result {-class class Class Toplevel Toplevel} -test frame-3.4 {TkCreateFrame procedure} { - catch {destroy .t} +test frame-3.4 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 wm geometry .t +0+0 update list [lindex [.t configure -width] 4] \ [lindex [.t configure -background] 4] \ [lindex [.t configure -height] 4] -} {350 black 90} +} -cleanup { + deleteWindows +} -result {350 black 90} # Be sure that the -class, -colormap, and -visual options are processed # before configuring the widget. - -test frame-3.5 {TkCreateFrame procedure} { - catch {destroy .f} +test frame-3.5 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *NewFrame.background #123456 frame .f -class NewFrame - option clear lindex [.f configure -background] 4 -} {#123456} -test frame-3.6 {TkCreateFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows + option clear +} -result {#123456} +test frame-3.6 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *NewFrame.background #123456 frame .f -class NewFrame - option clear lindex [.f configure -background] 4 -} {#123456} -test frame-3.7 {TkCreateFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows + option clear +} -result {#123456} +test frame-3.7 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *NewFrame.background #332211 option add *f.class NewFrame frame .f - option clear list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] -} {NewFrame #332211} -test frame-3.8 {TkCreateFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows + option clear +} -result {NewFrame #332211} +test frame-3.8 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { option add *Silly.background #122334 option add *f.Class Silly frame .f - option clear list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] -} {Silly #122334} -test frame-3.9 {TkCreateFrame procedure, -use option} -setup { - catch {destroy .t} - catch {destroy .x} -} -constraints unix -body { +} -cleanup { + deleteWindows + option clear +} -result {Silly #122334} +test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { + unix +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green @@ -330,12 +668,13 @@ test frame-3.9 {TkCreateFrame procedure, -use option} -setup { [expr {[winfo rooty .x] - [winfo rooty .t]}] \ [winfo width .t] [winfo height .t] } -cleanup { - destroy .t + deleteWindows } -result {0 0 140 300} -test frame-3.10 {TkCreateFrame procedure, -use option} -setup { - catch {destroy .t} - catch {destroy .x} -} -constraints unix -body { +test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { + unix +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 option add *x.use [winfo id .t] @@ -353,26 +692,38 @@ test frame-3.10 {TkCreateFrame procedure, -use option} -setup { # they are run on a pseudocolor display of depth 8). Even so, they # are non-portable: some machines don't seem to ever run out of # colors. - if {[testConstraint defaultPseudocolor8]} { eatColors .t1 } -test frame-3.11 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +test frame-3.11 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 wm geometry .t +0+0 update colorsFree .t -} {0} -test frame-3.12 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {0} +test frame-3.12 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 -colormap new wm geometry .t +0+0 update colorsFree .t -} {1} -test frame-3.13 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.13 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { option add *t.class Toplevel2 option add *Toplevel2.colormap new toplevel .t -width 300 -height 200 -bg #475601 @@ -380,9 +731,14 @@ test frame-3.13 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { update option clear colorsFree .t -} {1} -test frame-3.14 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.14 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { option add *t.class Toplevel3 option add *Toplevel3.Colormap new toplevel .t -width 300 -height 200 -bg #475601 -colormap new @@ -390,11 +746,14 @@ test frame-3.14 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { update option clear colorsFree .t -} {1} -test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup { - catch {destroy .t} - catch {destroy .x} -} -constraints {defaultPseudocolor8 unix nonPortable} -body { +} -cleanup { + deleteWindows +} -result {1} +test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -constraints { + defaultPseudocolor8 unix nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -width 300 -height 120 wm geometry .t +0+0 toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new @@ -403,30 +762,48 @@ test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -setup { } -cleanup { destroy .t } -result {0 1} -test frame-3.16 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +test frame-3.16 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 -visual default wm geometry .t +0+0 update colorsFree .t -} {0} -test frame-3.17 {TkCreateFrame procedure} {defaultPseudocolor8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {0} +test frame-3.17 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -width 300 -height 200 -bg #475601 -visual default \ -colormap new wm geometry .t +0+0 update colorsFree .t -} {1} -test frame-3.18 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.18 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 -} {1} -test frame-3.19 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1} +test frame-3.19 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { option add *t.class T4 option add *T4.visual {grayscale 8} toplevel .t -width 300 -height 200 -bg #434343 @@ -434,9 +811,14 @@ test frame-3.19 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 no update option clear list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] -} {1 {grayscale 8}} -test frame-3.20 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1 {grayscale 8}} +test frame-3.20 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { set x ok option add *t.class T5 option add *T5.Visual {grayscale 8} @@ -445,20 +827,28 @@ test frame-3.20 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 no update option clear list [colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] -} {1 {grayscale 8}} -test frame-3.21 {TkCreateFrame procedure} {defaultPseudocolor8 haveGrayscale8 nonPortable} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {1 {grayscale 8}} +test frame-3.21 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { set x ok toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 wm geometry .t +0+0 update colorsFree .t 131 131 131 -} {1} +} -cleanup { + deleteWindows +} -result {1} if {[testConstraint defaultPseudocolor8]} { destroy .t1 } + test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { - catch {destroy .t} + deleteWindows } -body { toplevel .t wm geometry .t +0+0 @@ -469,87 +859,103 @@ test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { update lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] } -cleanup { - destroy .t + deleteWindows } -result {200 200 1 1} test frame-3.23 {TkCreateFrame procedure} -setup { - catch {destroy .f} + deleteWindows } -body { frame .f -gorp glob } -returnCodes error -result {unknown option "-gorp"} test frame-3.24 {TkCreateFrame procedure} -setup { - catch {destroy .t} + deleteWindows } -body { toplevel .t -width 300 -height 200 -colormap new -bogus option wm geometry .t +0+0 } -returnCodes error -result {unknown option "-bogus"} -test frame-4.1 {TkCreateFrame procedure} { - catch {destroy .f} + +test frame-4.1 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { catch {frame .f -gorp glob} winfo exists .f -} 0 -test frame-4.2 {TkCreateFrame procedure} { - catch {destroy .f} +} -result 0 +test frame-4.2 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { list [frame .f -width 200 -height 100] [winfo exists .f] -} {.f 1} +} -cleanup { + deleteWindows +} -result {.f 1} + -catch {destroy .f} frame .f -highlightcolor black -test frame-5.1 {FrameWidgetCommand procedure} { - list [catch .f msg] $msg -} {1 {wrong # args: should be ".f option ?arg arg ...?"}} -test frame-5.2 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget} msg] $msg -} {1 {wrong # args: should be ".f cget option"}} -test frame-5.3 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget a b} msg] $msg -} {1 {wrong # args: should be ".f cget option"}} -test frame-5.4 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-5.5 {FrameWidgetCommand procedure, cget option} { +test frame-5.1 {FrameWidgetCommand procedure} -body { + .f +} -returnCodes error -result {wrong # args: should be ".f option ?arg ...?"} +test frame-5.2 {FrameWidgetCommand procedure, cget option} -body { + .f cget +} -returnCodes error -result {wrong # args: should be ".f cget option"} +test frame-5.3 {FrameWidgetCommand procedure, cget option} -body { + .f cget a b +} -returnCodes error -result {wrong # args: should be ".f cget option"} +test frame-5.4 {FrameWidgetCommand procedure, cget option} -body { + .f cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test frame-5.5 {FrameWidgetCommand procedure, cget option} -body { .f cget -highlightcolor -} {black} -test frame-5.6 {FrameWidgetCommand procedure, cget option} { - list [catch {.f cget -screen} msg] $msg -} {1 {unknown option "-screen"}} -test frame-5.7 {FrameWidgetCommand procedure, cget option} { - catch {destroy .t} +} -result {black} +test frame-5.6 {FrameWidgetCommand procedure, cget option} -body { + .f cget -screen +} -returnCodes error -result {unknown option "-screen"} +test frame-5.7 {FrameWidgetCommand procedure, cget option} -setup { + destroy .t +} -body { toplevel .t - catch {.t cget -screen} -} {0} -catch {destroy .t} -test frame-5.8 {FrameWidgetCommand procedure, configure option} { + .t cget -screen +} -cleanup { + destroy .t +} -returnCodes ok -match glob -result * + +test frame-5.8 {FrameWidgetCommand procedure, configure option} -body { llength [.f configure] -} {18} -test frame-5.9 {FrameWidgetCommand procedure, configure option} { - list [catch {.f configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-5.10 {FrameWidgetCommand procedure, configure option} { - list [catch {.f configure -gorp bogus} msg] $msg -} {1 {unknown option "-gorp"}} -test frame-5.11 {FrameWidgetCommand procedure, configure option} { - list [catch {.f configure -width 200 -height} msg] $msg -} {1 {value for "-height" missing}} -test frame-5.12 {FrameWidgetCommand procedure} { - list [catch {.f swizzle} msg] $msg -} {1 {bad option "swizzle": must be cget or configure}} -test frame-5.13 {FrameWidgetCommand procedure, configure option} { +} -result {18} +test frame-5.9 {FrameWidgetCommand procedure, configure option} -body { + .f configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test frame-5.10 {FrameWidgetCommand procedure, configure option} -body { + .f configure -gorp bogus +} -returnCodes error -result {unknown option "-gorp"} +test frame-5.11 {FrameWidgetCommand procedure, configure option} -body { + .f configure -width 200 -height +} -returnCodes error -result {value for "-height" missing} +test frame-5.12 {FrameWidgetCommand procedure} -body { + .f swizzle +} -returnCodes error -result {bad option "swizzle": must be cget or configure} +test frame-5.13 {FrameWidgetCommand procedure, configure option} -body { llength [. configure] -} {21} +} -result {21} +destroy .f -test frame-6.1 {ConfigureFrame procedure} { - catch {destroy .f} +test frame-6.1 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { frame .f -width 150 list [winfo reqwidth .f] [winfo reqheight .f] -} {150 1} -test frame-6.2 {ConfigureFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows +} -result {150 1} +test frame-6.2 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { frame .f -height 97 list [winfo reqwidth .f] [winfo reqheight .f] -} {1 97} -test frame-6.3 {ConfigureFrame procedure} { - catch {destroy .f} +} -cleanup { + deleteWindows +} -result {1 97} +test frame-6.3 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { frame .f set result {} lappend result [winfo reqwidth .f] [winfo reqheight .f] @@ -557,77 +963,98 @@ test frame-6.3 {ConfigureFrame procedure} { lappend result [winfo reqwidth .f] [winfo reqheight .f] .f configure -width 0 -height 0 lappend result [winfo reqwidth .f] [winfo reqheight .f] -} {1 1 100 180 100 180} +} -cleanup { + deleteWindows +} -result {1 1 100 180 100 180} -test frame-7.1 {FrameEventProc procedure} { +test frame-7.1 {FrameEventProc procedure} -setup { + deleteWindows +} -body { frame .frame2 set result [info commands .frame2] destroy .frame2 lappend result [info commands .frame2] -} {.frame2 {}} -test frame-7.2 {FrameEventProc procedure} { - deleteWindows +} -result {.frame2 {}} +test frame-7.2 {FrameEventProc procedure} -setup { + deleteWindows + set x {} +} -body { frame .f1 -bg #543210 rename .f1 .f2 - set x {} lappend x [winfo children .] lappend x [.f2 cget -bg] destroy .f1 lappend x [info command .f*] [winfo children .] -} {.f1 #543210 {} {}} - -test frame-8.1 {FrameCmdDeletedProc procedure} { +} -cleanup { deleteWindows +} -result {.f1 #543210 {} {}} + +test frame-8.1 {FrameCmdDeletedProc procedure} -setup { + deleteWindows +} -body { frame .f1 rename .f1 {} list [info command .f*] [winfo children .] -} {{} {}} -test frame-8.2 {FrameCmdDeletedProc procedure} { +} -cleanup { deleteWindows +} -result {{} {}} +test frame-8.2 {FrameCmdDeletedProc procedure} -setup { + deleteWindows +} -body { toplevel .f1 -menu .m wm geometry .f1 +0+0 update rename .f1 {} update list [info command .f*] [winfo children .] -} {{} {}} +} -cleanup { + deleteWindows +} -result {{} {}} # # This one fails with the dash-patch!!!! Still don't know why :-( # -#test frame-8.3 {FrameCmdDeletedProc procedure} { +#test frame-8.3 {FrameCmdDeletedProc procedure} -setup { # eval destroy [winfo children .] +# deleteWindows +#} -body { # toplevel .f1 -menu .m # wm geometry .f1 +0+0 # menu .m # update # rename .f1 {} # update -# set result [list [info command .f*] [winfo children .]] +# list [info command .f*] [winfo children .] +#} -cleanup { # eval destroy [winfo children .] -# set result -#} {{} .m} +# deleteWindows +#} -result {{} .m} -test frame-9.1 {MapFrame procedure} { - catch {destroy .t} +test frame-9.1 {MapFrame procedure} -setup { + deleteWindows +} -body { toplevel .t -width 100 -height 400 wm geometry .t +0+0 set result [winfo ismapped .t] update idletasks lappend result [winfo ismapped .t] -} {0 1} -test frame-9.2 {MapFrame procedure} { - catch {destroy .t} +} -cleanup { + deleteWindows +} -result {0 1} +test frame-9.2 {MapFrame procedure} -setup { + deleteWindows +} -body { toplevel .t -width 100 -height 400 wm geometry .t +0+0 destroy .t update winfo exists .t -} {0} -test frame-9.3 {MapFrame procedure, window deleted while mapping} { +} -result {0} +test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup { + deleteWindows +} -body { toplevel .t2 -width 200 -height 200 wm geometry .t2 +0+0 tkwait visibility .t2 - catch {destroy .t} toplevel .t -width 100 -height 400 wm geometry .t +0+0 frame .t2.f -width 50 -height 50 @@ -635,53 +1062,66 @@ test frame-9.3 {MapFrame procedure, window deleted while mapping} { pack .t2.f -side top update idletasks winfo exists .t -} {0} +} -cleanup { + deleteWindows +} -result {0} -set l [interp hidden] -deleteWindows -test frame-10.1 {frame widget vs hidden commands} { - catch {destroy .t} +test frame-10.1 {frame widget vs hidden commands} -setup { + deleteWindows +} -body { + set l [interp hidden] frame .t interp hide {} .t destroy .t - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -result 1 -test frame-11.1 {TkInstallFrameMenu} { - catch {destroy .t} + +test frame-11.1 {TkInstallFrameMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 .m1.system add command -label foo - list [toplevel .t -menu .m1] [destroy .m1] [destroy .t] -} {.t {} {}} -test frame-11.2 {TkInstallFrameMenu - frame renamed} { - catch {destroy .t} + toplevel .t -menu .m1 +} -cleanup { + deleteWindows +} -result {.t} +test frame-11.2 {TkInstallFrameMenu - frame renamed} -setup { + deleteWindows +} -body { catch {rename foo {}} menu .m1 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 .m1.system add command -label foo toplevel .t - list [rename .t foo] [destroy .t] [destroy foo] [destroy .m1] -} {{} {} {} {}} + rename .t foo +} -cleanup { + deleteWindows +} -result {} + -test frame-12.1 {FrameWorldChanged procedure} { +test frame-12.1 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { # Test -bd -padx and -pady - destroy .f frame .f -borderwidth 2 -padx 3 -pady 4 place .f -x 0 -y 0 -width 40 -height 40 pack [frame .f.f] -fill both -expand 1 update - set result [list [winfo x .f.f] [winfo y .f.f] \ - [winfo width .f.f] [winfo height .f.f]] - destroy .f - set result -} {5 6 30 28} -test frame-12.2 {FrameWorldChanged procedure} { + list [winfo x .f.f] [winfo y .f.f] [winfo width .f.f] [winfo height .f.f] +} -cleanup { + deleteWindows +} -result {5 6 30 28} +test frame-12.2 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { # Test all -labelanchor positions - destroy .f set font {helvetica 12} labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \ -text "Mupp" @@ -710,12 +1150,14 @@ test frame-12.2 {FrameWorldChanged procedure} { [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\ [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}] } - destroy .f - set result -} {1 1 1 1 1 1 1 1 1 1 1 1} -test frame-12.3 {FrameWorldChanged procedure} { + return $result +} -cleanup { + deleteWindows +} -result {1 1 1 1 1 1 1 1 1 1 1 1} +test frame-12.3 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { # Check reaction on font change - destroy .f font create myfont -family courier -size 10 labelframe .f -font myfont -text Mupp place .f -x 0 -y 0 -width 40 -height 40 @@ -727,103 +1169,267 @@ test frame-12.3 {FrameWorldChanged procedure} { update set h2 [font metrics myfont -linespace] set y2 [winfo y .f.f] - destroy .f - font delete myfont expr {($h2 - $h1) - ($y2 - $y1)} -} {0} +} -cleanup { + deleteWindows + font delete myfont +} -result {0} + -test frame-13.1 {labelframe configuration options} { +test frame-13.1 {labelframe configuration options} -setup { + deleteWindows +} -body { labelframe .f -class NewFrame - list [.f configure -class] [catch {.f configure -class Different} msg] $msg -} {{-class class Class Labelframe NewFrame} 1 {can't modify -class option after widget is created}} -catch {destroy .f} -test frame-13.2 {labelframe configuration options} { - list [catch {labelframe .f -colormap new} msg] $msg -} {0 .f} -catch {destroy .f} -test frame-13.3 {labelframe configuration options} { - list [catch {labelframe .f -visual default} msg] $msg -} {0 .f} -catch {destroy .f} -test frame-13.4 {labelframe configuration options} { - list [catch {labelframe .f -screen bogus} msg] $msg -} {1 {unknown option "-screen"}} -test frame-13.5 {labelframe configuration options} { - set result [list [catch {labelframe .f -container true} msg] $msg \ - [.f configure -container]] - destroy .f - set result -} {0 .f {-container container Container 0 1}} -test frame-13.6 {labelframe configuration options} { - list [catch {labelframe .f -container bogus} msg] $msg -} {1 {expected boolean value but got "bogus"}} -test frame-13.7 {labelframe configuration options} { + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class Labelframe NewFrame} +test frame-13.2 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -class NewFrame + .f configure -class Different +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -class option after widget is created} +test frame-13.3 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -colormap new +} -cleanup { + deleteWindows +} -result {.f} +test frame-13.4 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -visual default +} -cleanup { + deleteWindows +} -result {.f} +test frame-13.5 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-screen"} +test frame-13.6 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container true +} -cleanup { + deleteWindows +} -result {.f} +test frame-13.7 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container true + .f configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 1} +test frame-13.8 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {expected boolean value but got "bogus"} +test frame-13.9 {labelframe configuration options} -setup { + deleteWindows +} -body { labelframe .f - set result [list [catch {.f configure -container 1} msg] $msg] - destroy .f - set result -} {1 {can't modify -container option after widget is created}} + .f configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -container option after widget is created} + +destroy .f labelframe .f -set i 8 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #00ff00 #00ff00 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-fg #0000ff #0000ff non-existent - {unknown color name "non-existent"}} - {-font {courier 8} {courier 8} {} {}} - {-foreground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-height 100 100 not_a_number {bad screen distance "not_a_number"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 6 6 badValue {bad screen distance "badValue"}} - {-labelanchor se se badValue {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws}} - {-padx 3 3 badValue {bad screen distance "badValue"}} - {-pady 4 4 badValue {bad screen distance "badValue"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-takefocus "any string" "any string" {} {}} - {-text "any string" "any string" {} {}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - lassign $test name goodValue goodResult badValue badResult - test frame-13.$i {labelframe configuration options} { - .f configure $name $goodValue - lindex [.f configure $name] 4 - } $goodResult - incr i - if {$badValue ne ""} { - test frame-13.$i {labelframe configuration options} -body { - .f configure $name $badValue - } -returnCodes error -result $badResult - } - .f configure $name [lindex [.f configure $name] 3] - incr i -} +test frame-13.10 {labelframe configuration options} -body { + .f configure -background #ff0000 + lindex [.f configure -background] 4 +} -cleanup { + .f configure -background [lindex [.f configure -background] 3] +} -result {#ff0000} +test frame-13.11 {labelframe configuration options} -body { + .f configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.12 {labelframe configuration options} -body { + .f configure -bd 4 + lindex [.f configure -bd] 4 +} -cleanup { + .f configure -bd [lindex [.f configure -bd] 3] +} -result {4} +test frame-13.13 {labelframe configuration options} -body { + .f configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.14 {labelframe configuration options} -body { + .f configure -bg #00ff00 + lindex [.f configure -bg] 4 +} -cleanup { + .f configure -bg [lindex [.f configure -bg] 3] +} -result {#00ff00} +test frame-13.15 {labelframe configuration options} -body { + .f configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.16 {labelframe configuration options} -body { + .f configure -borderwidth 1.3 + lindex [.f configure -borderwidth] 4 +} -cleanup { + .f configure -borderwidth [lindex [.f configure -borderwidth] 3] +} -result {1} +test frame-13.17 {labelframe configuration options} -body { + .f configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.18 {labelframe configuration options} -body { + .f configure -cursor arrow + lindex [.f configure -cursor] 4 +} -cleanup { + .f configure -cursor [lindex [.f configure -cursor] 3] +} -result {arrow} +test frame-13.19 {labelframe configuration options} -body { + .f configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test frame-13.20 {labelframe configuration options} -body { + .f configure -fg #0000ff + lindex [.f configure -fg] 4 +} -cleanup { + .f configure -fg [lindex [.f configure -fg] 3] +} -result {#0000ff} +test frame-13.21 {labelframe configuration options} -body { + .f configure -fg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.22 {labelframe configuration options} -body { + .f configure -font {courier 8} + lindex [.f configure -font] 4 +} -cleanup { + .f configure -font [lindex [.f configure -font] 3] +} -result {courier 8} +test frame-13.23 {labelframe configuration options} -body { + .f configure -foreground #ff0000 + lindex [.f configure -foreground] 4 +} -cleanup { + .f configure -foreground [lindex [.f configure -foreground] 3] +} -result {#ff0000} +test frame-13.24 {labelframe configuration options} -body { + .f configure -foreground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.25 {labelframe configuration options} -body { + .f configure -height 100 + lindex [.f configure -height] 4 +} -cleanup { + .f configure -height [lindex [.f configure -height] 3] +} -result {100} +test frame-13.26 {labelframe configuration options} -body { + .f configure -height not_a_number +} -returnCodes error -result {bad screen distance "not_a_number"} +test frame-13.27 {labelframe configuration options} -body { + .f configure -highlightbackground #112233 + lindex [.f configure -highlightbackground] 4 +} -cleanup { + .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] +} -result {#112233} +test frame-13.28 {labelframe configuration options} -body { + .f configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test frame-13.29 {labelframe configuration options} -body { + .f configure -highlightcolor #123456 + lindex [.f configure -highlightcolor] 4 +} -cleanup { + .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] +} -result {#123456} +test frame-13.30 {labelframe configuration options} -body { + .f configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test frame-13.31 {labelframe configuration options} -body { + .f configure -highlightthickness 6 + lindex [.f configure -highlightthickness] 4 +} -cleanup { + .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] +} -result {6} +test frame-13.32 {labelframe configuration options} -body { + .f configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.33 {labelframe configuration options} -body { + .f configure -labelanchor se + lindex [.f configure -labelanchor] 4 +} -cleanup { + .f configure -labelanchor [lindex [.f configure -labelanchor] 3] +} -result {se} +test frame-13.34 {labelframe configuration options} -body { + .f configure -labelanchor badValue +} -returnCodes error -result {bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws} +test frame-13.35 {labelframe configuration options} -body { + .f configure -padx 3 + lindex [.f configure -padx] 4 +} -cleanup { + .f configure -padx [lindex [.f configure -padx] 3] +} -result {3} +test frame-13.36 {labelframe configuration options} -body { + .f configure -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.37 {labelframe configuration options} -body { + .f configure -pady 4 + lindex [.f configure -pady] 4 +} -cleanup { + .f configure -pady [lindex [.f configure -pady] 3] +} -result {4} +test frame-13.38 {labelframe configuration options} -body { + .f configure -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test frame-13.39 {labelframe configuration options} -body { + .f configure -relief ridge + lindex [.f configure -relief] 4 +} -cleanup { + .f configure -relief [lindex [.f configure -relief] 3] +} -result {ridge} +test frame-13.40 {labelframe configuration options} -body { + .f configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test frame-13.41 {labelframe configuration options} -body { + .f configure -takefocus {any string} + lindex [.f configure -takefocus] 4 +} -cleanup { + .f configure -takefocus [lindex [.f configure -takefocus] 3] +} -result {any string} +test frame-13.42 {labelframe configuration options} -body { + .f configure -text {any string} + lindex [.f configure -text] 4 +} -cleanup { + .f configure -text [lindex [.f configure -text] 3] +} -result {any string} +test frame-13.43 {labelframe configuration options} -body { + .f configure -width 32 + lindex [.f configure -width] 4 +} -cleanup { + .f configure -width [lindex [.f configure -width] 3] +} -result {32} +test frame-13.44 {labelframe configuration options} -body { + .f configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} destroy .f -test frame-14.1 {labelframe labelwidget option} { + +test frame-14.1 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test that label is moved in stacking order - destroy .f .l label .l -text Mupp -font {helvetica 8} labelframe .f -labelwidget .l pack .f frame .f.f -width 50 -height 50 pack .f.f update - set res [list [winfo children .] [winfo width .f] \ - [expr {[winfo height .f] - [winfo height .l]}]] - destroy .f .l - set res -} {{.f .l} 54 52} -test frame-14.2 {labelframe labelwidget option} { + list [winfo children .] [winfo width .f] \ + [expr {[winfo height .f] - [winfo height .l]}] +} -cleanup { + deleteWindows +} -result {{.f .l} 54 52} +test frame-14.2 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test the labelframe's reaction if the label is destroyed - destroy .f .l label .l -text Aratherlonglabel labelframe .f -labelwidget .l pack .f @@ -836,12 +1442,13 @@ test frame-14.2 {labelframe labelwidget option} { lappend res [.f cget -labelwidget] update lappend res [expr {[winfo width .f] - [winfo width .f.l]}] - destroy .f - set res -} {.l 12 {} 4} -test frame-14.3 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {.l 12 {} 4} +test frame-14.3 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test the labelframe's reaction if the label is stolen - destroy .f .l label .l -text Aratherlonglabel labelframe .f -labelwidget .l pack .f @@ -854,12 +1461,13 @@ test frame-14.3 {labelframe labelwidget option} { lappend res [.f cget -labelwidget] update lappend res [expr {[winfo width .f] - [winfo width .f.l]}] - destroy .f .l - set res -} {.l 12 {} 4} -test frame-14.4 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {.l 12 {} 4} +test frame-14.4 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test the label's reaction if the labelframe is destroyed - destroy .f .l label .l -text Mupp labelframe .f -labelwidget .l pack .f @@ -867,12 +1475,13 @@ test frame-14.4 {labelframe labelwidget option} { set res [list [winfo manager .l]] destroy .f lappend res [winfo manager .l] - destroy .l - set res -} {labelframe {}} -test frame-14.5 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {labelframe {}} +test frame-14.5 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Test that the labelframe reacts on changes in label - destroy .f .l label .l -text Aratherlonglabel labelframe .f -labelwidget .l pack .f @@ -889,24 +1498,25 @@ test frame-14.5 {labelframe labelwidget option} { update lappend res [expr {[winfo width .f] - [winfo width .l]}] lappend res [expr {[winfo width .f] > $first}] - destroy .f .l - set res -} {12 12 1 12 1} -test frame-14.6 {labelframe labelwidget option} { +} -cleanup { + deleteWindows +} -result {12 12 1 12 1} +test frame-14.6 {labelframe labelwidget option} -setup { + deleteWindows +} -body { # Destroying a labelframe with a child label caused a crash # when not handling mapping of the label correctly. # This test does not test anything directly, it's just ment # to catch if the same mistake is made again. - destroy .f labelframe .f pack .f label .f.l -text Mupp .f configure -labelwidget .f.l update - destroy .f -} {} - -catch {destroy .f} +} -cleanup { + deleteWindows +} -result {} +deleteWindows rename eatColors {} rename colorsFree {} @@ -914,3 +1524,6 @@ rename colorsFree {} cleanupTests return + + + diff --git a/tests/geometry.test b/tests/geometry.test index 04ab578..13cc515 100644 --- a/tests/geometry.test +++ b/tests/geometry.test @@ -7,9 +7,16 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +proc getsize w { + regexp {(^[^+-]*)} [wm geometry $w] foo x + return $x +} + +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test + wm geometry . 300x300 raise . @@ -23,15 +30,20 @@ button .b2 -text .b2 button .b3 -text .b3 button .f.f.b4 -text .b4 -test geometry-1.1 {Tk_ManageGeometry procedure} { +test geometry-1.1 {Tk_ManageGeometry procedure} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } +} -body { place .b1 -x 120 -y 80 update list [winfo x .b1] [winfo y .b1] -} {120 80} -test geometry-1.2 {Tk_ManageGeometry procedure} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w +} -result {120 80} +test geometry-1.2 {Tk_ManageGeometry procedure} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .b1 -in .f -x 40 -y 30 update @@ -39,28 +51,37 @@ test geometry-1.2 {Tk_ManageGeometry procedure} { place .f -x 30 -y 40 update list [winfo x .b1] [winfo y .b1] -} {0 0} +} -result {0 0} -test geometry-2.1 {Tk_GeometryRequest procedure} { + +test geometry-2.1 {Tk_GeometryRequest procedure} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + destroy .f2 +} -body { frame .f2 set result [list [winfo reqwidth .f2] [winfo reqheight .f2]] .f2 configure -width 150 -height 300 update lappend result [winfo reqwidth .f2] [winfo reqheight .f2] \ - [winfo geom .f2] + [winfo geom .f2] place .f2 -x 10 -y 20 update lappend result [winfo geom .f2] .f2 configure -width 100 -height 80 update lappend result [winfo geom .f2] -} {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20} -catch {destroy .f2} +} -cleanup { + destroy .f2 +} -result {1 1 150 300 1x1+0+0 150x300+10+20 100x80+10+20} + -test geometry-3.1 {Tk_SetInternalBorder procedure} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w +test geometry-3.1 {Tk_SetInternalBorder procedure} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .b1 -in .f -x 50 -y 5 update @@ -68,24 +89,28 @@ test geometry-3.1 {Tk_SetInternalBorder procedure} { .f configure -bd 5 update lappend x [winfo x .b1] [winfo y .b1] -} {72 37 75 40} -.f configure -bd 2 +} -cleanup { + .f configure -bd 2 +} -result {72 37 75 40} -test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w + +test geometry-4.1 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 place .b1 -in .f.f.f -x 50 -y 5 update list [winfo x .b1] [winfo y .b1] -} {91 46} -test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w +} -result {91 46} +test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 @@ -96,12 +121,13 @@ test geometry-4.2 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f -x 30 -y 25 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ - [winfo x .b3] [winfo y .b3] -} {101 41 61 61 101 61} -test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w + [winfo x .b3] [winfo y .b3] +} -result {101 41 61 61 101 61} +test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 @@ -114,12 +140,13 @@ test geometry-4.3 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f.f -x 10 -y 25 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ - [winfo x .b3] [winfo y .b3] -} {0 0 46 86 86 86} -test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w + [winfo x .b3] [winfo y .b3] +} -result {0 0 46 86 86 86} +test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 @@ -132,12 +159,13 @@ test geometry-4.4 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f.f.f -x 2 -y 3 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ - [winfo x .b3] [winfo y .b3] -} {93 49 0 0 93 69} -test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w + [winfo x .b3] [winfo y .b3] +} -result {93 49 0 0 93 69} +test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 @@ -150,11 +178,15 @@ test geometry-4.5 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f.f.f -x 2 -y 3 update list [winfo x .b1] [winfo y .b1] [winfo x .b2] [winfo y .b2] \ - [winfo x .b3] [winfo y .b3] -} {93 49 53 69 0 0} -test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { + [winfo x .b3] [winfo y .b3] +} -result {93 49 53 69 0 0} +test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } +} -body { foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} { - place forget $w + place forget $w } place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 @@ -165,11 +197,12 @@ test geometry-4.6 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f -x 25 -y 35 update list [winfo x .f.f.b4] [winfo y .f.f.b4] [winfo x .b2] [winfo y .b2] -} {54 9 56 71} -test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3 .f.f.b4} { - place forget $w +} -result {54 9 56 71} +test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { bind .b1 <Configure> {lappend x configure} place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 @@ -184,13 +217,15 @@ test geometry-4.7 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f -x 30 -y 40 place .f.f -x 10 -y 0 update + return $x +} -cleanup { bind .b1 <Configure> {} - set x -} {init configure |} -test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w +} -result {init configure |} +test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 @@ -204,13 +239,14 @@ test geometry-4.8 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f -x 30 -y 25 update list [winfo x .b1] [winfo y .b1] [winfo ismapped .b1] \ - [winfo x .b2] [winfo y .b2] [winfo ismapped .b2] \ - [winfo x .b3] [winfo y .b3] [winfo ismapped .b3] -} {91 46 0 51 66 0 91 66 0} -test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { - foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { - place forget $w + [winfo x .b2] [winfo y .b2] [winfo ismapped .b2] \ + [winfo x .b3] [winfo y .b3] [winfo ismapped .b3] +} -result {91 46 0 51 66 0 91 66 0} +test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w } +} -body { place .f -x 20 -y 30 -width 200 -height 200 place .f.f -x 15 -y 5 -width 150 -height 120 place .f.f.f -width 100 -height 80 @@ -223,14 +259,18 @@ test geometry-4.9 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { place .f.f -x 15 -y 5 -width 150 -height 120 update lappend result [winfo ismapped .b1] -} {1 0 1} -test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { +} -result {1 0 1} +test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} -setup { + foreach w {.f .f.f .f.f.f .b1 .b2 .b3} { + place forget $w + } + destroy .t +} -body { toplevel .t wm geometry .t +0+0 tkwait visibility .t update - frame .t.f - pack .t.f + pack [frame .t.f] button .t.quit -text Quit -command exit pack .t.quit -in .t.f wm iconify .t @@ -240,10 +280,12 @@ test geometry-4.10 {Tk_MaintainGeometry and Tk_UnmaintainGeometry} { wm deiconify .t update winfo ismapped .t.quit -} {1} +} -cleanup { + destroy .t +} -result {1} -catch {destroy .t} # cleanup cleanupTests return + diff --git a/tests/get.test b/tests/get.test index d3a4228..ea08c8c 100644 --- a/tests/get.test +++ b/tests/get.test @@ -6,73 +6,133 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -button .b -test get-1.1 {Tk_GetAnchorFromObj} { +test get-1.1 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor n .b cget -anchor -} {n} -test get-1.2 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {n} +test get-1.2 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor ne .b cget -anchor -} {ne} -test get-1.3 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {ne} +test get-1.3 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor e .b cget -anchor -} {e} -test get-1.4 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {e} +test get-1.4 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor se .b cget -anchor -} {se} -test get-1.5 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {se} +test get-1.5 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor s .b cget -anchor -} {s} -test get-1.6 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {s} +test get-1.6 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor sw .b cget -anchor -} {sw} -test get-1.7 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {sw} +test get-1.7 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor w .b cget -anchor -} {w} -test get-1.8 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {w} +test get-1.8 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor nw .b cget -anchor -} {nw} -test get-1.9 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {nw} +test get-1.9 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor n .b cget -anchor -} {n} -test get-1.10 {Tk_GetAnchorFromObj} { +} -cleanup { + destroy .b +} -result {n} +test get-1.10 {Tk_GetAnchorFromObj} -setup { + button .b +} -body { .b configure -anchor center .b cget -anchor -} {center} -test get-1.11 {Tk_GetAnchorFromObj - error} { - list [catch {.b configure -anchor unknown} msg] $msg -} {1 {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center}} +} -cleanup { + destroy .b +} -result {center} +test get-1.11 {Tk_GetAnchorFromObj - error} -setup { + button .b +} -body { + .b configure -anchor unknown +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad anchor "unknown": must be n, ne, e, se, s, sw, w, nw, or center} -catch {destroy .b} -button .b -test get-2.1 {Tk_GetJustifyFromObj} { + +test get-2.1 {Tk_GetJustifyFromObj} -setup { + button .b +} -body { .b configure -justify left .b cget -justify -} {left} -test get-2.2 {Tk_GetJustifyFromObj} { +} -cleanup { + destroy .b +} -result {left} +test get-2.2 {Tk_GetJustifyFromObj} -setup { + button .b +} -body { .b configure -justify right .b cget -justify -} {right} -test get-2.3 {Tk_GetJustifyFromObj} { +} -cleanup { + destroy .b +} -result {right} +test get-2.3 {Tk_GetJustifyFromObj} -setup { + button .b +} -body { .b configure -justify center .b cget -justify -} {center} -test get-2.4 {Tk_GetJustifyFromObj - error} { - list [catch {.b configure -justify stupid} msg] $msg -} {1 {bad justification "stupid": must be left, right, or center}} +} -cleanup { + destroy .b +} -result {center} +test get-2.4 {Tk_GetJustifyFromObj - error} -setup { + button .b +} -body { + .b configure -justify stupid +} -cleanup { + destroy .b +} -returnCodes {error} -result {bad justification "stupid": must be left, right, or center} # cleanup cleanupTests return + diff --git a/tests/grab.test b/tests/grab.test index 2f4f73b..33399cb 100644 --- a/tests/grab.test +++ b/tests/grab.test @@ -7,140 +7,145 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # There's currently no way to test the actual grab effect, per se, # in an automated test. Therefore, this test suite only covers the # interface to the grab command (ie, error messages, etc.) -test grab-1.1 {Tk_GrabObjCmd} { - list [catch {grab} msg] $msg -} [list 1 "wrong # args: should be \"grab ?-global? window\" or \"grab option ?arg arg ...?\""] -test grab-1.2 {Tk_GrabObjCmd} { + +test grab-1.1 {Tk_GrabObjCmd} -body { + grab +} -returnCodes error -result {wrong # args: should be "grab ?-global? window" or "grab option ?arg ...?"} +test grab-1.2 {Tk_GrabObjCmd} -body { rename grab grabTest1.2 - set res [list [catch {grabTest1.2} msg] $msg] + grabTest1.2 +} -cleanup { rename grabTest1.2 grab - set res -} [list 1 "wrong # args: should be \"grabTest1.2 ?-global? window\" or \"grabTest1.2 option ?arg arg ...?\""] - -test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} { - list [catch {grab .foo bar baz} msg] $msg -} [list 1 "wrong # args: should be \"grab ?-global? window\""] -test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} { - catch {destroy .foo} - list [catch {grab .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] -test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} { - list [catch {grab -foo bar} msg] $msg -} [list 1 "bad option \"-foo\": must be -global"] -test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} { - catch {destroy .foo} - list [catch {grab -global .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-1.7 {Tk_GrabObjCmd} { - list [catch {grab foo} msg] $msg -} [list 1 "bad option \"foo\": must be current, release, set, or status"] - -test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} { - list [catch {grab current foo bar} msg] $msg -} [list 1 "wrong # args: should be \"grab current ?window?\""] -test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} { - catch {destroy .foo} - list [catch {grab current .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-1.10 {Tk_GrabObjCmd, "grab release window"} { - list [catch {grab release} msg] $msg -} [list 1 "wrong # args: should be \"grab release window\""] -test grab-1.11 {Tk_GrabObjCmd, "grab release window"} { - catch {destroy .foo} - list [catch {grab release .foo} msg] $msg -} [list 0 ""] -test grab-1.12 {Tk_GrabObjCmd, "grab release window"} { - list [catch {grab release foo} msg] $msg -} [list 0 ""] - -test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} { - list [catch {grab set} msg] $msg -} [list 1 "wrong # args: should be \"grab set ?-global? window\""] -test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} { - list [catch {grab set foo bar baz} msg] $msg -} [list 1 "wrong # args: should be \"grab set ?-global? window\""] -test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} { - catch {destroy .foo} - list [catch {grab set .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] -test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} { - list [catch {grab set -foo bar} msg] $msg -} [list 1 "bad option \"-foo\": must be -global"] -test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} { - catch {destroy .foo} - list [catch {grab set -global .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-1.18 {Tk_GrabObjCmd, "grab status window"} { - list [catch {grab status} msg] $msg -} [list 1 "wrong # args: should be \"grab status window\""] -test grab-1.19 {Tk_GrabObjCmd, "grab status window"} { - list [catch {grab status foo bar} msg] $msg -} [list 1 "wrong # args: should be \"grab status window\""] -test grab-1.20 {Tk_GrabObjCmd, "grab status window"} { - catch {destroy .foo} - list [catch {grab status .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] - -test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} { +} -returnCodes error -result {wrong # args: should be "grabTest1.2 ?-global? window" or "grabTest1.2 option ?arg ...?"} + +test grab-1.3 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + grab .foo bar baz +} -returnCodes error -result {wrong # args: should be "grab ?-global? window"} +test grab-1.4 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + destroy .foo + grab .foo +} -returnCodes error -result {bad window path name ".foo"} +test grab-1.5 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + grab -foo bar +} -returnCodes error -result {bad option "-foo": must be -global} +test grab-1.6 {Tk_GrabObjCmd, "grab ?-global? window"} -body { + destroy .foo + grab -global .foo +} -returnCodes error -result {bad window path name ".foo"} + +test grab-1.7 {Tk_GrabObjCmd} -body { + grab foo +} -returnCodes error -result {bad option "foo": must be current, release, set, or status} + +test grab-1.8 {Tk_GrabObjCmd, "grab current ?window?"} -body { + grab current foo bar +} -returnCodes error -result {wrong # args: should be "grab current ?window?"} +test grab-1.9 {Tk_GrabObjCmd, "grab current ?window?"} -body { + destroy .foo + grab current .foo +} -returnCodes error -result {bad window path name ".foo"} + +test grab-1.10 {Tk_GrabObjCmd, "grab release window"} -body { + grab release +} -returnCodes error -result {wrong # args: should be "grab release window"} +test grab-1.11 {Tk_GrabObjCmd, "grab release window"} -body { + destroy .foo + grab release .foo +} -returnCodes ok -result {} +test grab-1.12 {Tk_GrabObjCmd, "grab release window"} -body { + grab release foo +} -returnCodes ok -result {} + +test grab-1.13 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + grab set +} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"} +test grab-1.14 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + grab set foo bar baz +} -returnCodes error -result {wrong # args: should be "grab set ?-global? window"} +test grab-1.15 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + destroy .foo + grab set .foo +} -returnCodes error -result {bad window path name ".foo"} +test grab-1.16 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + grab set -foo bar +} -returnCodes error -result {bad option "-foo": must be -global} +test grab-1.17 {Tk_GrabObjCmd, "grab set ?-global? window"} -body { + destroy .foo + grab set -global .foo +} -returnCodes error -result {bad window path name ".foo"} + +test grab-1.18 {Tk_GrabObjCmd, "grab status window"} -body { + grab status +} -returnCodes error -result {wrong # args: should be "grab status window"} +test grab-1.19 {Tk_GrabObjCmd, "grab status window"} -body { + grab status foo bar +} -returnCodes error -result {wrong # args: should be "grab status window"} +test grab-1.20 {Tk_GrabObjCmd, "grab status window"} -body { + destroy .foo + grab status .foo +} -returnCodes error -result {bad window path name ".foo"} + + +test grab-2.1 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } - set result [grab status .] + grab status . +} -cleanup { grab release . - set result -} "none" -test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} { +} -result {none} +test grab-2.2 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . - set result [grab status .] + grab status . +} -cleanup { grab release . - set result -} "local" -test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} { +} -result {local} +test grab-2.3 {Tk_GrabObjCmd, grab status gives correct status} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab -global . - set result [grab status .] + grab status . +} -cleanup { grab release . - set result -} "global" +} -result {global} + -test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} { +test grab-3.1 {Tk_GrabObjCmd, grab current gives correct information} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } - set curr -} "" -test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} { + return $curr +} -result {} +test grab-3.2 {Tk_GrabObjCmd, grab current gives correct information} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab . - set curr [grab current] + grab current +} -cleanup { grab release . - set curr -} "." +} -result {.} -test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} { + +test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr @@ -153,28 +158,31 @@ test grab-4.1 {Tk_GrabObjCmd, grab release releases grab} { lappend result [grab status .] grab release . lappend result [grab status .] -} [list "local" "none" "global" "none"] +} -result {local none global none} + -test grab-5.1 {Tk_GrabObjCmd, grab set} { +test grab-5.1 {Tk_GrabObjCmd, grab set} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab set . - set result [list [grab current .] [grab status .]] + list [grab current .] [grab status .] +} -cleanup { grab release . - set result -} [list "." "local"] -test grab-5.2 {Tk_GrabObjCmd, grab set} { +} -result {. local} +test grab-5.2 {Tk_GrabObjCmd, grab set} -body { set curr [grab current .] if { [string length $curr] > 0 } { grab release $curr } grab set -global . - set result [list [grab current .] [grab status .]] + list [grab current .] [grab status .] +} -cleanup { grab release . - set result -} [list "." "global"] +} -result {. global} + cleanupTests return + diff --git a/tests/grid.test b/tests/grid.test index fee81b5..b27318e 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -5,9 +5,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test + # helper routine to return "." to a sane state after a test # The variable GRID_VERBOSE can be used to "look" at the result @@ -39,87 +41,78 @@ proc grid_reset {{test ?} {top .}} { grid_reset 0.0 wm geometry . {} -test grid-1.1 {basic argument checking} { - list [catch grid msg] $msg -} {1 {wrong # args: should be "grid option arg ?arg ...?"}} - -test grid-1.2 {basic argument checking} { - list [catch {grid foo bar} msg] $msg -} {1 {bad option "foo": must be anchor, bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves}} - -test grid-1.3 {basic argument checking} { +test grid-1.1 {basic argument checking} -body { + grid +} -returnCodes error -result {wrong # args: should be "grid option arg ?arg ...?"} +test grid-1.2 {basic argument checking} -body { + grid foo bar +} -returnCodes error -result {bad option "foo": must be anchor, bbox, columnconfigure, configure, forget, info, location, propagate, remove, rowconfigure, size, or slaves} +test grid-1.3 {basic argument checking} -body { button .b - list [catch {grid .b -row 0 -column} msg] $msg -} {1 {extra option or option with no value}} -grid_reset 1.3 + grid .b -row 0 -column +} -cleanup { + grid_reset 1.3 +} -returnCodes error -result {extra option or option with no value} -test grid-1.4 {basic argument checking} { +test grid-1.4 {basic argument checking} -body { button .b - list [catch {grid configure .b - foo} msg] $msg -} {1 {unexpected parameter, "foo", in configure list. Should be window name or option}} -grid_reset 1.4 - -test grid-1.5 {basic argument checking} { - list [catch {grid .} msg] $msg -} {1 {can't manage ".": it's a top-level window}} - -test grid-1.6 {basic argument checking} { - list [catch {grid x} msg] $msg -} {1 {can't determine master window}} - -test grid-1.7 {basic argument checking} { - list [catch {grid configure x} msg] $msg -} {1 {can't determine master window}} - -test grid-1.8 {basic argument checking} { + grid configure .b - foo +} -cleanup { + grid_reset 1.4 +} -returnCodes error -result {unexpected parameter, "foo", in configure list. Should be window name or option} +test grid-1.5 {basic argument checking} -body { + grid . +} -returnCodes error -result {can't manage ".": it's a top-level window} +test grid-1.6 {basic argument checking} -body { + grid x +} -returnCodes error -result {can't determine master window} +test grid-1.7 {basic argument checking} -body { + grid configure x +} -returnCodes error -result {can't determine master window} +test grid-1.8 {basic argument checking} -body { button .b - list [catch {grid x .b} msg] $msg -} {0 {}} -grid_reset 1.8 + grid x .b +} -cleanup { + grid_reset 1.8 +} -returnCodes ok -result {} -test grid-1.9 {basic argument checking} { +test grid-1.9 {basic argument checking} -body { button .b - list [catch {grid configure x .b} msg] $msg -} {0 {}} -grid_reset 1.9 + grid configure x .b +} -cleanup { + grid_reset 1.9 +} -returnCodes ok -result {} -test grid-2.1 {bbox} { - list [catch {grid bbox .} msg] $msg -} {0 {0 0 0 0}} -test grid-2.2 {bbox} { +test grid-2.1 {bbox} -body { + grid bbox . +} -result {0 0 0 0} +test grid-2.2 {bbox} -body { button .b grid .b destroy .b update - list [catch {grid bbox .} msg] $msg -} {0 {0 0 0 0}} - -test grid-2.3 {bbox: argument checking} { - list [catch {grid bbox . 0 0 5} msg] $msg -} {1 {wrong # args: should be "grid bbox master ?column row ?column row??"}} - -test grid-2.4 {bbox} { - list [catch {grid bbox .bad 0 0} msg] $msg -} {1 {bad window path name ".bad"}} - -test grid-2.5 {bbox} { - list [catch {grid bbox . x 0} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.6 {bbox} { - list [catch {grid bbox . 0 x} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.7 {bbox} { - list [catch {grid bbox . 0 0 x 0} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.8 {bbox} { - list [catch {grid bbox . 0 0 0 x} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-2.9 {bbox} { + grid bbox . +} -result {0 0 0 0} +test grid-2.3 {bbox: argument checking} -body { + grid bbox . 0 0 5 +} -returnCodes error -result {wrong # args: should be "grid bbox master ?column row ?column row??"} +test grid-2.4 {bbox} -body { + grid bbox .bad 0 0 +} -returnCodes error -result {bad window path name ".bad"} +test grid-2.5 {bbox} -body { + grid bbox . x 0 +} -returnCodes error -result {expected integer but got "x"} +test grid-2.6 {bbox} -body { + grid bbox . 0 x +} -returnCodes error -result {expected integer but got "x"} +test grid-2.7 {bbox} -body { + grid bbox . 0 0 x 0 +} -returnCodes error -result {expected integer but got "x"} +test grid-2.8 {bbox} -body { + grid bbox . 0 0 0 x +} -returnCodes error -result {expected integer but got "x"} +test grid-2.9 {bbox} -body { frame .1 -width 75 -height 75 -bg red frame .2 -width 90 -height 90 -bg red grid .1 -row 0 -column 0 @@ -131,10 +124,11 @@ test grid-2.9 {bbox} { lappend a [grid bbox . 0 0 1 1] lappend a [grid bbox . 1 1] set a -} {{0 0 165 165} {0 0 75 75} {0 0 165 165} {75 75 90 90}} -grid_reset 2.9 +} -cleanup { + grid_reset 2.9 +} -result {{0 0 165 165} {0 0 75 75} {0 0 165 165} {75 75 90 90}} -test grid-2.10 {bbox} { +test grid-2.10 {bbox} -body { frame .1 -width 75 -height 75 -bg red frame .2 -width 90 -height 90 -bg red grid .1 -row 0 -column 0 @@ -145,97 +139,109 @@ test grid-2.10 {bbox} { lappend a [grid bbox . -2 -2 -1 -1] lappend a [grid bbox . 10 10 12 12] set a -} {{0 0 165 165} {0 0 0 0} {165 165 0 0}} -grid_reset 2.10 +} -cleanup { + grid_reset 2.10 +} -result {{0 0 165 165} {0 0 0 0} {165 165 0 0}} -test grid-3.1 {configure: basic argument checking} { - list [catch {grid configure foo} msg] $msg -} {1 {bad argument "foo": must be name of window}} -test grid-3.2 {configure: basic argument checking} { +test grid-3.1 {configure: basic argument checking} -body { + grid configure foo +} -returnCodes error -result {bad argument "foo": must be name of window} +test grid-3.2 {configure: basic argument checking} -body { button .b grid configure .b grid slaves . -} {.b} -grid_reset 3.2 +} -cleanup { + grid_reset 3.2 +} -result {.b} -test grid-3.3 {configure: basic argument checking} { +test grid-3.3 {configure: basic argument checking} -body { button .b - list [catch {grid .b -row -1} msg] $msg -} {1 {bad row value "-1": must be a non-negative integer}} -grid_reset 3.3 + grid .b -row -1 +} -cleanup { + grid_reset 3.3 +} -returnCodes error -result {bad row value "-1": must be a non-negative integer} -test grid-3.4 {configure: basic argument checking} { +test grid-3.4 {configure: basic argument checking} -body { button .b - list [catch {grid .b -column -1} msg] $msg -} {1 {bad column value "-1": must be a non-negative integer}} -grid_reset 3.4 + grid .b -column -1 +} -cleanup { + grid_reset 3.4 +} -returnCodes error -result {bad column value "-1": must be a non-negative integer} -test grid-3.5 {configure: basic argument checking} { +test grid-3.5 {configure: basic argument checking} -body { button .b - list [catch {grid .b -rowspan 0} msg] $msg -} {1 {bad rowspan value "0": must be a positive integer}} -grid_reset 3.5 + grid .b -rowspan 0 +} -cleanup { + grid_reset 3.5 +} -returnCodes error -result {bad rowspan value "0": must be a positive integer} -test grid-3.6 {configure: basic argument checking} { +test grid-3.6 {configure: basic argument checking} -body { button .b - list [catch {grid .b -columnspan 0} msg] $msg -} {1 {bad columnspan value "0": must be a positive integer}} -grid_reset 3.6 + grid .b -columnspan 0 +} -cleanup { + grid_reset 3.6 +} -returnCodes error -result {bad columnspan value "0": must be a positive integer} -test grid-3.7 {configure: basic argument checking} { +test grid-3.7 {configure: basic argument checking} -body { frame .f button .f.b - list [catch {grid .f .f.b} msg] $msg -} {1 {can't put .f.b inside .}} -grid_reset 3.7 + grid .f .f.b +} -cleanup { + grid_reset 3.7 +} -returnCodes error -result {can't put .f.b inside .} -test grid-3.8 {configure: basic argument checking} { +test grid-3.8 {configure: basic argument checking} -body { button .b grid configure x .b grid slaves . -} {.b} -grid_reset 3.8 +} -cleanup { + grid_reset 3.8 +} -result {.b} -test grid-3.9 {configure: basic argument checking} { +test grid-3.9 {configure: basic argument checking} -body { button .b - list [catch {grid configure y .b} msg] $msg -} {1 {invalid window shortcut, "y" should be '-', 'x', or '^'}} -grid_reset 3.9 + grid configure y .b +} -cleanup { + grid_reset 3.9 +} -returnCodes error -result {invalid window shortcut, "y" should be '-', 'x', or '^'} -test grid-4.1 {forget: basic argument checking} { - list [catch {grid forget foo} msg] $msg -} {1 {bad window path name "foo"}} -test grid-4.2 {forget} { +test grid-4.1 {forget: basic argument checking} -body { + grid forget foo +} -returnCodes error -result {bad window path name "foo"} +test grid-4.2 {forget} -body { button .c grid [button .b] set a [grid slaves .] grid forget .b .c lappend a [grid slaves .] set a -} {.b {}} -grid_reset 4.2 +} -cleanup { + grid_reset 4.2 +} -result {.b {}} -test grid-4.3 {forget} { +test grid-4.3 {forget} -body { button .c grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns grid forget .c grid .c -row 0 -column 0 grid info .c -} {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -grid_reset 4.3 +} -cleanup { + grid_reset 4.3 +} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -test grid-4.3.1 {forget} { +test grid-4.4 {forget} -body { button .c grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx {3 5} -pady {4 7} -sticky ns grid forget .c grid .c -row 0 -column 0 grid info .c -} {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -grid_reset 4.3.1 +} -cleanup { + grid_reset 4.3.1 +} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -test grid-4.4 {forget, calling Tk_UnmaintainGeometry} { +test grid-4.5 {forget, calling Tk_UnmaintainGeometry} -body { frame .f -bd 2 -relief raised place .f -x 10 -y 20 -width 200 -height 100 frame .f2 -width 50 -height 30 -bg red @@ -246,59 +252,61 @@ test grid-4.4 {forget, calling Tk_UnmaintainGeometry} { place .f -x 30 update lappend x [winfo ismapped .f2] -} {1 0} -grid_reset 4.4 +} -cleanup { + grid_reset 4.4 +} -result {1 0} -test grid-5.1 {info: basic argument checking} { - list [catch {grid info a b} msg] $msg -} {1 {wrong # args: should be "grid info window"}} -test grid-5.2 {info} { +test grid-5.1 {info: basic argument checking} -body { + grid info a b +} -returnCodes error -result {wrong # args: should be "grid info window"} +test grid-5.2 {info} -body { frame .1 -width 75 -height 75 -bg red grid .1 -row 0 -column 0 update - list [catch {grid info .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 5.2 + grid info .x +} -cleanup { + grid_reset 5.2 +} -returnCodes error -result {bad window path name ".x"} -test grid-5.3 {info} { +test grid-5.3 {info} -body { frame .1 -width 75 -height 75 -bg red grid .1 -row 0 -column 0 update - list [catch {grid info .1} msg] $msg -} {0 {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}}} -grid_reset 5.3 + grid info .1 +} -cleanup { + grid_reset 5.3 +} -result {-in . -column 0 -row 0 -columnspan 1 -rowspan 1 -ipadx 0 -ipady 0 -padx 0 -pady 0 -sticky {}} -test grid-5.4 {info} { +test grid-5.4 {info} -body { frame .1 -width 75 -height 75 -bg red update - list [catch {grid info .1} msg] $msg -} {0 {}} -grid_reset 5.4 - -test grid-6.1 {location: basic argument checking} { - list [catch "grid location ." msg] $msg -} {1 {wrong # args: should be "grid location master x y"}} - -test grid-6.2 {location: basic argument checking} { - list [catch "grid location .bad 0 0" msg] $msg -} {1 {bad window path name ".bad"}} - -test grid-6.3 {location: basic argument checking} { - list [catch "grid location . x y" msg] $msg -} {1 {bad screen distance "x"}} - -test grid-6.4 {location: basic argument checking} { - list [catch "grid location . 1c y" msg] $msg -} {1 {bad screen distance "y"}} - -test grid-6.5 {location: basic argument checking} { + grid info .1 +} -cleanup { + grid_reset 5.4 +} -returnCodes ok -result {} + + +test grid-6.1 {location: basic argument checking} -body { + grid location . +} -returnCodes error -result {wrong # args: should be "grid location master x y"} +test grid-6.2 {location: basic argument checking} -body { + grid location .bad 0 0 +} -returnCodes error -result {bad window path name ".bad"} +test grid-6.3 {location: basic argument checking} -body { + grid location . x y +} -returnCodes error -result {bad screen distance "x"} +test grid-6.4 {location: basic argument checking} -body { + grid location . 1c y +} -returnCodes error -result {bad screen distance "y"} +test grid-6.5 {location: basic argument checking} -body { frame .f grid location .f 10 10 -} {-1 -1} -grid_reset 6.5 +} -cleanup { + grid_reset 6.5 +} -result {-1 -1} -test grid-6.6 {location (x)} { +test grid-6.6 {location (x)} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -312,10 +320,11 @@ test grid-6.6 {location (x)} { } } set result -} {{-10->-1 0} {0->0 0} {201->1 0}} -grid_reset 6.6 +} -cleanup { + grid_reset 6.6 +} -result {{-10->-1 0} {0->0 0} {201->1 0}} -test grid-6.7 {location (y)} { +test grid-6.7 {location (y)} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -329,10 +338,11 @@ test grid-6.7 {location (y)} { } } set result -} {{-10->0 -1} {0->0 0} {101->0 1}} -grid_reset 6.7 +} -cleanup { + grid_reset 6.7 +} -result {{-10->0 -1} {0->0 0} {101->0 1}} -test grid-6.8 {location (weights)} { +test grid-6.8 {location (weights)} -body { frame .f -width 300 -height 100 -highlightthickness 0 -bg red frame .a grid .a @@ -352,10 +362,13 @@ test grid-6.8 {location (weights)} { } } set result -} {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}} -grid_reset 6.8 +} -cleanup { + grid_reset 6.8 +} -result {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}} -test grid-6.9 {location: check updates pending} {nonPortable} { +test grid-6.9 {location: check updates pending} -constraints { + nonPortable +} -body { set a "" foreach i {0 1 2} { frame .$i -width 120 -height 75 -bg red @@ -363,35 +376,42 @@ test grid-6.9 {location: check updates pending} {nonPortable} { grid .$i -row $i -column $i } set a -} {{0 0} {1 1} {1 1}} -grid_reset 6.9 - -test grid-7.1 {propagate} { - list [catch {grid propagate . 1 xxx} msg] $msg -} {1 {wrong # args: should be "grid propagate window ?boolean?"}} -grid_reset 7.1 - -test grid-7.2 {propagate} { - list [catch {grid propagate .} msg] $msg -} {0 1} -grid_reset 7.2 - -test grid-7.3 {propagate} { - list [catch {grid propagate . 0;grid propagate .} msg] $msg -} {0 0} -grid_reset 7.3 - -test grid-7.4 {propagate} { - list [catch {grid propagate .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 7.4 - -test grid-7.5 {propagate} { - list [catch {grid propagate . x} msg] $msg -} {1 {expected boolean value but got "x"}} -grid_reset 7.5 - -test grid-7.6 {propagate} { +} -cleanup { + grid_reset 6.9 +} -result {{0 0} {1 1} {1 1}} + + +test grid-7.1 {propagate} -body { + grid propagate . 1 xxx +} -cleanup { + grid_reset 7.1 +} -returnCodes error -result {wrong # args: should be "grid propagate window ?boolean?"} + +test grid-7.2 {propagate} -body { + grid propagate . +} -cleanup { + grid_reset 7.2 +} -result {1} + +test grid-7.3 {propagate} -body { + grid propagate . 0;grid propagate . +} -cleanup { + grid_reset 7.3 +} -result {0} + +test grid-7.4 {propagate} -body { + grid propagate .x +} -cleanup { + grid_reset 7.4 +} -returnCodes error -result {bad window path name ".x"} + +test grid-7.5 {propagate} -body { + grid propagate . x +} -cleanup { + grid_reset 7.5 +} -returnCodes error -result {expected boolean value but got "x"} + +test grid-7.6 {propagate} -body { frame .f -width 100 -height 100 -bg red grid .f -row 0 -column 0 update @@ -405,9 +425,10 @@ test grid-7.6 {propagate} { update lappend a [winfo width .f]x[winfo height .f] set a -} {100x100 100x100 75x85} -grid_reset 7.6 -test grid-7.7 {propagate} { +} -cleanup { + grid_reset 7.6 +} -result {100x100 100x100 75x85} +test grid-7.7 {propagate} -body { grid propagate . 1 set res [list [grid propagate .]] grid propagate . 0 @@ -415,26 +436,31 @@ test grid-7.7 {propagate} { grid propagate . 0 lappend res [grid propagate .] set res -} [list 1 0 0] -grid_reset 7.7 +} -cleanup { + grid_reset 7.7 +} -result [list 1 0 0] + -test grid-8.1 {size} { - list [catch {grid size . foo} msg] $msg -} {1 {wrong # args: should be "grid size window"}} -grid_reset 8.1 +test grid-8.1 {size} -body { + grid size . foo +} -cleanup { + grid_reset 8.1 +} -returnCodes error -result {wrong # args: should be "grid size window"} -test grid-8.2 {size} { - list [catch {grid size .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 8.2 +test grid-8.2 {size} -body { + grid size .x +} -cleanup { + grid_reset 8.2 +} -returnCodes error -result {bad window path name ".x"} -test grid-8.3 {size} { +test grid-8.3 {size} -body { frame .f - list [catch {grid size .f} msg] $msg -} {0 {0 0}} -grid_reset 8.3 + grid size .f +} -cleanup { + grid_reset 8.3 +} -result {0 0} -test grid-8.4 {size} { +test grid-8.4 {size} -body { catch {unset a} scale .f grid .f -row 0 -column 0 @@ -450,10 +476,11 @@ test grid-8.4 {size} { update lappend a [grid size .] set a -} {{1 1} {6 5} {664 948} {1 1}} -grid_reset 8.4 +} -cleanup { + grid_reset 8.4 +} -result {{1 1} {6 5} {664 948} {1 1}} -test grid-8.5 {size} { +test grid-8.5 {size} -body { catch {unset a} scale .f grid .f -row 0 -column 0 @@ -470,10 +497,11 @@ test grid-8.5 {size} { update lappend a [grid size .] set a -} {{1 1} {1 18} {64 18} {1 1}} -grid_reset 8.5 +} -cleanup { + grid_reset 8.5 +} -result {{1 1} {1 18} {64 18} {1 1}} -test grid-8.6 {size} { +test grid-8.6 {size} -body { catch {unset a} scale .f grid .f -row 10 -column 50 @@ -496,55 +524,49 @@ test grid-8.6 {size} { update lappend a [grid size .] set a -} {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}} -grid_reset 8.6 - -test grid-9.1 {slaves} { - list [catch {grid slaves .} msg] $msg -} {0 {}} - -test grid-9.2 {slaves} { - list [catch {grid slaves .foo} msg] $msg -} {1 {bad window path name ".foo"}} - -test grid-9.3 {slaves} { - list [catch {grid slaves a b} msg] $msg -} {1 {wrong # args: should be "grid slaves window ?-option value...?"}} - -test grid-9.4 {slaves} { - list [catch {grid slaves . a b} msg] $msg -} {1 {bad option "a": must be -column or -row}} - -test grid-9.5 {slaves} { - list [catch {grid slaves . -column x} msg] $msg -} {1 {expected integer but got "x"}} - -test grid-9.6 {slaves} { - list [catch {grid slaves . -row -3} msg] $msg -} {1 {-row is an invalid value: should NOT be < 0}} - -test grid-9.7 {slaves} { - list [catch {grid slaves . -foo 3} msg] $msg -} {1 {bad option "-foo": must be -column or -row}} - -test grid-9.8 {slaves} { - list [catch {grid slaves .x -row 3} msg] $msg -} {1 {bad window path name ".x"}} - -test grid-9.9 {slaves} { - list [catch {grid slaves . -row 3} msg] $msg -} {0 {}} - -test grid-9.10 {slaves} { +} -cleanup { + grid_reset 8.6 +} -result {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}} + + +test grid-9.1 {slaves} -body { + grid slaves . +} -returnCodes ok -result {} +test grid-9.2 {slaves} -body { + grid slaves .foo +} -returnCodes error -result {bad window path name ".foo"} +test grid-9.3 {slaves} -body { + grid slaves a b +} -returnCodes error -result {wrong # args: should be "grid slaves window ?-option value ...?"} +test grid-9.4 {slaves} -body { + grid slaves . a b +} -returnCodes error -result {bad option "a": must be -column or -row} +test grid-9.5 {slaves} -body { + grid slaves . -column x +} -returnCodes error -result {expected integer but got "x"} +test grid-9.6 {slaves} -body { + grid slaves . -row -3 +} -returnCodes error -result {-row is an invalid value: should NOT be < 0} +test grid-9.7 {slaves} -body { + grid slaves . -foo 3 +} -returnCodes error -result {bad option "-foo": must be -column or -row} +test grid-9.8 {slaves} -body { + grid slaves .x -row 3 +} -returnCodes error -result {bad window path name ".x"} +test grid-9.9 {slaves} -body { + grid slaves . -row 3 +} -returnCodes ok -result {} +test grid-9.10 {slaves} -body { foreach i {0 1 2} { label .$i -text $i grid .$i -row $i -column $i } - list [catch {grid slaves .} msg] $msg -} {0 {.2 .1 .0}} -grid_reset 9.10 + grid slaves . +} -cleanup { + grid_reset 9.10 +} -result {.2 .1 .0} -test grid-9.11 {slaves} { +test grid-9.11 {slaves} -body { catch {unset a} foreach i {0 1 2} { label .$i -text $i @@ -559,95 +581,112 @@ test grid-9.11 {slaves} { lappend a $col{[grid slaves . -column $col]} } set a -} {{0{.0-x .0}} {1{.1-x .1}} {2{.2-x .2}} 3{} 0{.0} {1{.1 .0-x}} {2{.2 .1-x}} 3{.2-x}} -grid_reset 9.11 +} -cleanup { + grid_reset 9.11 +} -result {{0{.0-x .0}} {1{.1-x .1}} {2{.2-x .2}} 3{} 0{.0} {1{.1 .0-x}} {2{.2 .1-x}} 3{.2-x}} -# column/row configure -test grid-10.1 {column/row configure} { - list [catch {grid columnconfigure .} msg] $msg -} {1 {wrong # args: should be "grid columnconfigure master index ?-option value...?"}} -grid_reset 10.1 - -test grid-10.2 {column/row configure} { - list [catch {grid columnconfigure . 0 -weight 0 -pad} msg] $msg -} {1 {wrong # args: should be "grid columnconfigure master index ?-option value...?"}} -grid_reset 10.2 - -test grid-10.3 {column/row configure} { - list [catch {grid columnconfigure .f 0 -weight} msg] $msg -} {1 {bad window path name ".f"}} -grid_reset 10.3 - -test grid-10.4 {column/row configure} { - list [catch {grid columnconfigure . nine -weight} msg] $msg -} {1 {expected integer but got "nine" (when retreiving options only integer indices are allowed)}} -grid_reset 10.4 - -test grid-10.5 {column/row configure} { - list [catch {grid columnconfigure . 265 -weight} msg] $msg -} {0 0} -grid_reset 10.5 - -test grid-10.6 {column/row configure} { - list [catch {grid columnconfigure . 0} msg] $msg -} {0 {-minsize 0 -pad 0 -uniform {} -weight 0}} -grid_reset 10.6 - -test grid-10.7 {column/row configure} { - list [catch {grid columnconfigure . 0 -foo} msg] $msg -} {1 {bad option "-foo": must be -minsize, -pad, -uniform, or -weight}} -grid_reset 10.7 - -test grid-10.8 {column/row configure} { - list [catch {grid columnconfigure . 0 -minsize foo} msg] $msg -} {1 {bad screen distance "foo"}} -grid_reset 10.8 - -test grid-10.9 {column/row configure} { - list [catch {grid columnconfigure . 0 -minsize foo} msg] $msg -} {1 {bad screen distance "foo"}} -grid_reset 10.9 - -test grid-10.10 {column/row configure} { +# column/row configure +test grid-10.1 {column/row configure} -body { + grid columnconfigure . +} -cleanup { + grid_reset 10.1 +} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"} + +test grid-10.2 {column/row configure} -body { + grid columnconfigure . 0 -weight 0 -pad +} -cleanup { + grid_reset 10.2 +} -returnCodes error -result {wrong # args: should be "grid columnconfigure master index ?-option value ...?"} + +test grid-10.3 {column/row configure} -body { + grid columnconfigure .f 0 -weight +} -cleanup { + grid_reset 10.3 +} -returnCodes error -result {bad window path name ".f"} + +test grid-10.4 {column/row configure} -body { + grid columnconfigure . nine -weight +} -cleanup { + grid_reset 10.4 +} -returnCodes error -result {expected integer but got "nine" (when retreiving options only integer indices are allowed)} + +test grid-10.5 {column/row configure} -body { + grid columnconfigure . 265 -weight +} -cleanup { + grid_reset 10.5 +} -result {0} + +test grid-10.6 {column/row configure} -body { + grid columnconfigure . 0 +} -cleanup { + grid_reset 10.6 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} + +test grid-10.7 {column/row configure} -body { + grid columnconfigure . 0 -foo +} -cleanup { + grid_reset 10.7 +} -returnCodes error -result {bad option "-foo": must be -minsize, -pad, -uniform, or -weight} + +test grid-10.8 {column/row configure} -body { + grid columnconfigure . 0 -minsize foo +} -cleanup { + grid_reset 10.8 +} -returnCodes error -result {bad screen distance "foo"} + +test grid-10.9 {column/row configure} -body { + grid columnconfigure . 0 -minsize foo +} -cleanup { + grid_reset 10.9 +} -returnCodes error -result {bad screen distance "foo"} + +test grid-10.10 {column/row configure} -body { grid columnconfigure . 0 -minsize 10 grid columnconfigure . 0 -minsize -} {10} -grid_reset 10.10 - -test grid-10.11 {column/row configure} { - list [catch {grid columnconfigure . 0 -weight bad} msg] $msg -} {1 {expected integer but got "bad"}} -grid_reset 10.11 - -test grid-10.12 {column/row configure} { - list [catch {grid columnconfigure . 0 -weight -3} msg] $msg -} {1 {invalid arg "-weight": should be non-negative}} -grid_reset 10.12 - -test grid-10.13 {column/row configure} { +} -cleanup { + grid_reset 10.10 +} -result {10} + +test grid-10.11 {column/row configure} -body { + grid columnconfigure . 0 -weight bad +} -cleanup { + grid_reset 10.11 +} -returnCodes error -result {expected integer but got "bad"} + +test grid-10.12 {column/row configure} -body { + grid columnconfigure . 0 -weight -3 +} -cleanup { + grid_reset 10.12 +} -returnCodes error -result {invalid arg "-weight": should be non-negative} + +test grid-10.13 {column/row configure} -body { grid columnconfigure . 0 -weight 3 grid columnconfigure . 0 -weight -} {3} -grid_reset 10.13 - -test grid-10.14 {column/row configure} { - list [catch {grid columnconfigure . 0 -pad foo} msg] $msg -} {1 {bad screen distance "foo"}} -grid_reset 10.14 - -test grid-10.15 {column/row configure} { - list [catch {grid columnconfigure . 0 -pad -3} msg] $msg -} {1 {invalid arg "-pad": should be non-negative}} -grid_reset 10.15 - -test grid-10.16 {column/row configure} { +} -cleanup { + grid_reset 10.13 +} -result {3} + +test grid-10.14 {column/row configure} -body { + grid columnconfigure . 0 -pad foo +} -cleanup { + grid_reset 10.14 +} -returnCodes error -result {bad screen distance "foo"} + +test grid-10.15 {column/row configure} -body { + grid columnconfigure . 0 -pad -3 +} -cleanup { + grid_reset 10.15 +} -returnCodes error -result {invalid arg "-pad": should be non-negative} + +test grid-10.16 {column/row configure} -body { grid columnconfigure . 0 -pad 3 grid columnconfigure . 0 -pad -} {3} -grid_reset 10.16 +} -cleanup { + grid_reset 10.16 +} -result {3} -test grid-10.17 {column/row configure} { +test grid-10.17 {column/row configure} -body { frame .f set a "" grid columnconfigure .f 0 -weight 0 @@ -660,10 +699,11 @@ test grid-10.17 {column/row configure} { lappend a [grid columnconfigure .f 0 -weight] grid columnconfigure .f 0 -weight 0 set a -} {0 1 0 1} -grid_reset 10.17 +} -cleanup { + grid_reset 10.17 +} -result {0 1 0 1} -test grid-10.18 {column/row configure} { +test grid-10.18 {column/row configure} -body { frame .f grid columnconfigure .f {0 2} -minsize 10 -weight 1 list [grid columnconfigure .f 0 -minsize] \ @@ -672,32 +712,37 @@ test grid-10.18 {column/row configure} { [grid columnconfigure .f 0 -weight] \ [grid columnconfigure .f 1 -weight] \ [grid columnconfigure .f 2 -weight] -} {10 0 10 1 0 1} -grid_reset 10.18 +} -cleanup { + grid_reset 10.18 +} -result {10 0 10 1 0 1} -test grid-10.19 {column/row configure} { - list [catch {grid columnconfigure . {0 -1 2} -weight 1} msg] $msg -} {1 {grid columnconfigure: "-1" is out of range}} -grid_reset 10.19 +test grid-10.19 {column/row configure} -body { + grid columnconfigure . {0 -1 2} -weight 1 +} -cleanup { + grid_reset 10.19 +} -returnCodes error -result {grid columnconfigure: "-1" is out of range} -test grid-10.20 {column/row configure} { +test grid-10.20 {column/row configure} -body { grid columnconfigure . 0 -uniform foo grid columnconfigure . 0 -uniform -} {foo} -grid_reset 10.20 +} -cleanup { + grid_reset 10.20 +} -result {foo} -test grid-10.21 {column/row configure} { - list [catch {grid columnconfigure . .b -weight 1} msg] $msg -} {1 {grid columnconfigure: illegal index ".b"}} -grid_reset 10.21 +test grid-10.21 {column/row configure} -body { + grid columnconfigure . .b -weight 1 +} -cleanup { + grid_reset 10.21 +} -returnCodes error -result {grid columnconfigure: illegal index ".b"} -test grid-10.22 {column/row configure} { +test grid-10.22 {column/row configure} -body { button .b - list [catch {grid columnconfigure . .b -weight 1} msg] $msg -} {1 {grid columnconfigure: the window ".b" is not managed by "."}} -grid_reset 10.22 + grid columnconfigure . .b -weight 1 +} -cleanup { + grid_reset 10.22 +} -returnCodes error -result {grid columnconfigure: the window ".b" is not managed by "."} -test grid-10.23 {column/row configure} { +test grid-10.23 {column/row configure} -body { button .b grid .b -column 1 -columnspan 2 grid columnconfigure . .b -weight 1 @@ -706,10 +751,11 @@ test grid-10.23 {column/row configure} { lappend res [grid columnconfigure . $i -weight] } set res -} {0 1 1 0} -grid_reset 10.23 +} -cleanup { + grid_reset 10.23 +} -result {0 1 1 0} -test grid-10.24 {column/row configure} { +test grid-10.24 {column/row configure} -body { button .b button .c button .d @@ -723,10 +769,11 @@ test grid-10.24 {column/row configure} { lappend res [grid columnconfigure . $i -weight] } set res -} {0 1 2 2 2 1 0} -grid_reset 10.24 +} -cleanup { + grid_reset 10.24 +} -result {0 1 2 2 2 1 0} -test grid-10.25 {column/row configure} { +test grid-10.25 {column/row configure} -body { button .b button .c button .d @@ -740,46 +787,43 @@ test grid-10.25 {column/row configure} { lappend res [grid rowconfigure . $i -weight] } set res -} {0 2 1 1 2 2 0 1} -grid_reset 10.25 +} -cleanup { + grid_reset 10.25 +} -result {0 2 1 1 2 2 0 1} -test grid-10.26 {column/row configure} { +test grid-10.26 {column/row configure} -body { button .b grid columnconfigure .b 0 -} {-minsize 0 -pad 0 -uniform {} -weight 0} -grid_reset 10.26 +} -cleanup { + grid_reset 10.26 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} -test grid-10.30 {column/row configure - no indices} { +test grid-10.27 {column/row configure - no indices} -body { # Bug 1422430 set t [toplevel .test] - set res [list [catch {grid columnconfigure $t "" -weight 1} msg] $msg] + grid columnconfigure $t "" -weight 1 +} -cleanup { destroy $t - set res -} {1 {no column indices specified}} - -test grid-10.31 {column/row configure - no indices} { +} -returnCodes error -result {no column indices specified} +test grid-10.28 {column/row configure - no indices} -body { set t [toplevel .test] - set res [list [catch {grid rowconfigure $t "" -weight 1} msg] $msg] + grid rowconfigure $t "" -weight 1 +} -cleanup { destroy $t - set res -} {1 {no row indices specified}} - -test grid-10.32 {column/row configure - invalid indices} { - list [catch {grid columnconfigure . {0 1 2} -weight} msg] $msg -} {1 {grid columnconfigure: must specify a single element on retrieval}} - -test grid-10.33 {column/row configure - invalid indices} { - list [catch {grid rowconfigure . {0 1 2} -weight} msg] $msg -} {1 {grid rowconfigure: must specify a single element on retrieval}} - -test grid-10.34 {column/row configure - empty 'all' configure} { +} -returnCodes error -result {no row indices specified} +test grid-10.29 {column/row configure - invalid indices} -body { + grid columnconfigure . {0 1 2} -weight +} -returnCodes error -result {grid columnconfigure: must specify a single element on retrieval} +test grid-10.30 {column/row configure - invalid indices} -body { + grid rowconfigure . {0 1 2} -weight +} -returnCodes error -result {grid rowconfigure: must specify a single element on retrieval} +test grid-10.31 {column/row configure - empty 'all' configure} -body { # Bug 1422430 set t [toplevel .test] grid rowconfigure $t all -weight 1 destroy $t -} {} - -test grid-10.35 {column/row configure} { +} -result {} +test grid-10.32 {column/row configure} -body { # Test that no lingering message is there frame .f set res [grid columnconfigure .f all -weight 1] @@ -791,20 +835,23 @@ test grid-10.35 {column/row configure} { append res [grid columnconfigure .f {2 .f.f} -weight 1] destroy .f set res -} {} -grid_reset 10.35 - -test grid-10.36 {column/row configure} { - list [catch {grid columnconfigure . all} msg] $msg -} {1 {expected integer but got "all" (when retreiving options only integer indices are allowed)}} -grid_reset 10.36 - -test grid-10.37 {column/row configure} { - list [catch {grid columnconfigure . 100000} msg] $msg -} {0 {-minsize 0 -pad 0 -uniform {} -weight 0}} -grid_reset 10.37 - -test grid-10.38 {column/row configure} -body { +} -cleanup { + grid_reset 10.35 +} -result {} + +test grid-10.33 {column/row configure} -body { + grid columnconfigure . all +} -cleanup { + grid_reset 10.36 +} -returnCodes error -result {expected integer but got "all" (when retreiving options only integer indices are allowed)} + +test grid-10.34 {column/row configure} -body { + grid columnconfigure . 100000 +} -cleanup { + grid_reset 10.37 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} + +test grid-10.35 {column/row configure} -body { # This is a test for bug 1423666 where a column >= 10000 caused # a crash in layout. The update is needed to reach the layout stage. # Test different combinations of row/column overflow @@ -827,7 +874,7 @@ test grid-10.38 {column/row configure} -body { } 0 end] grid_reset 10.38 -test grid-10.39 {column/row configure} -body { +test grid-10.36 {column/row configure} -body { # Additional tests for row/column overflow frame .f frame .g @@ -849,38 +896,43 @@ test grid-10.39 {column/row configure} -body { } 0 end] grid_reset 10.39 -# auto-placement tests -test grid-11.1 {default widget placement} { - list [catch {grid ^} msg] $msg -} {1 {can't use '^', cant find master}} -grid_reset 11.1 +# auto-placement tests +test grid-11.1 {default widget placement} -body { + grid ^ +} -cleanup { + grid_reset 11.1 +} -returnCodes error -result {can't use '^', cant find master} -test grid-11.2 {default widget placement} { +test grid-11.2 {default widget placement} -body { button .b - list [catch {grid .b ^} msg] $msg -} {1 {can't find slave to extend with "^".}} -grid_reset 11.2 + grid .b ^ +} -cleanup { + grid_reset 11.2 +} -returnCodes error -result {can't find slave to extend with "^".} -test grid-11.3 {default widget placement} { +test grid-11.3 {default widget placement} -body { button .b - list [catch {grid .b - - .c} msg] $msg -} {1 {bad window path name ".c"}} -grid_reset 11.3 + grid .b - - .c +} -cleanup { + grid_reset 11.3 +} -returnCodes error -result {bad window path name ".c"} -test grid-11.4 {default widget placement} { +test grid-11.4 {default widget placement} -body { button .b - list [catch {grid .b - - = -} msg] $msg -} {1 {invalid window shortcut, "=" should be '-', 'x', or '^'}} -grid_reset 11.4 + grid .b - - = - +} -cleanup { + grid_reset 11.4 +} -returnCodes error -result {invalid window shortcut, "=" should be '-', 'x', or '^'} -test grid-11.5 {default widget placement} { +test grid-11.5 {default widget placement} -body { button .b - list [catch {grid .b - x -} msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.5 + grid .b - x - +} -cleanup { + grid_reset 11.5 +} -returnCodes error -result {Must specify window before shortcut '-'.} -test grid-11.6 {default widget placement} { +test grid-11.6 {default widget placement} -body { foreach i {1 2 3 4 5 6} { frame .f$i -width 50 -height 50 -highlightthickness 0 -bg red } @@ -893,31 +945,35 @@ test grid-11.6 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,50 100,50} {150,50 50,50}} -grid_reset 11.6 +} -cleanup { + grid_reset 11.6 +} -result {{0,50 100,50} {150,50 50,50}} -test grid-11.7 {default widget placement} { +test grid-11.7 {default widget placement} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -row 5 -column 5 - list [catch "grid .f x -" msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.7 + grid .f x - +} -cleanup { + grid_reset 11.7 +} -returnCodes error -result {Must specify window before shortcut '-'.} -test grid-11.8 {default widget placement} { +test grid-11.8 {default widget placement} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -row 5 -column 5 - list [catch "grid .f ^ -" msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.8 + grid .f ^ - +} -cleanup { + grid_reset 11.8 +} -returnCodes error -result {Must specify window before shortcut '-'.} -test grid-11.9 {default widget placement} { +test grid-11.9 {default widget placement} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid .f -row 5 -column 5 - list [catch "grid .f x ^" msg] $msg -} {1 {can't find slave to extend with "^".}} -grid_reset 11.9 + grid .f x ^ +} -cleanup { + grid_reset 11.9 +} -returnCodes error -result {can't find slave to extend with "^".} -test grid-11.10 {default widget placement} { +test grid-11.10 {default widget placement} -body { foreach i {1 2 3} { frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red } @@ -930,10 +986,11 @@ test grid-11.10 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,0 100,50} {100,0 100,100} {0,50 100,50}} -grid_reset 11.10 +} -cleanup { + grid_reset 11.10 +} -result {{0,0 100,50} {100,0 100,100} {0,50 100,50}} -test grid-11.11 {default widget placement} { +test grid-11.11 {default widget placement} -body { foreach i {1 2 3 4 5 6 7 8 9 10 11 12} { frame .f$i -width 50 -height 50 -highlightthickness 1 -highlightbackground black } @@ -949,10 +1006,11 @@ test grid-11.11 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,50 50,50} {50,50 100,150} {150,50 50,50} {0,100 50,50} {150,100 50,50} {0,150 50,50} {150,150 50,50} {0,200 200,50}} -grid_reset 11.11 +} -cleanup { + grid_reset 11.11 +} -result {{0,50 50,50} {50,50 100,150} {150,50 50,50} {0,100 50,50} {150,100 50,50} {0,150 50,50} {150,150 50,50} {0,200 200,50}} -test grid-11.12 {default widget placement} { +test grid-11.12 {default widget placement} -body { foreach i {1 2 3 4} { frame .f$i -width 75 -height 50 -highlightthickness 1 -highlightbackground black } @@ -971,10 +1029,11 @@ test grid-11.12 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,0 75,50} {75,0 75,100} {150,0 75,50} {0,50 75,50} {0,0 75,50} {75,0 75,100} {150,0 75,100} {75,50 75,50}} -grid_reset 11.12 +} -cleanup { + grid_reset 11.12 +} -result {{0,0 75,50} {75,0 75,100} {150,0 75,50} {0,50 75,50} {0,0 75,50} {75,0 75,100} {150,0 75,100} {75,50 75,50}} -test grid-11.13 {default widget placement} { +test grid-11.13 {default widget placement} -body { foreach i {1 2 3 4 5 6 7} { frame .f$i -width 40 -height 50 -highlightthickness 1 -highlightbackground black } @@ -987,10 +1046,11 @@ test grid-11.13 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,50 120,50} {120,50 80,50}} -grid_reset 11.13 +} -cleanup { + grid_reset 11.13 +} -result {{0,50 120,50} {120,50 80,50}} -test grid-11.14 {default widget placement} { +test grid-11.14 {default widget placement} -body { foreach i {1 2 3} { frame .f$i -width 60 -height 60 -highlightthickness 0 -bg red } @@ -1003,10 +1063,11 @@ test grid-11.14 {default widget placement} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,30 60,60} {60,0 60,60} {60,60 60,60}} -grid_reset 11.14 +} -cleanup { + grid_reset 11.14 +} -result {{0,30 60,60} {60,0 60,60} {60,60 60,60}} -test grid-11.15 {^ ^ test with multiple windows} { +test grid-11.15 {^ ^ test with multiple windows} -body { foreach i {1 2 3 4} { frame .f$i -width 50 -height 50 -bd 1 -relief solid } @@ -1019,24 +1080,26 @@ test grid-11.15 {^ ^ test with multiple windows} { [winfo width .f$i],[winfo height .f$i]" } set a -} {{0,0 50,50} {50,0 50,100} {100,0 50,100} {0,50 50,50}} -grid_reset 11.15 +} -cleanup { + grid_reset 11.15 +} -result {{0,0 50,50} {50,0 50,100} {100,0 50,100} {0,50 50,50}} -test grid-11.16 {default widget placement} { +test grid-11.16 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } - grid .a .b .c .d -sticky news + grid .a .b .c .d -sticky news grid x ^ x .e -sticky news update set res "" lappend res [winfo height .a] lappend res [winfo height .b] lappend res [winfo height .c] -} {50 100 50} -grid_reset 11.16 +} -cleanup { + grid_reset 11.16 +} -result {50 100 50} -test grid-11.17 {default widget placement} { +test grid-11.17 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1047,10 +1110,11 @@ test grid-11.17 {default widget placement} { lappend res [winfo height .a] lappend res [winfo height .b] lappend res [winfo height .c] -} {100 50 100} -grid_reset 11.17 +} -cleanup { + grid_reset 11.17 +} -result {100 50 100} -test grid-11.18 {default widget placement} { +test grid-11.18 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1063,10 +1127,11 @@ test grid-11.18 {default widget placement} { lappend res [winfo height .b] lappend res [winfo height .c] lappend res [winfo height .d] -} {100 100 100 50} -grid_reset 11.18 +} -cleanup { + grid_reset 11.18 +} -result {100 100 100 50} -test grid-11.19 {default widget placement} { +test grid-11.19 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1082,10 +1147,12 @@ test grid-11.19 {default widget placement} { lappend res [winfo height .b] lappend res [winfo height .c] lappend res [winfo height .d] -} {50 100 100 50} -grid_reset 11.19 +} -cleanup { + grid_reset 11.19 +} -result {50 100 100 50} + -test grid-12.1 {-sticky} { +test grid-12.1 {-sticky} -body { catch {unset data} frame .f -width 200 -height 100 -highlightthickness 0 -bg red set a "" @@ -1101,7 +1168,9 @@ test grid-12.1 {-sticky} { append a "($data(-sticky)) [winfo x .f] [winfo y .f] [winfo width .f] [winfo height .f]\n" } set a -} {() 25 25 200 100 +} -cleanup { + grid_reset 12.1 +} -result {() 25 25 200 100 (n) 25 0 200 100 (s) 25 50 200 100 (e) 50 25 200 100 @@ -1118,63 +1187,71 @@ test grid-12.1 {-sticky} { (new) 0 0 250 100 (nesw) 0 0 250 150 } -grid_reset 12.1 - -test grid-12.2 {-sticky} { + +test grid-12.2 {-sticky} -body { frame .f -bg red - list [catch "grid .f -sticky glue" msg] $msg -} {1 {bad stickyness value "glue": must be a string containing n, e, s, and/or w}} -grid_reset 12.2 - -test grid-12.3 {-sticky} { + grid .f -sticky glue +} -cleanup { + grid_reset 12.2 +} -returnCodes error -result {bad stickyness value "glue": must be a string containing n, e, s, and/or w} + +test grid-12.3 {-sticky} -body { frame .f -bg red grid .f -sticky {n,s,e,w} array set A [grid info .f] set A(-sticky) -} {nesw} -grid_reset 12.3 +} -cleanup { + grid_reset 12.3 +} -result {nesw} -test grid-13.1 {-in} { + +test grid-13.1 {-in} -body { frame .f -bg red - list [catch "grid .f -in .f" msg] $msg -} {1 {Window can't be managed in itself}} -grid_reset 13.1 + grid .f -in .f +} -cleanup { + grid_reset 13.1 +} -returnCodes error -result {Window can't be managed in itself} -test grid-13.1.1 {-in} { +test grid-13.2 {-in} -body { frame .f -bg red list [winfo manager .f] \ [catch {grid .f -in .f} err] $err \ [winfo manager .f] -} {{} 1 {Window can't be managed in itself} {}} -grid_reset 13.1.1 +} -cleanup { + grid_reset 13.1.1 +} -result {{} 1 {Window can't be managed in itself} {}} -test grid-13.2 {-in} { +test grid-13.3 {-in} -body { frame .f -bg red - list [catch "grid .f -in .bad" msg] $msg -} {1 {bad window path name ".bad"}} -grid_reset 13.2 + grid .f -in .bad +} -cleanup { + grid_reset 13.2 +} -returnCodes error -result {bad window path name ".bad"} -test grid-13.3 {-in} { +test grid-13.4 {-in} -body { frame .f -bg red toplevel .top - list [catch "grid .f -in .top" msg] $msg -} {1 {can't put .f inside .top}} + grid .f -in .top +} -cleanup { + grid_reset 13.3 +} -returnCodes error -result {can't put .f inside .top} destroy .top -grid_reset 13.3 -test grid-13.4 {-ipadx} { +test grid-13.5 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipadx x" msg] $msg -} {1 {bad ipadx value "x": must be positive screen distance}} -grid_reset 13.4 + grid .f -ipadx x +} -cleanup { + grid_reset 13.4 +} -returnCodes error -result {bad ipadx value "x": must be positive screen distance} -test grid-13.4.1 {-ipadx} { +test grid-13.6 {-ipadx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipadx {5 5}" msg] $msg -} {1 {bad ipadx value "5 5": must be positive screen distance}} -grid_reset 13.4.1 + grid .f -ipadx {5 5} +} -cleanup { + grid_reset 13.4.1 +} -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance} -test grid-13.5 {-ipadx} { +test grid-13.7 {-ipadx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1182,22 +1259,25 @@ test grid-13.5 {-ipadx} { grid .f -ipadx 1 update list $a [winfo width .f] -} {200 202} -grid_reset 13.5 +} -cleanup { + grid_reset 13.5 +} -result {200 202} -test grid-13.6 {-ipady} { +test grid-13.8 {-ipady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipady x" msg] $msg -} {1 {bad ipady value "x": must be positive screen distance}} -grid_reset 13.6 + grid .f -ipady x +} -cleanup { + grid_reset 13.6 +} -returnCodes error -result {bad ipady value "x": must be positive screen distance} -test grid-13.6.1 {-ipady} { +test grid-13.9 {-ipady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -ipady {5 5}" msg] $msg -} {1 {bad ipady value "5 5": must be positive screen distance}} -grid_reset 13.6.1 + grid .f -ipady {5 5} +} -cleanup { + grid_reset 13.6.1 +} -returnCodes error -result {bad ipady value "5 5": must be positive screen distance} -test grid-13.7 {-ipady} { +test grid-13.10 {-ipady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1205,22 +1285,25 @@ test grid-13.7 {-ipady} { grid .f -ipady 1 update list $a [winfo height .f] -} {100 102} -grid_reset 13.7 +} -cleanup { + grid_reset 13.7 +} -result {100 102} -test grid-13.8 {-padx} { +test grid-13.11 {-padx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -padx x" msg] $msg -} {1 {bad pad value "x": must be positive screen distance}} -grid_reset 13.8 + grid .f -padx x +} -cleanup { + grid_reset 13.8 +} -returnCodes error -result {bad pad value "x": must be positive screen distance} -test grid-13.8.1 {-padx} { +test grid-13.12 {-padx} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -padx {10 x}" msg] $msg -} {1 {bad 2nd pad value "x": must be positive screen distance}} -grid_reset 13.8.1 + grid .f -padx {10 x} +} -cleanup { + grid_reset 13.8.1 +} -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance} -test grid-13.9 {-padx} { +test grid-13.13 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1228,10 +1311,11 @@ test grid-13.9 {-padx} { grid .f -padx 1 update list $a "[winfo width .f] [winfo width .] [winfo x .f]" -} {{200 200} {200 202 1}} -grid_reset 13.9 +} -cleanup { + grid_reset 13.9 +} -result {{200 200} {200 202 1}} -test grid-13.9.1 {-padx} { +test grid-13.14 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1239,22 +1323,25 @@ test grid-13.9.1 {-padx} { grid .f -padx {10 5} update list $a "[winfo width .f] [winfo width .] [winfo x .f]" -} {{200 200} {200 215 10}} -grid_reset 13.9.1 +} -cleanup { + grid_reset 13.9.1 +} -result {{200 200} {200 215 10}} -test grid-13.10 {-pady} { +test grid-13.15 {-pady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -pady x" msg] $msg -} {1 {bad pad value "x": must be positive screen distance}} -grid_reset 13.10 + grid .f -pady x +} -cleanup { + grid_reset 13.10 +} -returnCodes error -result {bad pad value "x": must be positive screen distance} -test grid-13.10.1 {-pady} { +test grid-13.16 {-pady} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red - list [catch "grid .f -pady {10 x}" msg] $msg -} {1 {bad 2nd pad value "x": must be positive screen distance}} -grid_reset 13.10.1 + grid .f -pady {10 x} +} -cleanup { + grid_reset 13.10.1 +} -returnCodes error -result {bad 2nd pad value "x": must be positive screen distance} -test grid-13.11 {-pady} { +test grid-13.17 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1262,10 +1349,11 @@ test grid-13.11 {-pady} { grid .f -pady 1 update list $a "[winfo height .f] [winfo height .] [winfo y .f]" -} {{100 100} {100 102 1}} -grid_reset 13.11 +} -cleanup { + grid_reset 13.11 +} -result {{100 100} {100 102 1}} -test grid-13.11.1 {-pady} { +test grid-13.18 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1273,10 +1361,11 @@ test grid-13.11.1 {-pady} { grid .f -pady {4 16} update list $a "[winfo height .f] [winfo height .] [winfo y .f]" -} {{100 100} {100 120 4}} -grid_reset 13.11.1 +} -cleanup { + grid_reset 13.11.1 +} -result {{100 100} {100 120 4}} -test grid-13.12 {-ipad x and y} { +test grid-13.19 {-ipad x and y} -body { frame .f -width 20 -height 20 -highlightthickness 0 -bg red grid columnconfigure . 0 -minsize 150 grid rowconfigure . 0 -minsize 100 @@ -1292,10 +1381,11 @@ test grid-13.12 {-ipad x and y} { } } set a -} { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30} -grid_reset 13.12 +} -cleanup { + grid_reset 13.12 +} -result { 0,0:,65,40,20,20 0,5:,65,35,20,30 5,0:,60,40,30,20 5,5:,60,35,30,30} -test grid-13.13 {reparenting} { +test grid-13.20 {reparenting} -body { frame .1 frame .2 button .b @@ -1309,14 +1399,16 @@ test grid-13.13 {reparenting} { lappend a [grid slaves .1],[grid slaves .2],$info(-in) unset info set a -} {.b,,.1 ,.b,.2} -grid_reset 13.13 +} -cleanup { + grid_reset 13.13 +} -result {.b,,.1 ,.b,.2} + -test grid-14.1 {structure notify} { +test grid-14.1 {structure notify} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red frame .g -width 200 -height 100 -highlightthickness 0 -bg red - grid .f - grid .g -in .f + grid .f + grid .g -in .f update set a "" lappend a "[winfo x .g],[winfo y .g] \ @@ -1326,13 +1418,14 @@ test grid-14.1 {structure notify} { lappend a "[winfo x .g],[winfo y .g] \ [winfo width .g],[winfo height .g]" set a -} {{0,0 200,100} {5,5 200,100}} -grid_reset 14.1 +} -cleanup { + grid_reset 14.1 +} -result {{0,0 200,100} {5,5 200,100}} -test grid-14.2 {structure notify} { - frame .f -width 200 -height 100 - frame .f.g -width 200 -height 100 - grid .f +test grid-14.2 {structure notify} -body { + frame .f -width 200 -height 100 + frame .f.g -width 200 -height 100 + grid .f grid .f.g update set a "" @@ -1340,10 +1433,13 @@ test grid-14.2 {structure notify} { .f config -bd 20 update lappend a [grid bbox .],[grid bbox .f] -} {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}} -grid_reset 14.2 +} -cleanup { + grid_reset 14.2 +} -result {{0 0 200 100,0 0 200 100} {0 0 240 140,20 20 200 100}} -test grid-14.3 {map notify: bug 1648} {nonPortable} { +test grid-14.3 {map notify: bug 1648} -constraints { + nonPortable +} -body { # This test is nonPortable because the number of times # A(.) will be incremented is unspecified--the behavior # is different accross window managers. @@ -1362,10 +1458,12 @@ test grid-14.3 {map notify: bug 1648} {nonPortable} { update bind . <Configure> {} array get A -} {.2 2 .0 1 . 2 .1 1} -grid_reset 14.3 +} -cleanup { + grid_reset 14.3 +} -result {.2 2 .0 1 . 2 .1 1} + -test grid-15.1 {lost slave} { +test grid-15.1 {lost slave} -body { button .b grid .b set a [grid slaves .] @@ -1373,23 +1471,26 @@ test grid-15.1 {lost slave} { lappend a [grid slaves .] grid .b lappend a [grid slaves .] -} {.b {} .b} -grid_reset 15.1 +} -cleanup { + grid_reset 15.1 +} -result {.b {} .b} -test grid-15.2 {lost slave} { +test grid-15.2 {lost slave} -body { frame .f grid .f button .b grid .b -in .f set a [grid slaves .f] - pack .b + pack .b -in .f lappend a [grid slaves .f] grid .b -in .f lappend a [grid slaves .f] -} {.b {} .b} -grid_reset 15.2 +} -cleanup { + grid_reset 15.2 +} -result {.b {} .b} + -test grid-16.1 {layout centering} { +test grid-16.1 {layout centering} -body { foreach i {0 1 2} { frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1399,10 +1500,11 @@ test grid-16.1 {layout centering} { . configure -width 300 -height 250 update grid bbox . -} {37 50 225 150} -grid_reset 16.1 +} -cleanup { + grid_reset 16.1 +} -result {37 50 225 150} -test grid-16.2 {layout weights (expanding)} { +test grid-16.2 {layout weights (expanding)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1417,12 +1519,13 @@ test grid-16.2 {layout weights (expanding)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {120-75 167-100 213-125} -grid_reset 16.2 +} -cleanup { + grid_reset 16.2 +} -result {120-75 167-100 213-125} -test grid-16.3 {layout weights (shrinking)} { +test grid-16.3 {layout weights (shrinking)} -body { foreach i {0 1 2} { - frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe grid rowconfigure . $i -weight [expr $i + 1] grid columnconfigure . $i -weight [expr $i + 1] @@ -1435,10 +1538,11 @@ test grid-16.3 {layout weights (shrinking)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {84-63 66-50 50-37} -grid_reset 16.3 +} -cleanup { + grid_reset 16.3 +} -result {84-63 66-50 50-37} -test grid-16.4 {layout weights (shrinking with minsize)} { +test grid-16.4 {layout weights (shrinking with minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1453,10 +1557,11 @@ test grid-16.4 {layout weights (shrinking with minsize)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {70-60 65-45 65-45} -grid_reset 16.4 +} -cleanup { + grid_reset 16.4 +} -result {70-60 65-45 65-45} -test grid-16.5 {layout weights (shrinking at minsize)} { +test grid-16.5 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1471,11 +1576,12 @@ test grid-16.5 {layout weights (shrinking at minsize)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {100-75 100-75 100-75} -grid_reset 16.5 +} -cleanup { + grid_reset 16.5 +} -result {100-75 100-75 100-75} -test grid-16.6 {layout weights (shrinking at minsize)} { +test grid-16.6 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1490,10 +1596,17 @@ test grid-16.6 {layout weights (shrinking at minsize)} { lappend a [winfo width .$i]-[winfo height .$i] } set a -} {69-52 69-52 69-52} -grid_reset 16.6 - -test grid-16.7 {layout weights (shrinking at minsize)} { +} -cleanup { + grid_reset 16.6 +} -result {69-52 69-52 69-52} + +# test fails when run alone +# reason (I think): -minsize 0 causes both: +# [winfo ismapped .$i] => 0 and +# not responding for width ang height settings, so that +# [winfo width .$i] [winfo height .$i] take different values +# That doesn't happen if previous tests run +test grid-16.7 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1501,17 +1614,18 @@ test grid-16.7 {layout weights (shrinking at minsize)} { grid propagate . 0 grid columnconfigure . 1 -weight 1 -minsize 0 grid rowconfigure . 1 -weight 1 -minsize 0 - . configure -width 100 -height 75 + . configure -width 100 -height 1 set a "" update foreach i {0 1 2} { lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i] } set a -} {100-75-1 1-1-0 100-75-1} -grid_reset 16.7 +} -cleanup { + grid_reset 16.7 +} -result {100-75-1 1-1-0 100-75-1} -test grid-16.8 {layout internal constraints} { +test grid-16.8 {layout internal constraints} -body { foreach i {0 1 2 3 4} { frame .$i -bg gray -width 30 -height 25 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1547,10 +1661,11 @@ test grid-16.8 {layout internal constraints} { append a "[winfo x .$i] " } set a -} {0 30 130 230 280 , 0 30 130 230 260 , 0 30 113 196 280 , 0 30 60 90 120 } -grid_reset 16.8 +} -cleanup { + grid_reset 16.8 +} -result {0 30 130 230 280 , 0 30 130 230 260 , 0 30 113 196 280 , 0 30 60 90 120 } -test grid-16.9 {layout uniform} { +test grid-16.9 {layout uniform} -body { frame .f1 -width 75 -height 50 frame .f2 -width 60 -height 25 frame .f3 -width 95 -height 75 @@ -1564,10 +1679,11 @@ test grid-16.9 {layout uniform} { update list [grid bbox . 0 0] [grid bbox . 0 1] [grid bbox . 0 2] \ [grid bbox . 0 3] [grid bbox . 0 4] -} {{0 0 135 75} {0 75 135 100} {0 175 135 75} {0 250 135 100} {0 350 135 40}} -grid_reset 16.9 +} -cleanup { + grid_reset 16.9 +} -result {{0 0 135 75} {0 75 135 100} {0 175 135 75} {0 250 135 100} {0 350 135 40}} -test grid-16.10 {layout uniform} { +test grid-16.10 {layout uniform} -body { grid [frame .f1 -width 75 -height 50] -row 0 -column 0 grid [frame .f2 -width 60 -height 30] -row 1 -column 2 grid [frame .f3 -width 95 -height 90] -row 2 -column 1 @@ -1585,10 +1701,11 @@ test grid-16.10 {layout uniform} { update list [grid bbox . 0 0] [grid bbox . 2 1] [grid bbox . 1 2] \ [grid bbox . 4 3] [grid bbox . 3 4] -} {{0 0 75 60} {170 60 150 30} {75 90 95 90} {390 180 140 100} {320 280 70 45}} -grid_reset 16.10 +} -cleanup { + grid_reset 16.10 +} -result {{0 0 75 60} {170 60 150 30} {75 90 95 90} {390 180 140 100} {320 280 70 45}} -test grid-16.11 {layout uniform (shrink)} { +test grid-16.11 {layout uniform (shrink)} -body { frame .f1 -width 75 -height 50 frame .f2 -width 100 -height 95 grid .f1 .f2 -sticky news @@ -1601,10 +1718,11 @@ test grid-16.11 {layout uniform (shrink)} { . configure -width 150 -height 95 update lappend res [grid bbox . 0 0] [grid bbox . 1 0] -} {{0 0 100 95} {100 0 100 95} {0 0 50 95} {50 0 100 95}} -grid_reset 16.11 +} -cleanup { + grid_reset 16.11 +} -result {{0 0 100 95} {100 0 100 95} {0 0 50 95} {50 0 100 95}} -test grid-16.12 {layout uniform (grow)} { +test grid-16.12 {layout uniform (grow)} -body { frame .f1 -width 40 -height 50 frame .f2 -width 50 -height 95 frame .f3 -width 60 -height 50 @@ -1625,11 +1743,12 @@ test grid-16.12 {layout uniform (grow)} { update lappend res [grid bbox . 0 0] [grid bbox . 1 0] lappend res [grid bbox . 2 0] [grid bbox . 3 0] -} [list {0 0 50 95} {50 0 50 95} {100 0 100 95} {200 0 70 95} \ +} -cleanup { + grid_reset 16.12 +} -result [list {0 0 50 95} {50 0 50 95} {100 0 100 95} {200 0 70 95} \ {0 0 70 95} {70 0 50 95} {120 0 140 95} {260 0 90 95}] -grid_reset 16.12 -test grid-16.13 {layout span} { +test grid-16.13 {layout span} -body { frame .f1 -width 24 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1652,11 +1771,12 @@ test grid-16.13 {layout span} { set res # The last result below should ideally be 8 8 8 126 but the current # implementation is not exact enough. -} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ +} -cleanup { + grid_reset 16.13 +} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ [list 18 38 18 76 0] [list 7 8 9 126 0]] -grid_reset 16.13 -test grid-16.14 {layout span} { +test grid-16.14 {layout span} -body { frame .f1 -width 110 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1677,11 +1797,12 @@ test grid-16.14 {layout span} { lappend res $res2 } set res -} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ +} -cleanup { + grid_reset 16.14 +} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 14 42 56 38 0] \ [list 27 55 28 40 0] [list 36 37 37 40 0]] -grid_reset 16.14 -test grid-16.15 {layout span} { +test grid-16.15 {layout span} -body { frame .f1 -width 24 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1702,11 +1823,12 @@ test grid-16.15 {layout span} { lappend res $res2 } set res -} [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 0 0 112 38 0] \ +} -cleanup { + grid_reset 16.15 +} -result [list [list 0 112 0 38 0] [list 0 0 112 38 0] [list 0 0 112 38 0] \ [list 0 37 37 76 0] [list 0 12 12 126 0]] -grid_reset 16.15 -test grid-16.16 {layout span} { +test grid-16.16 {layout span} -body { frame .f1 -width 64 -height 20 frame .f2 -width 38 -height 20 frame .f3 -width 150 -height 20 @@ -1731,11 +1853,12 @@ test grid-16.16 {layout span} { lappend res $res2 } set res -} [list [list 30 34 43 43 0] [list 30 34 48 38 0] [list 22 42 48 38 0] \ +} -cleanup { + grid_reset 16.16 +} -result [list [list 30 34 43 43 0] [list 30 34 48 38 0] [list 22 42 48 38 0] \ [list 25 39 29 57 0] [list 30 34 22 64 0]] -grid_reset 16.16 -test grid-16.17 {layout weights (shrinking at minsize)} { +test grid-16.17 {layout weights (shrinking at minsize)} -body { foreach i {0 1 2 3} { frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1755,10 +1878,11 @@ test grid-16.17 {layout weights (shrinking at minsize)} { lappend a [winfo width .$i]-[winfo height .$i]-[winfo ismapped .$i] } set a -} {25-25-1 25-25-1 100-75-1 100-75-1 25-25-0 25-25-0 100-75-1 100-75-1} -grid_reset 16.17 +} -cleanup { + grid_reset 16.17 +} -result {25-25-1 25-25-1 100-75-1 100-75-1 25-25-0 25-25-0 100-75-1 100-75-1} -test grid-16.18 {layout span} { +test grid-16.18 {layout span} -body { frame .f1 -width 30 -height 20 frame .f2 -width 166 -height 20 frame .f3 -width 39 -height 20 @@ -1781,10 +1905,36 @@ test grid-16.18 {layout span} { lappend res $res2 } set res -} [list [list 137 29 10] [list 30 136 10] [list 98 68 10]] -grid_reset 16.18 +} -cleanup { + grid_reset 16.18 +} -result [list [list 137 29 10] [list 30 136 10] [list 98 68 10]] + +test grid-16.19 {layout span} -constraints { knownBug } -body { + # This test shows the problem in Bug 2075285 + # Several overlapping multi-span widgets is a weak spot + # in the current implementation. + # Test present as a reminder in case a future algorithm update is made. + frame .f1 -width 100 -height 20 + frame .f2 -width 20 -height 20 + frame .f3 -width 10 -height 20 + frame .f4 -width 20 -height 20 + + grid .f1 - - - - - -sticky we + grid .f2 - .f3 - .f4 - -sticky we + grid columnconfigure . {1 5} -weight 1 -test grid-17.1 {forget and pending idle handlers} { + set res {} + update + for {set c 0} {$c <= 5} {incr c} { + lappend res [lindex [grid bbox . $c 0] 2] + } + set res +} -cleanup { + grid_reset 16.19 +} -result [list 0 45 5 5 0 45] + + +test grid-17.1 {forget and pending idle handlers} -body { # This test is intended to detect a crash caused by a failure to remove # pending idle handlers when grid forget is invoked. @@ -1805,9 +1955,10 @@ test grid-17.1 {forget and pending idle handlers} { grid .t.f.l destroy .t set result ok -} ok +} -result ok + -test grid-18.1 {test respect for internalborder} { +test grid-18.1 {test respect for internalborder} -body { toplevel .pack wm geometry .pack 200x200 frame .pack.l -width 15 -height 10 @@ -1824,8 +1975,8 @@ test grid-18.1 {test respect for internalborder} { lappend res [winfo geometry .pack.lf.f] destroy .pack set res -} {196x188+2+10 177x186+5+7} -test grid-18.2 {test support for minreqsize} { +} -result {196x188+2+10 177x186+5+7} +test grid-18.2 {test support for minreqsize} -body { toplevel .pack wm geometry .pack {} frame .pack.l -width 150 -height 100 @@ -1840,9 +1991,10 @@ test grid-18.2 {test support for minreqsize} { lappend res [winfo geometry .pack.lf] destroy .pack set res -} {162x127+0+0 172x112+0+0} +} -result {162x127+0+0 172x112+0+0} -test grid-19.1 {uniform realloc} { + +test grid-19.1 {uniform realloc} -body { # Use a lot of uniform groups to test the reallocation mechanism for {set t 0} {$t < 100} {incr t 2} { frame .fa$t -width 5 -height 20 @@ -1852,55 +2004,65 @@ test grid-19.1 {uniform realloc} { } update grid bbox . -} {0 0 600 20} -grid_reset 19.1 +} -cleanup { + grid_reset 19.1 +} -result {0 0 600 20} + -test grid-20.1 {recalculate size after removal (destroy)} { +test grid-20.1 {recalculate size after removal (destroy)} -body { label .l1 -text l1 grid .l1 -row 2 -column 2 destroy .l1 label .l2 -text l2 grid .l2 grid size . -} {1 1} -grid_reset 20.1 +} -cleanup { + grid_reset 20.1 +} -result {1 1} -test grid-20.2 {recalculate size after removal (forget)} { +test grid-20.2 {recalculate size after removal (forget)} -body { label .l1 -text l1 grid .l1 -row 2 -column 2 grid forget .l1 label .l2 -text l2 grid .l2 grid size . -} {1 1} -grid_reset 20.2 - -test grid-21.1 {anchor} { - list [catch {grid anchor . 1 xxx} msg] $msg -} {1 {wrong # args: should be "grid anchor window ?anchor?"}} -grid_reset 21.1 - -test grid-21.2 {anchor} { - list [catch {grid anchor .} msg] $msg -} {0 nw} -grid_reset 21.2 - -test grid-21.3 {anchor} { - list [catch {grid anchor . se;grid anchor .} msg] $msg -} {0 se} -grid_reset 21.3 - -test grid-21.4 {anchor} { - list [catch {grid anchor .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 21.4 - -test grid-21.5 {anchor} { - list [catch {grid anchor . x} msg] $msg -} {1 {bad anchor "x": must be n, ne, e, se, s, sw, w, nw, or center}} -grid_reset 21.5 - -test grid-21.6 {anchor} { +} -cleanup { + grid_reset 20.2 +} -result {1 1} + + +test grid-21.1 {anchor} -body { + grid anchor . 1 xxx +} -cleanup { + grid_reset 21.1 +} -returnCodes error -result {wrong # args: should be "grid anchor window ?anchor?"} + +test grid-21.2 {anchor} -body { + grid anchor . +} -cleanup { + grid_reset 21.2 +} -result {nw} + +test grid-21.3 {anchor} -body { + grid anchor . se;grid anchor . +} -cleanup { + grid_reset 21.3 +} -result {se} + +test grid-21.4 {anchor} -body { + grid anchor .x +} -cleanup { + grid_reset 21.4 +} -returnCodes error -result {bad window path name ".x"} + +test grid-21.5 {anchor} -body { + grid anchor . x +} -cleanup { + grid_reset 21.5 +} -returnCodes error -result {bad anchor "x": must be n, ne, e, se, s, sw, w, nw, or center} + +test grid-21.6 {anchor} -body { foreach i {0 1 2} { frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge grid .$i -row $i -column $i -sticky nswe @@ -1915,12 +2077,13 @@ test grid-21.6 {anchor} { lappend res [grid bbox .] } set res -} [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \ +} -cleanup { + grid_reset 21.6 +} -result [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \ {37 100 225 150} {0 100 225 150} {0 50 225 150} {0 0 225 150} \ {37 50 225 150}] -grid_reset 21.6 -test grid-21.7 {anchor} { +test grid-21.7 {anchor} -body { # Test with a non-symmetric internal border. # This only tests vertically, there is currently no way to get # it assymetric horizontally. @@ -1945,10 +2108,11 @@ test grid-21.7 {anchor} { } pack propagate . 1 ; wm geometry . {} set res -} [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \ +} -cleanup { + grid_reset 21.7 +} -result [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \ {37 100 225 150} {0 100 225 150} {0 60 225 150} {0 20 225 150} \ {37 60 225 150}] -grid_reset 21.7 test grid-22.1 {remove: basic argument checking} { list [catch {grid remove foo} msg] $msg diff --git a/tests/id.test b/tests/id.test deleted file mode 100644 index de0d965..0000000 --- a/tests/id.test +++ /dev/null @@ -1,91 +0,0 @@ -# This file is a Tcl script to test out the procedures in the file -# tkId.c, which recycle X resource identifiers. It is organized in -# the standard fashion for Tcl tests. -# -# Copyright (c) 1995 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. -# All rights reserved. - -package require tcltest 2.1 -eval tcltest::configure $argv -tcltest::loadTestedCommands - -test id-1.1 {WindowIdCleanup, delaying window release} {unix testwrapper} { - bind all <Destroy> {lappend x %W} - catch {unset map} - frame .f - set j 0 - foreach i {a b c d e f g h i j k l m n o p q} { - toplevel .f.$i -height 50 -width 100 - wm geometry .f.$i +$j+$j - incr j 10 - update - set map([winfo id .f.$i]) .f.$i - set map([testwrapper .f.$i]) wrapper.f.$i - } - set x {} - destroy .f - - # Destroy events should have occurred for all windows. - set result [list [lsort $x]] - - set x {} - update idletasks - set reused {} - foreach i {a b c d e} { - set w .${i}2 - frame $w -height 20 -width 100 -bd 2 -relief raised - pack $w - if [info exists map([winfo id $w])] { - lappend reused $map([winfo id $w]) - } - set map([winfo id $w]) $w - } - - # No window ids should have been reused: stale Destroy events still - # pending in queue. - lappend result [lsort $reused] - - # Wait a few seconds, then try again; ids should still not have - # been re-used. - - set y 0 - after 2000 {set y 1} - tkwait variable y - foreach i {a b c} { - set w .${i}3 - frame $w -height 20 -width 100 -bd 2 -relief raised - pack $w - if [info exists map([winfo id $w])] { - lappend reused $map([winfo id $w]) - } - set map([winfo id $w])] $w - } - - # Ids should not yet have been reused. - lappend result [lsort $reused] - - - # Wait a few more seconds, to give ids enough time to be recycled. - set y 0 - after 6000 {set y 1} - tkwait variable y - foreach i {a b c d e f} { - set w .${i}4 - frame $w -height 20 -width 100 -bd 2 -relief raised - pack $w - if [info exists map([winfo id $w])] { - lappend reused $map([winfo id $w]) - } - set map([winfo id $w])] $w - } - - # Ids should be reused now, due to time delay. Destroy events should - # have been discarded. - lappend result [lsort $reused] [lsort $x] -} {{.f .f.a .f.b .f.c .f.d .f.e .f.f .f.g .f.h .f.i .f.j .f.k .f.l .f.m .f.n .f.o .f.p .f.q} {} {} {.f.o .f.p .f.q wrapper.f.p wrapper.f.q} {}} -bind all <Destroy> {} - -# cleanup -cleanupTests -return diff --git a/tests/image.test b/tests/image.test index c6c4f8a..3134ee8 100644 --- a/tests/image.test +++ b/tests/image.test @@ -7,38 +7,56 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force ::tk::test::loadTkCommand -eval image delete [image names] +imageInit + +# Canvas used in some tests in the whole file canvas .c -highlightthickness 2 pack .c update -test image-1.1 {Tk_ImageCmd procedure, "create" option} { - list [catch image msg] $msg -} {1 {wrong # args: should be "image option ?args?"}} -test image-1.2 {Tk_ImageCmd procedure, "create" option} { - list [catch {image gorp} msg] $msg -} {1 {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width}} -test image-1.3 {Tk_ImageCmd procedure, "create" option} { - list [catch {image create} msg] $msg -} {1 {wrong # args: should be "image create type ?name? ?options?"}} -test image-1.4 {Tk_ImageCmd procedure, "create" option} { - list [catch {image c bad_type} msg] $msg -} {1 {image type "bad_type" doesn't exist}} -test image-1.5 {Tk_ImageCmd procedure, "create" option} testImageType { - list [image create test myimage] [image names] -} {myimage myimage} -test image-1.6 {Tk_ImageCmd procedure, "create" option} testImageType { + + +test image-1.1 {Tk_ImageCmd procedure, "create" option} -body { + image +} -returnCodes error -result {wrong # args: should be "image option ?args?"} +test image-1.2 {Tk_ImageCmd procedure, "create" option} -body { + image gorp +} -returnCodes error -result {bad option "gorp": must be create, delete, height, inuse, names, type, types, or width} +test image-1.3 {Tk_ImageCmd procedure, "create" option} -body { + image create +} -returnCodes error -result {wrong # args: should be "image create type ?name? ?-option value ...?"} +test image-1.4 {Tk_ImageCmd procedure, "create" option} -body { + image c bad_type +} -returnCodes error -result {image type "bad_type" doesn't exist} +test image-1.5 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -body { + list [image create test myimage] [imageNames] +} -cleanup { + imageCleanup +} -result {myimage myimage} +test image-1.6 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { scan [image create test] image%d first image create test myimage scan [image create test -variable x] image%d second expr $second-$first -} {1} -test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { - image delete myimage +} -cleanup { + imageCleanup +} -result {1} + +test image-1.7 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { image create test myimage -variable x .c create image 100 50 -image myimage .c create image 100 150 -image myimage @@ -46,10 +64,16 @@ test image-1.7 {Tk_ImageCmd procedure, "create" option} testImageType { set x {} image create test myimage -variable x update - set x -} {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} -test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { + return $x +} -cleanup { + imageCleanup +} -result {{myimage free} {myimage free} {myimage delete} {myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} +test image-1.8 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -setup { .c delete all + imageCleanup +} -body { image create test myimage -variable x .c create image 100 50 -image myimage .c create image 100 150 -image myimage @@ -58,185 +82,289 @@ test image-1.8 {Tk_ImageCmd procedure, "create" option} testImageType { set x {} image create test myimage -variable x update - set x -} {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} -test image-1.9 {Tk_ImageCmd procedure, "create" option} testImageType { + return $x +} -cleanup { .c delete all - eval image delete [image names] - list [catch {image create test -badName foo} msg] $msg [image names] -} {1 {bad option name "-badName"} {}} -test image-1.10 {Tk_ImageCmd procedure, "create" option with same name as main window} { + imageCleanup +} -result {{myimage get} {myimage get} {myimage display 0 0 30 15 30 30} {myimage display 0 0 30 15 30 130}} +test image-1.9 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -body { + image create test -badName foo +} -returnCodes error -result {bad option name "-badName"} +test image-1.10 {Tk_ImageCmd procedure, "create" option} -constraints { + testImageType +} -body { + catch {image create test -badName foo} + imageNames +} -result {} +test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window} -body { set code [loadTkCommand] append code { - update - puts [list [catch {image create photo .} msg] $msg] - exit + update + puts [list [catch {image create photo .} msg] $msg] + exit } set script [makeFile $code script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] + exec [interpreter] <$script +} -cleanup { removeFile script - set x -} {0 {1 {images may not be named the same as the main window}}} -test image-1.11 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} { +} -result {1 {images may not be named the same as the main window}} +test image-1.12 {Tk_ImageCmd procedure, "create" option with same name as main window after renaming} -body { set code [loadTkCommand] append code { - update - puts [list [catch {rename . foo;image create photo foo} msg] $msg] - exit + update + puts [list [catch {rename . foo;image create photo foo} msg] $msg] + exit } set script [makeFile $code script] - set x [list [catch {exec [interpreter] <$script} msg] $msg] + exec [interpreter] <$script +} -cleanup { removeFile script - set x -} {0 {1 {images may not be named the same as the main window}}} -test image-1.12 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { +} -result {1 {images may not be named the same as the main window}} +test image-1.13 {Tk_ImageCmd, "create" option: do not generated command name in use} -setup { + .c delete all + imageCleanup +} -body { set i [image create bitmap] regexp {^image(\d+)$} $i -> serial incr serial proc image$serial {} {return works} set j [image create bitmap] -} -body { + image$serial } -cleanup { rename image$serial {} image delete $i $j } -result works -test image-2.1 {Tk_ImageCmd procedure, "delete" option} { - list [catch {image delete} msg] $msg -} {0 {}} -test image-2.2 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] +test image-2.1 {Tk_ImageCmd procedure, "delete" option} -body { + image delete +} -result {} +test image-2.2 {Tk_ImageCmd procedure, "delete" option} -constraints { + testImageType +} -setup { + imageCleanup + set result {} +} -body { image create test myimage image create test img2 - set result {} - lappend result [lsort [image names]] + lappend result [lsort [imageNames]] image d myimage img2 - lappend result [image names] -} {{img2 myimage} {}} -test image-2.3 {Tk_ImageCmd procedure, "delete" option} testImageType { - .c delete all - eval image delete [image names] + lappend result [imageNames] +} -cleanup { + imageCleanup +} -result {{img2 myimage} {}} +test image-2.3 {Tk_ImageCmd procedure, "delete" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { image create test myimage image create test img2 - list [catch {image delete myimage gorp img2} msg] $msg [image names] -} {1 {image "gorp" doesn't exist} img2} - -test image-3.1 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height} msg] $msg -} {1 {wrong # args: should be "image height name"}} -test image-3.2 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height a b} msg] $msg -} {1 {wrong # args: should be "image height name"}} -test image-3.3 {Tk_ImageCmd procedure, "height" option} { - list [catch {image height foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-3.4 {Tk_ImageCmd procedure, "height" option} testImageType { + image delete myimage gorp img2 +} -cleanup { + imageCleanup +} -returnCodes error -result {image "gorp" doesn't exist} +test image-2.4 {Tk_ImageCmd procedure, "delete" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { + image create test myimage + image create test img2 + catch {image delete myimage gorp img2} + imageNames +} -cleanup { + imageCleanup +} -result {img2} + + +test image-3.1 {Tk_ImageCmd procedure, "height" option} -body { + image height +} -returnCodes error -result {wrong # args: should be "image height name"} +test image-3.2 {Tk_ImageCmd procedure, "height" option} -body { + image height a b +} -returnCodes error -result {wrong # args: should be "image height name"} +test image-3.3 {Tk_ImageCmd procedure, "height" option} -body { + image height foo +} -returnCodes error -result {image "foo" doesn't exist} +test image-3.4 {Tk_ImageCmd procedure, "height" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { image create test myimage set x [image h myimage] myimage changed 0 0 0 0 60 50 list $x [image height myimage] -} {15 50} +} -cleanup { + imageCleanup +} -result {15 50} -test image-4.1 {Tk_ImageCmd procedure, "names" option} { - list [catch {image names x} msg] $msg -} {1 {wrong # args: should be "image names"}} -test image-4.2 {Tk_ImageCmd procedure, "names" option} testImageType { - .c delete all - eval image delete [image names] - image create test myimage - image create test img2 - image create test 24613 - lsort [image names] -} {24613 img2 myimage} -test image-4.3 {Tk_ImageCmd procedure, "names" option} { - .c delete all - eval image delete [image names] - lsort [image names] -} {} - -test image-5.1 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type} msg] $msg -} {1 {wrong # args: should be "image type name"}} -test image-5.2 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type a b} msg] $msg -} {1 {wrong # args: should be "image type name"}} -test image-5.3 {Tk_ImageCmd procedure, "type" option} { - list [catch {image type foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-5.4 {Tk_ImageCmd procedure, "type" option} testImageType { + +test image-4.1 {Tk_ImageCmd procedure, "names" option} -body { + image names x +} -returnCodes error -result {wrong # args: should be "image names"} +test image-4.2 {Tk_ImageCmd procedure, "names" option} -constraints { + testImageType +} -setup { + catch {interp delete testinterp} +} -body { + interp create testinterp + load {} Tk testinterp + interp eval testinterp { + image delete {*}[image names] + image create test myimage + image create test img2 + image create test 24613 + lsort [image names] + } +} -cleanup { + interp delete testinterp +} -result {24613 img2 myimage} +test image-4.3 {Tk_ImageCmd procedure, "names" option} -setup { + catch {interp delete testinterp} +} -body { + interp create testinterp + load {} Tk testinterp + interp eval testinterp { + image delete {*}[image names] + eval image delete [image names] [image names] + lsort [image names] + } +} -cleanup { + interp delete testinterp +} -result {} + + +test image-5.1 {Tk_ImageCmd procedure, "type" option} -body { + image type +} -returnCodes error -result {wrong # args: should be "image type name"} +test image-5.2 {Tk_ImageCmd procedure, "type" option} -body { + image type a b +} -returnCodes error -result {wrong # args: should be "image type name"} +test image-5.3 {Tk_ImageCmd procedure, "type" option} -body { + image type foo +} -returnCodes error -result {image "foo" doesn't exist} + +test image-5.4 {Tk_ImageCmd procedure, "type" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { image create test myimage image type myimage -} {test} -test image-5.5 {Tk_ImageCmd procedure, "type" option} testImageType { +} -cleanup { + imageCleanup +} -result {test} +test image-5.5 {Tk_ImageCmd procedure, "type" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { image create test myimage .c create image 50 50 -image myimage image delete myimage - list [catch {image type myimage} msg] $msg -} {1 {image "myimage" doesn't exist}} -test image-5.6 {Tk_ImageCmd procedure, "type" option} testOldImageType { + image type myimage +} -cleanup { + imageCleanup +} -returnCodes error -result {image "myimage" doesn't exist} +test image-5.6 {Tk_ImageCmd procedure, "type" option} -constraints { + testOldImageType +} -setup { + imageCleanup +} -body { image create oldtest myimage image type myimage -} {oldtest} -test image-5.7 {Tk_ImageCmd procedure, "type" option} testOldImageType { +} -cleanup { + imageCleanup +} -result {oldtest} +test image-5.7 {Tk_ImageCmd procedure, "type" option} -constraints { + testOldImageType +} -setup { + .c delete all + imageCleanup +} -body { image create oldtest myimage .c create image 50 50 -image myimage image delete myimage - list [catch {image type myimage} msg] $msg -} {1 {image "myimage" doesn't exist}} + image type myimage +} -cleanup { + .c delete all + imageCleanup +} -returnCodes error -result {image "myimage" doesn't exist} -test image-6.1 {Tk_ImageCmd procedure, "types" option} { - list [catch {image types x} msg] $msg -} {1 {wrong # args: should be "image types"}} -test image-6.2 {Tk_ImageCmd procedure, "types" option} testImageType { + +test image-6.1 {Tk_ImageCmd procedure, "types" option} -body { + image types x +} -returnCodes error -result {wrong # args: should be "image types"} +test image-6.2 {Tk_ImageCmd procedure, "types" option} -constraints { + testImageType +} -body { lsort [image types] -} {bitmap oldtest photo test} - -test image-7.1 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width} msg] $msg -} {1 {wrong # args: should be "image width name"}} -test image-7.2 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width a b} msg] $msg -} {1 {wrong # args: should be "image width name"}} -test image-7.3 {Tk_ImageCmd procedure, "width" option} { - list [catch {image width foo} msg] $msg -} {1 {image "foo" doesn't exist}} -test image-7.4 {Tk_ImageCmd procedure, "width" option} testImageType { +} -result {bitmap oldtest photo test} + + +test image-7.1 {Tk_ImageCmd procedure, "width" option} -body { + image width +} -returnCodes error -result {wrong # args: should be "image width name"} +test image-7.2 {Tk_ImageCmd procedure, "width" option} -body { + image width a b +} -returnCodes error -result {wrong # args: should be "image width name"} +test image-7.3 {Tk_ImageCmd procedure, "width" option} -body { + image width foo +} -returnCodes error -result {image "foo" doesn't exist} +test image-7.4 {Tk_ImageCmd procedure, "width" option} -constraints { + testImageType +} -setup { + imageCleanup +} -body { image create test myimage set x [image w myimage] myimage changed 0 0 0 0 60 50 list $x [image width myimage] -} {30 60} +} -cleanup { + imageCleanup +} -result {30 60} -test image-8.1 {Tk_ImageCmd procedure, "inuse" option} testImageType { - catch {image delete myimage2} - image create test myimage2 + +test image-8.1 {Tk_ImageCmd procedure, "inuse" option} -constraints { + testImageType +} -setup { + imageCleanup set res {} + destroy .b +} -body { + image create test myimage2 lappend res [image inuse myimage2] - catch {destroy .b} button .b -image myimage2 lappend res [image inuse myimage2] +} -cleanup { + imageCleanup catch {destroy .b} - image delete myimage2 - set res -} [list 0 1] +} -result [list 0 1] -test image-9.1 {Tk_ImageChanged procedure} testImageType { +test image-9.1 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + imageCleanup +} -body { image create test foo -variable x .c create image 50 50 -image foo update set x {} foo changed 5 6 7 8 30 15 update - set x -} {{foo display 5 6 7 8 30 30}} -test image-9.2 {Tk_ImageChanged procedure} testImageType { + return $x +} -cleanup { + .c delete all + imageCleanup +} -result {{foo display 5 6 7 8 30 30}} +test image-9.2 {Tk_ImageChanged procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + imageCleanup +} -body { image create test foo -variable x .c create image 50 50 -image foo .c create image 90 100 -image foo @@ -244,25 +372,38 @@ test image-9.2 {Tk_ImageChanged procedure} testImageType { set x {} foo changed 5 6 7 8 30 15 update - set x -} {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} + return $x +} -cleanup { + .c delete all + imageCleanup +} -result {{foo display 5 6 25 9 30 30} {foo display 0 0 12 14 65 74}} + -test image-10.1 {Tk_GetImage procedure} { - list [catch {.c create image 100 10 -image bad_name} msg] $msg -} {1 {image "bad_name" doesn't exist}} -test image-10.2 {Tk_GetImage procedure} testImageType { +test image-10.1 {Tk_GetImage procedure} -setup { + imageCleanup +} -body { + .c create image 100 10 -image bad_name +} -cleanup { + imageCleanup +} -returnCodes error -result {image "bad_name" doesn't exist} +test image-10.2 {Tk_GetImage procedure} -constraints testImageType -setup { + destroy .l + imageCleanup +} -body { image create test mytest - catch {destroy .l} label .l -image mytest image delete mytest - set result [list [catch {label .l2 -image mytest} msg] $msg] + label .l2 -image mytest +} -cleanup { destroy .l - set result -} {1 {image "mytest" doesn't exist}} + imageCleanup +} -returnCodes error -result {image "mytest" doesn't exist} + -test image-11.1 {Tk_FreeImage procedure} testImageType { +test image-11.1 {Tk_FreeImage procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + imageCleanup +} -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 @@ -272,168 +413,214 @@ test image-11.1 {Tk_FreeImage procedure} testImageType { .c delete i1 pack .c update - list [image names] $x -} {foo {{foo free} {foo display 0 0 30 15 103 121}}} -test image-11.2 {Tk_FreeImage procedure} testImageType { + list [imageNames] $x +} -cleanup { .c delete all - eval image delete [image names] + imageCleanup +} -result {foo {{foo free} {foo display 0 0 30 15 103 121}}} +test image-11.2 {Tk_FreeImage procedure} -constraints testImageType -setup { + .c delete all + imageCleanup +} -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 - set names [image names] + set names [imageNames] image delete foo update - set names2 [image names] + set names2 [imageNames] set x {} .c delete i1 pack forget .c pack .c update - list $names $names2 [image names] $x -} {foo {} {} {}} + list $names $names2 [imageNames] $x +} -cleanup { + .c delete all + imageCleanup +} -result {foo {} {} {}} -# Non-portable, apparently due to differences in rounding: -test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] +# Non-portable, apparently due to differences in rounding: +test image-12.1 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + imageCleanup +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 30 40 55 65 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 0 0 5 5 50 50}} -test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + imageCleanup +} -result {{foo display 0 0 5 5 50 50}} +test image-12.2 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + imageCleanup +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 60 40 100 65 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 10 0 20 5 30 50}} -test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + imageCleanup +} -result {{foo display 10 0 20 5 30 50}} +test image-12.3 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + imageCleanup +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 60 70 100 200 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 10 10 20 5 30 30}} -test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + imageCleanup +} -result {{foo display 10 10 20 5 30 30}} +test image-12.4 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + imageCleanup +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 30 70 55 200 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 0 10 5 5 50 30}} -test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + imageCleanup +} -result {{foo display 0 10 5 5 50 30}} +test image-12.5 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + imageCleanup +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 10 20 120 130 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 0 0 30 15 70 70}} -test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} \ - {testImageType nonPortable} { - .c delete all - eval image delete [image names] + return $x +} -cleanup { + imageCleanup +} -result {{foo display 0 0 30 15 70 70}} +test image-12.6 {Tk_RedrawImage procedure, redisplay area clipping} -constraints { + testImageType nonPortable +} -setup { + imageCleanup +} -body { image create test foo -variable x .c create image 50 60 -image foo -tags i1 -anchor nw update .c create rectangle 55 65 75 70 -width 0 -fill black -outline {} set x {} update - set x -} {{foo display 5 5 20 5 30 30}} + return $x +} -cleanup { + imageCleanup +} -result {{foo display 5 5 20 5 30 30}} -test image-13.1 {Tk_SizeOfImage procedure} testImageType { - eval image delete [image names] + +test image-13.1 {Tk_SizeOfImage procedure} -constraints testImageType -setup { + imageCleanup +} -body { image create test foo -variable x set result [list [image width foo] [image height foo]] foo changed 0 0 0 0 85 60 lappend result [image width foo] [image height foo] -} {30 15 85 60} +} -cleanup { + imageCleanup +} -result {30 15 85 60} -test image-13.2 {DeleteImage procedure} testImageType { +test image-13.2 {DeleteImage procedure} -constraints testImageType -setup { .c delete all - eval image delete [image names] + imageCleanup +} -body { image create test foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 set x {} image delete foo - lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | -} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} + lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | +} -cleanup { + imageCleanup +} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} -test image-13.3 {Tk_SizeOfImage procedure} testOldImageType { - eval image delete [image names] +test image-13.3 {Tk_SizeOfImage procedure} -constraints testOldImageType -setup { + imageCleanup +} -body { image create oldtest foo -variable x set result [list [image width foo] [image height foo]] foo changed 0 0 0 0 85 60 lappend result [image width foo] [image height foo] -} {30 15 85 60} +} -cleanup { + imageCleanup +} -result {30 15 85 60} -test image-13.4 {DeleteImage procedure} testOldImageType { +test image-13.4 {DeleteImage procedure} -constraints testOldImageType -setup { .c delete all - eval image delete [image names] + imageCleanup +} -body { image create oldtest foo -variable x .c create image 50 50 -image foo -tags i1 .c create image 90 100 -image foo -tags i2 set x {} image delete foo - lappend x | [image names] | [catch {image delete foo} msg] | $msg | [image names] | -} {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} - - -catch {image delete hidden} -set l [image names] -set h [interp hidden] + lappend x | [imageNames] | [catch {image delete foo} msg] | $msg | [imageNames] | +} -cleanup { + .c delete all + imageCleanup +} -result {{foo free} {foo free} {foo delete} | {} | 1 | {image "foo" doesn't exist} | {} |} -test image-14.1 {image command vs hidden commands} { +test image-14.1 {image command vs hidden commands} -body { catch {image delete hidden} + set l [imageNames] + set h [interp hidden] image create photo hidden interp hide {} hidden image delete hidden - list [image names] [interp hidden] -} [list $l $h] + set res1 [list [imageNames] [interp hidden]] + set res2 [list $l $h] + expr {$res1 eq $res2} +} -result 1 -eval image delete [image names] -test image-15.1 {deleting image does not make widgets forget about it} { +test image-15.1 {deleting image does not make widgets forget about it} -setup { .c delete all + imageCleanup +} -body { image create photo foo -width 10 -height 10 .c create image 10 10 -image foo -tags i1 -anchor nw update set x [.c bbox i1] - lappend x [image names] + lappend x [imageNames] image delete foo - lappend x [image names] + lappend x [imageNames] image create photo foo -width 20 -height 20 - lappend x [.c bbox i1] [image names] -} {10 10 20 20 foo {} {10 10 30 30} foo} + lappend x [.c bbox i1] [imageNames] +} -cleanup { + .c delete all + imageCleanup +} -result {10 10 20 20 foo {} {10 10 30 30} foo} destroy .c -eval image delete [image names] +imageFinish # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/imgBmap.test b/tests/imgBmap.test index edbb8c3..5ffd7c4 100644 --- a/tests/imgBmap.test +++ b/tests/imgBmap.test @@ -7,9 +7,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit set data1 {#define foo_width 16 #define foo_height 16 @@ -31,123 +33,153 @@ set data2 { makeFile $data1 foo.bm makeFile $data2 foo2.bm -eval image delete [image names] -canvas .c -pack .c -update -image create bitmap i1 -.c create image 200 100 -image i1 +imageCleanup +#canvas .c +#pack .c +#update +#image create bitmap i1 +#.c create image 200 100 -image i1 update proc bgerror msg { global errMsg set errMsg $msg } -test imageBmap-1.1 {options for bitmap images} { + +test imageBmap-1.1 {options for bitmap images} -body { image create bitmap i1 -background #123456 lindex [i1 configure -background] 4 -} {#123456} -test imageBmap-1.2 {options for bitmap images} { +} -cleanup { + image delete i1 +} -result {#123456} +test imageBmap-1.2 {options for bitmap images} -setup { + destroy .c + pack [canvas .c] + update +} -body { set errMsg {} image create bitmap i1 -background lousy + .c create image 200 100 -image i1 update list $errMsg $errorInfo -} {{unknown color name "lousy"} {unknown color name "lousy" +} -cleanup { + image delete i1 + destroy .c +} -result {{unknown color name "lousy"} {unknown color name "lousy" (while configuring image "i1")}} -test imageBmap-1.3 {options for bitmap images} { +test imageBmap-1.3 {options for bitmap images} -body { image create bitmap i1 -data $data1 lindex [i1 configure -data] 4 -} $data1 -test imageBmap-1.4 {options for bitmap images} { - list [catch {image create bitmap i1 -data bogus} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-1.5 {options for bitmap images} { +} -result $data1 +test imageBmap-1.4 {options for bitmap images} -body { + image create bitmap i1 -data bogus +} -returnCodes error -result {format error in bitmap data} +test imageBmap-1.5 {options for bitmap images} -body { image create bitmap i1 -file foo.bm lindex [i1 configure -file] 4 -} foo.bm -test imageBmap-1.6 {options for bitmap images} { +} -result foo.bm +test imageBmap-1.6 {options for bitmap images} -body { list [catch {image create bitmap i1 -file bogus} msg] [string tolower $msg] -} {1 {couldn't read bitmap file "bogus": no such file or directory}} -test imageBmap-1.7 {options for bitmap images} { +} -result {1 {couldn't read bitmap file "bogus": no such file or directory}} +test imageBmap-1.7 {options for bitmap images} -body { image create bitmap i1 -foreground #00ff00 lindex [i1 configure -foreground] 4 -} {#00ff00} -test imageBmap-1.8 {options for bitmap images} { +} -cleanup { + image delete i1 +} -result {#00ff00} +test imageBmap-1.8 {options for bitmap images} -setup { + destroy .c + pack [canvas .c] + update +} -body { set errMsg {} image create bitmap i1 -foreground bad_color + .c create image 200 100 -image i1 update list $errMsg $errorInfo -} {{unknown color name "bad_color"} {unknown color name "bad_color" +} -cleanup { + destroy .c + image delete i1 +} -result {{unknown color name "bad_color"} {unknown color name "bad_color" (while configuring image "i1")}} -test imageBmap-1.9 {options for bitmap images} { +test imageBmap-1.9 {options for bitmap images} -body { image create bitmap i1 -data $data1 -maskdata $data2 lindex [i1 configure -maskdata] 4 -} $data2 -test imageBmap-1.10 {options for bitmap images} { - list [catch {image create bitmap i1 -data $data1 -maskdata bogus} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-1.11 {options for bitmap images} { +} -result $data2 +test imageBmap-1.10 {options for bitmap images} -body { + image create bitmap i1 -data $data1 -maskdata bogus +} -returnCodes error -result {format error in bitmap data} +test imageBmap-1.11 {options for bitmap images} -body { image create bitmap i1 -file foo.bm -maskfile foo2.bm lindex [i1 configure -maskfile] 4 -} foo2.bm -test imageBmap-1.12 {options for bitmap images} { +} -result foo2.bm +test imageBmap-1.12 {options for bitmap images} -body { list [catch {image create bitmap i1 -data $data1 -maskfile bogus} msg] \ [string tolower $msg] -} {1 {couldn't read bitmap file "bogus": no such file or directory}} +} -result {1 {couldn't read bitmap file "bogus": no such file or directory}} rename bgerror {} -test imageBmap-2.1 {ImgBmapCreate procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -gorp dum} msg] $msg [image names] -} {1 {unknown option "-gorp"} {}} -test imageBmap-2.2 {ImgBmapCreate procedure} { - eval image delete [image names] - .c delete all + +test imageBmap-2.1 {ImgBmapCreate procedure} -setup { + imageCleanup +} -body { + list [catch {image create bitmap -gorp dum} msg] $msg [imageNames] +} -result {1 {unknown option "-gorp"} {}} +test imageBmap-2.2 {ImgBmapCreate procedure} -setup { + imageCleanup +} -body { image create bitmap image1 - list [info commands image1] [image names] \ + list [info commands image1] [imageNames] \ [image width image1] [image height image1] \ [lindex [image1 configure -foreground] 4] \ [lindex [image1 configure -background] 4] -} {image1 image1 0 0 #000000 {}} +} -cleanup { + image delete image1 +} -result {image1 image1 0 0 #000000 {}} -test imageBmap-3.1 {ImgBmapConfigureMaster procedure, memory de-allocation} { + +test imageBmap-3.1 {ImgBmapConfigureMaster procedure, memory de-allocation} -body { image create bitmap i1 -data $data1 i1 configure -data $data1 -} {} -test imageBmap-3.2 {ImgBmapConfigureMaster procedure} { +} -cleanup { + image delete i1 +} -result {} +test imageBmap-3.2 {ImgBmapConfigureMaster procedure} -body { image create bitmap i1 -data $data1 list [catch {i1 configure -data bogus} msg] $msg [image width i1] \ [image height i1] -} {1 {format error in bitmap data} 16 16} -test imageBmap-3.3 {ImgBmapConfigureMaster procedure, memory de-allocation} { +} -result {1 {format error in bitmap data} 16 16} +test imageBmap-3.3 {ImgBmapConfigureMaster procedure, memory de-allocation} -body { image create bitmap i1 -data $data1 -maskdata $data2 i1 configure -maskdata $data2 -} {} -test imageBmap-3.4 {ImgBmapConfigureMaster procedure} { +} -cleanup { + image delete i1 +} -result {} +test imageBmap-3.4 {ImgBmapConfigureMaster procedure} -body { image create bitmap i1 - list [catch {i1 configure -maskdata $data2} msg] $msg -} {1 {can't have mask without bitmap}} -test imageBmap-3.5 {ImgBmapConfigureMaster procedure} { - list [catch {image create bitmap i1 -data $data1 -maskdata { + i1 configure -maskdata $data2 +} -returnCodes error -result {can't have mask without bitmap} +test imageBmap-3.5 {ImgBmapConfigureMaster procedure} -body { + image create bitmap i1 -data $data1 -maskdata { #define foo_width 8 #define foo_height 16 static char foo_bits[] = { 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81}; } - } msg] $msg -} {1 {bitmap and mask have different sizes}} -test imageBmap-3.6 {ImgBmapConfigureMaster procedure} { - list [catch {image create bitmap i1 -data $data1 -maskdata { +} -returnCodes error -result {bitmap and mask have different sizes} +test imageBmap-3.6 {ImgBmapConfigureMaster procedure} -body { + image create bitmap i1 -data $data1 -maskdata { #define foo_width 16 #define foo_height 8 static char foo_bits[] = { 0xff, 0xff, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0xff, 0xff, 0xff, 0xff, 0x81, 0x81}; } - } msg] $msg -} {1 {bitmap and mask have different sizes}} -test imageBmap-3.7 {ImgBmapConfigureMaster procedure} { +} -returnCodes error -result {bitmap and mask have different sizes} +test imageBmap-3.7 {ImgBmapConfigureMaster procedure} -setup { + destroy .c + pack [canvas .c] +} -body { image create bitmap i1 -data $data1 .c create image 100 100 -image i1 -tags i1.1 -anchor nw .c create image 200 100 -image i1 -tags i1.2 -anchor nw @@ -163,63 +195,58 @@ test imageBmap-3.7 {ImgBmapConfigureMaster procedure} { } update list [image width i1] [image height i1] [.c bbox i1.1] [.c bbox i1.2] -} {15 14 {100 100 115 114} {200 100 215 114}} +} -cleanup { + image delete i1 + destroy .c +} -result {15 14 {100 100 115 114} {200 100 215 114}} -test imageBmap-4.1 {ImgBmapConfigureInstance procedure: check error handling} { + +test imageBmap-4.1 {ImgBmapConfigureInstance procedure: check error handling} -setup { + destroy .c + pack [canvas .c] + update +} -body { proc bgerror args {} - .c delete all image create bitmap i1 -file foo.bm .c create image 100 100 -image i1 update i1 configure -foreground bogus update -} {} +} -cleanup { + image delete i1 + destroy .c +} -result {} + -test imageBmap-5.1 {GetBitmapData procedure} { +test imageBmap-5.1 {GetBitmapData procedure} -body { list [catch {image create bitmap -file ~bad_user/a/b} msg] \ [string tolower $msg] -} {1 {user "bad_user" doesn't exist}} -test imageBmap-5.2 {GetBitmapData procedure} { +} -result {1 {user "bad_user" doesn't exist}} +test imageBmap-5.2 {GetBitmapData procedure} -body { list [catch {image create bitmap -file bad_name} msg] [string tolower $msg] -} {1 {couldn't read bitmap file "bad_name": no such file or directory}} -test imageBmap-5.3 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data { }} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.4 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data {#define foo2_width}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.5 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data {#define foo2_width gorp}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.6 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data {#define foo2_width 1.4}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.7 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data {#define foo2_height}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.8 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data {#define foo2_height gorp}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.9 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap -data {#define foo2_height 1.4}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.10 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all +} -result {1 {couldn't read bitmap file "bad_name": no such file or directory}} +test imageBmap-5.3 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data { } +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.4 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data "#define foo2_width" +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.5 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data "#define foo2_width gorp" +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.6 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data "#define foo2_width 1.4" +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.7 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data "#define foo2_height" +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.8 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data "#define foo2_height gorp" +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.9 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap -data "#define foo2_height 1.4" +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.10 {GetBitmapData procedure} -setup {imageCleanup} -body { image create bitmap i1 -data { #define foo2_height 14 #define foo2_width 15 xx _widtg 18 xwidth 18 _heighz 18 xheight 18 @@ -230,10 +257,10 @@ test imageBmap-5.10 {GetBitmapData procedure} { 0xff, 0xff}; } list [image width i1] [image height i1] -} {15 14} -test imageBmap-5.11 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all +} -cleanup { + image delete i1 +} -result {15 14} +test imageBmap-5.11 {GetBitmapData procedure} -setup {imageCleanup} -body { image create bitmap i1 -data { _height 14 _width 15 char { @@ -243,11 +270,11 @@ test imageBmap-5.11 {GetBitmapData procedure} { 0xff, 0xff} } list [image width i1] [image height i1] -} {15 14} -test imageBmap-5.12 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data { +} -cleanup { + image delete i1 +} -result {15 14} +test imageBmap-5.12 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data { #define foo2_height 14 #define foo2_width 15 static short foo2_bits[] = { @@ -255,12 +282,10 @@ test imageBmap-5.12 {GetBitmapData procedure} { 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0xff}; - }} msg] $msg -} {1 {format error in bitmap data; looks like it's an obsolete X10 bitmap file}} -test imageBmap-5.13 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data { + } +} -returnCodes error -result {format error in bitmap data; looks like it's an obsolete X10 bitmap file} +test imageBmap-5.13 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data { #define foo2_height 16 #define foo2_width 16 static char foo2_bits[] = @@ -268,28 +293,22 @@ test imageBmap-5.13 {GetBitmapData procedure} { 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0xff; - }} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.14 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data { + } +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.14 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data { #define foo2_width 16 static char foo2_bits[] = { - 0xff, 0xff, 0xff, }}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.15 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data { + 0xff, 0xff, 0xff, }} +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.15 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data { #define foo2_height 16 static char foo2_bits[] = { - 0xff, 0xff, 0xff, }}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.16 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data { + 0xff, 0xff, 0xff, }} +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.16 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data { #define foo2_height 16 #define foo2_width 16 static char foo2_bits[] = { @@ -297,12 +316,10 @@ test imageBmap-5.16 {GetBitmapData procedure} { 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, foo}; - }} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-5.17 {GetBitmapData procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data " + } +} -returnCodes error -result {format error in bitmap data} +test imageBmap-5.17 {GetBitmapData procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data " #define foo2_height 16 #define foo2_width 16 static char foo2_bits[] = \{ @@ -310,67 +327,66 @@ test imageBmap-5.17 {GetBitmapData procedure} { 0xff, 0x81, 0xff, 0x81, 0xff, 0xff, 0xff, 0xff, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff, 0x81, 0xff - "} msg] $msg -} {1 {format error in bitmap data}} + " +} -returnCodes error -result {format error in bitmap data} -test imageBmap-6.1 {NextBitmapWord procedure} { - eval image delete [image names] - .c delete all - list [catch {image create bitmap i1 -data {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890}} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-6.2 {NextBitmapWord procedure} { - eval image delete [image names] - .c delete all + +test imageBmap-6.1 {NextBitmapWord procedure} -setup {imageCleanup} -body { + image create bitmap i1 -data {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} +} -returnCodes error -result {format error in bitmap data} +test imageBmap-6.2 {NextBitmapWord procedure} -setup {imageCleanup} -body { makeFile {1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890} foo3.bm - list [catch {image create bitmap i1 -file foo3.bm} msg] $msg -} {1 {format error in bitmap data}} -test imageBmap-6.3 {NextBitmapWord procedure} { - eval image delete [image names] - .c delete all + image create bitmap i1 -file foo3.bm +} -returnCodes error -result {format error in bitmap data} +test imageBmap-6.3 {NextBitmapWord procedure} -setup {imageCleanup} -body { makeFile { } foo3.bm - list [catch {image create bitmap i1 -file foo3.bm} msg] $msg -} {1 {format error in bitmap data}} + image create bitmap i1 -file foo3.bm +} -returnCodes error -result {format error in bitmap data} removeFile foo3.bm -eval image delete [image names] -.c delete all + +imageCleanup +# Image used in 7.* tests image create bitmap i1 -test imageBmap-7.1 {ImgBmapCmd procedure} { - list [catch {i1} msg] $msg -} {1 {wrong # args: should be "i1 option ?arg arg ...?"}} -test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} { - list [catch {i1 cget} msg] $msg -} {1 {wrong # args: should be "i1 cget option"}} -test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} { - list [catch {i1 cget a b} msg] $msg -} {1 {wrong # args: should be "i1 cget option"}} -test imageBmap-7.4 {ImgBmapCmd procedure, "cget" option} { +test imageBmap-7.1 {ImgBmapCmd procedure} -body { + i1 +} -returnCodes error -result {wrong # args: should be "i1 option ?arg ...?"} +test imageBmap-7.2 {ImgBmapCmd procedure, "cget" option} -body { + i1 cget +} -returnCodes error -result {wrong # args: should be "i1 cget option"} +test imageBmap-7.3 {ImgBmapCmd procedure, "cget" option} -body { + i1 cget a b +} -returnCodes error -result {wrong # args: should be "i1 cget option"} +test imageBmap-7.4 {ImgBmapCmd procedure, "cget" option} -body { i1 co -foreground #123456 i1 cget -foreground -} {#123456} -test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} { - list [catch {i1 cget -stupid} msg] $msg -} {1 {unknown option "-stupid"}} -test imageBmap-7.6 {ImgBmapCmd procedure} { +} -result {#123456} +test imageBmap-7.5 {ImgBmapCmd procedure, "cget" option} -body { + i1 cget -stupid +} -returnCodes error -result {unknown option "-stupid"} +test imageBmap-7.6 {ImgBmapCmd procedure} -body { llength [i1 configure] -} {6} -test imageBmap-7.7 {ImgBmapCmd procedure} { +} -result {6} +test imageBmap-7.7 {ImgBmapCmd procedure} -body { i1 co -foreground #001122 i1 configure -foreground -} {-foreground {} {} #000000 #001122} -test imageBmap-7.8 {ImgBmapCmd procedure} { - list [catch {i1 configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test imageBmap-7.9 {ImgBmapCmd procedure} { - list [catch {i1 configure -foreground #221100 -background} msg] $msg -} {1 {value for "-background" missing}} -test imageBmap-7.10 {ImgBmapCmd procedure} { - list [catch {i1 gorp} msg] $msg -} {1 {bad option "gorp": must be cget or configure}} +} -result {-foreground {} {} #000000 #001122} +test imageBmap-7.8 {ImgBmapCmd procedure} -body { + i1 configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test imageBmap-7.9 {ImgBmapCmd procedure} -body { + i1 configure -foreground #221100 -background +} -returnCodes error -result {value for "-background" missing} +test imageBmap-7.10 {ImgBmapCmd procedure} -body { + i1 gorp +} -returnCodes error -result {bad option "gorp": must be cget or configure} -test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} { - eval image delete [image names] - .c delete all + +test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} -setup { + destroy .c + pack [canvas .c] + update +} -body { image create bitmap i1 -data $data1 .c create image 50 100 -image i1 -tags i1.1 .c create image 150 100 -image i1 -tags i1.2 @@ -386,43 +402,68 @@ test imageBmap-8.1 {ImgBmapGet/Free procedures, shared instances} { i1 configure -background black update image delete i1 -} {} +} -cleanup { + destroy .c +} -result {} + -test imageBmap-9.1 {ImgBmapDisplay procedure, nothing to display} { +test imageBmap-9.1 {ImgBmapDisplay procedure, nothing to display} -setup { + destroy .c + pack [canvas .c] + update +} -body { proc bgerror args {} - eval image delete [image names] - .c delete all + imageCleanup image create bitmap i1 -data $data1 .c create image 50 100 -image i1 -tags i1.1 i1 configure -data {} update -} {} -test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} { +} -cleanup { + image delete i1 + destroy .c +} -result {} +test imageBmap-9.2 {ImgBmapDisplay procedure, nothing to display} -setup { + destroy .c + pack [canvas .c] + update +} -body { proc bgerror args {} - eval image delete [image names] + imageCleanup .c delete all image create bitmap i1 -data $data1 .c create image 50 100 -image i1 -tags i1.1 i1 configure -foreground bogus update -} {} +} -cleanup { + image delete i1 + destroy .c +} -result {} if {[info exists bgerror]} { rename bgerror {} } -test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} { - eval image delete [image names] - .c delete all + +test imageBmap-10.1 {ImgBmapFree procedure, resource freeing} -setup { + destroy .c + pack [canvas .c] + update +} -body { + imageCleanup image create bitmap i1 -data $data1 -maskdata $data2 -foreground #112233 \ -background #445566 .c create image 100 100 -image i1 update .c delete all image delete i1 -} {} -test imageBmap-10.2 {ImgBmapFree procedures, unlinking} { - eval image delete [image names] - .c delete all +} -cleanup { + destroy .c +} -result {} +test imageBmap-10.2 {ImgBmapFree procedures, unlinking} -setup { + destroy .c + pack [canvas .c] + update +} -body { + imageCleanup image create bitmap i1 -data $data1 -maskdata $data2 -foreground #112233 \ -background #445566 .c create image 100 100 -image i1 @@ -438,32 +479,41 @@ test imageBmap-10.2 {ImgBmapFree procedures, unlinking} { destroy .b1 update .c delete all -} {} +} -cleanup { + image delete i1 + deleteWindows +} -result {} -test imageBmap-11.1 {ImgBmapDelete procedure} { + +test imageBmap-11.1 {ImgBmapDelete procedure} -body { image create bitmap i2 -file foo.bm -maskfile foo2.bm image delete i2 info command i2 -} {} -test imageBmap-11.2 {ImgBmapDelete procedure} { +} -result {} +test imageBmap-11.2 {ImgBmapDelete procedure} -body { image create bitmap i2 -file foo.bm -maskfile foo2.bm rename i2 newi2 set x [list [info command i2] [info command new*] [newi2 cget -file]] image delete i2 lappend x [info command new*] -} {{} newi2 foo.bm {}} +} -result {{} newi2 foo.bm {}} + -test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} { +test imageBmap-12.1 {ImgBmapCmdDeletedProc procedure} -body { image create bitmap i2 -file foo.bm -maskfile foo2.bm rename i2 {} - list [lsearch -exact [image names] i2] [catch {i2 foo} msg] $msg -} {-1 1 {invalid command name "i2"}} + list [lsearch -exact [imageNames] i2] [catch {i2 foo} msg] $msg +} -result {-1 1 {invalid command name "i2"}} removeFile foo.bm removeFile foo2.bm -destroy .c -eval image delete [image names] +imageFinish # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/imgPNG.test b/tests/imgPNG.test new file mode 100644 index 0000000..0757411 --- /dev/null +++ b/tests/imgPNG.test @@ -0,0 +1,1116 @@ +# This file is a Tcl script to test out the code in tkImgFmtPNG.c, which reads +# and write PNG-format image files for photo widgets. The files is organized +# in the standard fashion for Tcl tests. +# +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 1998 Willem van Schaik (images only) +# Copyright (c) 2008 Donal K. Fellows +# All rights reserved. + +package require tcltest 2.2 +namespace import ::tcltest::* +eval tcltest::configure $argv +tcltest::loadTestedCommands +imageInit + +namespace eval png { + variable encoded + # Key names are from the names of the source images, which come from + # http://www.schaik.com/pngsuite/pngsuite.html + # The exception is "BadX", which is used to test handling badly compressed + # images. + array set encoded { + basn0g08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAAAAABWESUoAAAABGdBTUEAAYag +MeiWXwAAAEFJREFUeJxjZGAkABQIyLMMBQWMDwgp+PcfP2B5MBwUMMoRkGdkonlcDAYFjI/wyv7/z/ +iH5nExGBQwyuCVZWQEAFDl/nE14thZAAAAAElFTkSuQmCC" + basn2c08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAIAAAD8GO2jAAAABGdBTUEAAYag +MeiWXwAAAEhJREFUeJzt1cEJADAMAkCF7JH9t3ITO0Qr9KH4zuErtA0EO4AKFPgcoO3kfUx4QIECD0 +qHH8KEBxQo8KB0OCOpQIG7cHejwAGCsfleD0DPSwAAAABJRU5ErkJggg==" + basn3p08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAAABGdBTUEAAYag +MeiWXwAAAwBQTFRFIkQA9f/td/93y///EQoAOncAIiL//xH/EQAAIiIA/6xVZv9m/2Zm/wH/IhIA3P +//zP+ZRET/AFVVIgAAy8v/REQAVf9Vy8sAMxoA/+zc7f//5P/L/9zcRP9EZmb/MwAARCIA7e3/ZmYA +/6RE//+q7e0AAMvL/v///f/+//8BM/8zVSoAAQH/iIj/AKqqAQEARAAAiIgA/+TLulsAIv8iZjIA// ++Zqqr/VQAAqqoAy2MAEf8R1P+qdzoA/0RE3GsAZgAAAf8BiEIA7P/ca9wA/9y6ADMzAO0A7XMA//+I +mUoAEf//dwAA/4MB/7q6/nsA//7/AMsA/5mZIv//iAAA//93AIiI/9z/GjMAAACqM///AJkAmQAAAA +ABMmYA/7r/RP///6r/AHcAAP7+qgAASpkA//9m/yIiAACZi/8RVf///wEB/4j/AFUAABER///+//3+ +pP9EZv///2b/ADMA//9V/3d3AACI/0T/ABEAd///AGZm///tAAEA//XtERH///9E/yL//+3tEREAiP +//AAB3k/8iANzcMzP//gD+urr/mf//MzMAY8sAuroArP9V///c//8ze/4A7QDtVVX/qv//3Nz/VVUA +AABm3NwA3ADcg/8Bd3f//v7////L/1VVd3cA/v4AywDLAAD+AQIAAQAAEiIA//8iAEREm/8z/9SqAA +BVmZn/mZkAugC6KlUA/8vLtP9m/5sz//+6qgCqQogAU6oA/6qqAADtALq6//8RAP4AAABEAJmZmQCZ +/8yZugAAiACIANwA/5MiAADc/v/+qlMAdwB3AgEAywAAAAAz/+3/ALoA/zMz7f/t/8SIvP93AKoAZg +BmACIi3AAA/8v/3P/c/4sRAADLAAEBVQBVAIgAAAAiAf//y//L7QAA/4iIRABEW7oA/7x3/5n/AGYA +uv+6AHd3c+0A/gAAMwAzAAC6/3f/AEQAqv+q//7+AAARIgAixP+IAO3tmf+Z/1X/ACIA/7RmEQARCh +EA/xER3P+6uv//iP+IAQAB/zP/uY7TYgAAAbFJREFUeJwNwQcACAQQAMBHqIxIZCs7Mwlla1hlZ+8V +itCw9yoqNGiYDatsyt6jjIadlVkysve+u5jC9xTmV/qyl6bcJR7kAQZzg568xXmuE2lIyUNM5So7OM +AFIhvp+YgGvEtFNnOKeJonSEvwP9NZzhHiOfLzBXPoxKP8yD6iPMXITjP+oTdfsp14lTJMJjGtOMFQ +fiFe4wWK8BP7qUd31hBNqMos2tKYFbRnJdGGjTzPz2yjEA1ZSKymKCM5ylaWcJrZxCZK8jgfU4vc/M +W3xE7K8RUvsZb3Wc/XxCEqk4v/qMQlFvMZcZIafMOnLKM13zGceJNqPMU4KnCQAqQgbrKHpXSgFK/Q +n6REO9YxjWE8Sx2SMJD4jfl8wgzy0YgPuEeUJQcD6EoWWpCaHsQkHuY9RpGON/icK0RyrvE680jG22 +TlHaIbx6jLnySkF+M5QxzmD6pwkTsMoSAdidqsojipuMyHzOQ4sYgfyElpzjKGErQkqvMyC7jFv9xm +BM2JuTzDRDLxN4l4jF1EZjIwmhfZzSOMpT4xiH70IQG/k5En2UKcowudycsG8jCBmtwHgRv+EIeWyO +AAAAAASUVORK5CYII=" + basn6a08 "iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAYAAABzenr0AAAABGdBTUEAAYag +MeiWXwAAAG9JREFUeJzt1jEKgDAMRuEnZGhPofc/VQSPIcTdxUV4HVLoUCj8H00o2YoBMF57fpz/uj +ODHXUFRwPKBqj5DVigB041HiJ9gFyCVOMbsEIPXNwuAHkgiJL/4qABNqB7QAeUPBAE2QAZUDZAfwEb +8ABSIBqcFg+4TAAAAABJRU5ErkJggg==" + + BadX "iVBORw0KGgoAAAANSUhEUgAAAAUAAAAFCAYAAACNbyblAAAABHNCSVQICAgIfAhk +iAAAABN0RVh0U29mdHdhcmUAVGsgOC42YjEuMcrtT1oAAAAcSURBVHicYmBgYPjPgAr+ozP+o0uj68 +BUiWEmAAAA//8SozfjAAAAAElFTkSuQmCC" + MultiIDAT "iVBORw0KGgoAAAANSUhEUgAAAN8AAADUCAYAAAAcPvbvAAAAAXNSR0IArs4 +c6QAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9oEGQQKMpLRO +uoAACAASURBVHja7L158GbZWd/3ec45977bb+2e7p7pnu7ZNzFaRhJCwggjsHqUCgUhiWMSJymwUoV +UlkumJChCHFWBywQQNqhYpFDB2Ljs2EWqiAmphMQVO2ATQMJCQsuMZrp7lt5++7ve9957lid/3Ptbu +tWjGRAgZvo9XW//3vXe973nfM/zPN9nE1VlMf58RwHkgFMgJhDAQg0EAJQ+FuYekgVrCBope5YK6F3 +8Vw9UCdbvOnuBwbH2aDnBKy7rtkcA357PYHC0B0/t2xfjaz7M4hJ8jS+6fPnriqKqxLqG1IDTGINpP +9vtds8bY85j5ABoYBAxX3ly5dbnW4wF+G7PoTcDpvnnYyDEeACYJOlgsozN3xMS71Fx7RQaFIOIbY6 +n5iaMpQX4/gIOt7gEf/7jyzFgQMFIAxODQSShmYXcgICmRr5F9dlwPH3XaFJw3LgMjFcsgiDtcZAG1 +HIEsArIAnwLybcA30urnQcPjSHr5GBNK7kSgpLq6h0XLz63fP36xjKYd4AlYUgYdF/t1MPJlVtJv8V +YgO92vujmFmJQblAUFbWmfXPCZQaH4mezJ5/+wtM8//yLBJ+ePFQ7pQGdtjhTGkl49LiSFuBbgG8h+ +V5OJU0CAQVJJBQxIBqY7uw8+fyFS2xcvkooqycPxBzSqJU3MjcHE5yOAnAxFjbf7bzjyVG06Y07YWy +ghEps3AUaMJpB7U8Ue8MnptvbpKSkyj9BTCewbMm+TccR6WdvBLoutM6F5FtIvpvuHFE7DaAaMRiCJ +hKxnSUlFMW7r1+8ZIrNberhmPHWhsHIu20r16K2yE2HgL55khd+3QX4FuMWNh8KouDUoijG2saWA9B +EPR6f37t8Fb+zTbW1wdVnn0GHu+eJFYaAMa0uc8MxzWKiF2rnYtys/+nNkjA1Dw4kIAaIiCYAmW3vv +Pv6xUuc7uY4Z5ltXENC9W6siKKaNEEAK6ZVZxVEDjRbARC7uP4LybcY6WYNsbXVGuDpwStiFIJ//Wh +r+/Tw6nXcdEI2m7B96Vn8aPc0qX49VIjEBls36pmAaX2A5gZ1dDEW4LvtheCNd1ppqPsATc39afHke +GsLijlrKXDMKDoZUY92INZPQiASUEmo6OEBAJI2t1ucZzEW4Lttgbcv/W54UsEeqIsREWE2Gp7fvbZ +BR4S7Bl1ODnosWaXY2wZfnBcCSiRoA8B9cuWQYJEF8BbgW4yviMZDbbMJsEYRUm+8s/fOzWtX6RmHK +Ut0NiVMp1x5/iJpMn4n0LMI1jQ2nR7x56nqIfAWbr4F+BbjKxuDgrR2HwDvms7GnclwhBXDXXcc5/j +qEsu9LnVRoMF3IL1LSXitSC3CVF5Kx12MBfhu0xGlSa2LBKDCUIH4AxdBSFABdcrpsgTT4jxXL3C3v +8bXZZsMj09YX4k8sLfLGy9sYj//AuxMzqc4oxTLmEQtYKRJMxIR1OjNwZ6LsQDf7TteCge29QZYAxC +Z7e6cH+/tYpLSzRyDwQDnGi9RWZawuwfz+Xln7a1z+F7JSRdjAb7b5aLv+/LM/hTI4ZNiGxUxA/D1u +d3rVx/b29zAxJqBc2TWISJ0Oh2cs1DMoJw/ZpKegxpzk355g/q5AN8CfLe7xDMcDURpH7VPqECMYAH +q8vxo8zrz4R5dha4xTQRM5ED61eMRTKcQ03nRwIGr70gcm+4ffzEW4Luth+4D0HBDzvlB1nozMY5Em +k+fjJMxnbqmbw0dlH7Ww4khxkgxn7K7s0Xc3QEfnlyRDHcTpalH/y4AuADf7Q6+fQA2twaKKg0Zo4C +zQArWj4bfJtMZfWDZGnoiZGJxJsN1crLMYjWRiikUs2+DZDNNByFl+ypnkhuBuBgL8C2YliM1WBJNU +kIEnCSopm8rtjfXw2iPzNd0ETpJMcmRuR5Z3qXb79HJLTIvYTRap6ze5lLCHg1wOfJ34eZbgG8x4KD +Y0X7mwWEiekSIUM7P+71dwniErSqcD1iUvhuQGUeISlGW1MWMajyC8QSinicq0sIs3ax7LsYCfLf3a +GWQ3giK/SBrQUE9Ops+GcZj0nRGR5WOs0iM+DJRFDVBlYQS64o4HsHuLoTwZBNMLU1qX2qSbJsSobr +A4AJ8t7vamb7M/jsqnCwKKa2HWfE2PxqSh0DXGHKxZFlGbvt08iUkyxFrsMYQZwVxcwf2Rm+j9uu0M +Z37Np+9UQ4uxgJ8ty/f8mUA5KbEdu+/rdjdttPtHZxP9GyGMYYsy8ntgKwzQIxDrSOzllTMKba3YDS +yhPBtaGyO1TKn5sDODIsJWIDv9h3xqPK3z3weAaABKOsnp7tDyuEIGyNWDClBQDBqMZIRsCQBay3UN +Wk8g2IOSZ9EBYNytGqEFV0Yfwvw3e7gS4dB00cyGQ4iXxRiMTtfjsdQB3JjceIa+w4BzYjJUadETBB +jRLwnFQVMphDj+abOpxwCW0FIB0TMYizAd9uqnfHmJ/SGx4/NJ9Nz1bRo7Lw2nAzjSEZAHT4mklpqj +YS6JtWeOJ/D1jaU1TlCfOzgcAnQ2E72AnwL8N3Wki+2ki/emMPXOt6T9+dHe0PqYk4mBougqhjnMFm +OkYwUmyBQwRBCgBShDky3d2E6AV+dv6FIRVKU2HoTF2MBvttY8qVbsjDN8N6fn02mVPOySQdKiZRS0 +6nIZs3bVZvHzrb2nGBIzGeTxu6r6/OKNhKzJXgWZQP/Yo1F9bI/T9C1iz/Spw9NQz4FejAlUlOzCp1 +sd/td/UtXcFtzenPBxBx1UKSaEC1djWQmI9VgnWsKdkahmxx6bQR/+Hm489S7TLXbKaypCrcK5Aw0x +4XFrC8k3+180aWtLn1TcmvTaUjfWRVFz1c1GiOookkQNc0tQUqJGCMpNLcYAr6uqeYlVTEnDIcwnvS +I+k5n7H7vzS8vJ78YC/DdbkP21U5p9M0YIwI4BI3x/GS3sfdSiKR0o7qoKRFCQFOCmNCgaB1IPhCqm +nI+Z+vaBmzvQEznu8YtBN0CfIuxPxKHlfxAG3uulU5pXj052xsR5h4TFQJoBFFBkqBBCSkRQ0JTQkL +CREGiIjGhdWCyNyRt7UDpn2wmObah24uxAN9C8jXgsxyEnhgEB6fDdP76+d4YrTwOi2jjXNckEA2xB +u89IQRSSGhImKRYFSQKEiCVNeONbZjOX0/ktNOI1bb+52LGF+C77S/6fkiLE0S0aXEZw7vr4Uj8aIq +UHptAVIkxIckiScAnfB3RoCSfSJUn1REJNFLRe0IZ2L56Hba2BR/f7ZKQyyKTfQG+xbhRBLZ/LKDz6 +vx8e0iazJEqYqOgEVLQJjtBHRrb/D9tX/OJWEeiT3gfqavAbDrl6vMvMrx6HWbz88S238OiR9hfqLG +wxb9GmFONIK5pfpkClszovH63H02xRY2tIyYKISopAmohKkYdYiwiilElJYtGJSbFR8XHyHQ2Z4Qy2 +tpjbVa+m17f4DQhsWFOv+peKYs9eyH5/oKOl3Jmi0jr9G4c5sH7ZhIUqMMTroontp+/Qr03oRMgzit +iHRFxzOcVVeUbuy8m6ipSzCrms5JyXlNUNUVVMatqyhjx3vO5T3+GsL17gpSeIDVBnokvZ1CPfu/91 +24sNX8TYXTkPTd/fuHIX0i+vzDgk1s41ywGS8LmFjRhswxierIajTCzCqkjztOQJ6ntdxkVrRMEJXR +NWwLekKIwrz0xRqqYmMbAqC7Y8yXF5hbj3T2ORX0STX+AGoy1reRtgHZ0U9i/LQC0kHyvOsAd3fmP/ +r35BhFNjQM91XWDsKp6cu/aJmkypxPABcUkwbSFADUJMYKvE7WPhAAhQFlFJvOaYVGyPZuyM59RG2F +rOOTChQtcfPYCeP8kIpRlgVd/ADhjDMaYryitF0BcSL5XpYr50he9bWiibYSnmGVieke5N6YTIasTJ +iQ0RKIoUSAmg8QGp943sZ6+qqnnJfO6Yh49Y18zToFpmdiaTCh9xYULl3jrpHgHa6vLeZ5PklhU9Yb +vt39/X53cB+TR3yiL8JiF5HtVECrtQr1ZnTskXJSjmeaQ3uWHw2y0tUU1miCVR+cBX3qqsmZeeXxM+ +AAxKAlH8IlyXjOrAkVITENi5Gt25gWX93YpgqesPBcuXOC5S5cy6vpdMTbnjDEeqJxHpbOINIm5Cwm +4AN+rSeodVStvBtuXfS4F9jl/cRnU/j17W9vMRmPK0QSqQKw9ofZ4HwkpNfl7SQkRYoI6wLyqmc5Lp +mXFuCzZLefszAtmGilCYFRMufDsRa5duwZJ35PlOYmm0vVR6bYfK3qzyvxSqvViLMD3qrL/jt72e+g +RA8TIfDw+v7O13YSKKahP0AZNp5RIsZFWPgbqumY2K5jNCiazOZNpwd5kyt5sxrAoGFZzJlXF3mzGX +jHl0vPP8cUvfpFrl198/7ycU6Wasizx3h+omfsbxa1s1sVY2HyvKgl4VPW81YKeT6agynhv7wlV/Ya +969f/zQvPPTfU0fj1/WKe+yph6pqQwoHNl2IilR5becblDF/VFMWcopgz9XOmEijUU2lgHEpCo9zyw +niHX//1X+daXXDPGx+v1s/c9Uf3nzr7h4PB4FMrKyu/NxgMPu2cwzl3S9fBwtb7MzRPbscdzlPSRFO +aI38P1QCNbRl3A02nythkipvGZhqSYxBsW+jdtoX5AjAPje/cojjGOPbohhKmNWyPHg07o/Ofuv573 +7o3nn7zZ75waf36iyNOd0/zsDvDyT3D8V3F7pXEqqSQinIgTLPIuJ4xns+oqhK7u0WZAsN6zrYv2CO +wZwK7WrMdPMMI0UEQRx2UGJU867O+ssbS0hIPn+rz0GOPcuaBezlx7vTeg48/9ltn7z/3/ywtLf1fn +az7FFHJbQeNhgiI7Ta/jcbtkamSidzQ7OWw6xJH7NkbukQcGenI1ZYjStjLKWLpNaWw3Zbgq6jbhXM +IQMNhuOWhbdZEoohpc89Nk3M3ItEhawsSgfcRUUfHWaxAVU2QuEcoNvCTjbcVm1e/a+u5y99++UuXH +r/+4iYvzq+zNRrzhWcuU0yFJ+59gneefTPn/CprY5CdKZoC01QwEc/c1BSpYjgaMRmPSeWYOkUmqWY +nzNlNnqEJ7BLYS0oBeAvBCDEJITaL3ZGRGYtJBYOOpb/SY+3EKg8/+iCPPPoADz14P/efPfu5+++5/ +zeOrR3/Nddf+X1sBlmHGou3FiHD4m6AzAHAUkA14lrSRm6IZTsKmHgL4L0cqNJrzlq6TcHnj8i8tk+ +QHpnQtp7KfqMRNTe2NDcpYo0AHsE3z6YAsznMZ8StF+4bbVz861svPvXXtq9deny4vcHu9h67uyOKW +c0w9bi6tculywUuc7zjsb/EW8+9kfWxhetTBkGwBiZhxrCcUlASY2Syt8vuzg4TG6lJzJJnV0tGePb +wTEiMUGY0SfLxoAeZgaStImpY7TqCr0kR+haODWCtC2dO9Xjg7N08cP+9PPzIYzz2xjd97tT9D/4LT +p75p7jOJRBULOgpVJu+7yL7x20u3H5VNmk3twOJdnSZSbgFkF6p1HvtgO82tfluVnnayT2KMGsQOSx +BFI/clpNAqoESZAr1FN3dZHb58neEjSt/Y/vZz3+n33qR6d5lUjFC5gXMSsxc6aqBaYbfKuiUcO7Yn +Zxbu4s128ekmipFJnUAo5QamMaaedWoodW0REjsGcUnmAFjDEOUCcIMocYQ24bT+z9HJGEyg2gTvbJ +X1ViFdQd3rcCprjBQZX06x12/wAubz+CvfJ7RC59+/OzDjz1+92Ov+7vH7773X9r1E/9Qlld+nbSMq +B5tMAjGHdm72n6AB1scN25scjOAbk/ez92e0DMI6aVblB9ZC0nbGs/7QFTAz0Dn4PeIwxcZXr34vtE +LF95fXn3hDW64Q9q6gp2PWKkndDVA9IwrD7PGRTAZlexsNsdblyVWgiXtzWAcyZNlWhZ4qSnwFMkzr +ucUkwmhKhCUXQNVikzVM6RmTGRKokLwCMFkHJZpSqhCjG0omQHpOGyK9HJhJXesW+VkFjnWSwxSYm0 +1o6NTphvPcLHeZDp6jjvP3fudJ+8+951rJ05+llP242SdT5D3GgMXA9GRxCKmAxgS9gB+B3gT/hj23 +QJ8r02W6dDK+/IXbnYZxIATwVjXqqEK0yvocIPR1qXvn2xc+v5y44WzYesyDHeQ2YQVEwlaMI0zijI +yKyF4MGLIxDH2iQgcy7ucXT/NcVlC9mrCzpxU1oToKaiYSs1Ua4ahZuQLEjUWx9B6ilgzoaYgMkWpM +FTtlhL2u6NYB/ijafONHZsCSZuKZxmGnhGOLy9xetWRuznS9ayudxkc72P74OIOxcacYbmB7Ky/QWL +28cHy2g/btVM/TW/tp2EA0sPQBTVoS0Dtb1iHXXJTWyb/FstO+YpzcWuyZgG+V92wuh9QbA/L+N2kg +RpRNNU49U2ty5iI8wnFeEJ1+ffft7dx5YcmVy/eY4Zb9OsJy7MZqS4Ifs60mlJrzRSYOYPv9pDkSHN +lOvW8MJxQAnf2V1npr9IjR7ynqiLldM48VhQ2sMuMnThjr55RSMCTSMzZTCVlrCgIrdUp1AgRQY1tf +1DznTGmTZtoMtnFgBihK8rqYIn15S494zHGoM4QMsfa8SX6x3p0VnJsR+h3PaudwHo+Z9V1uT7890h +YP7vM3f+AcOcH6Zz4cczxT+COgeSI2ltgK+z3TfryZfeytEO6hd23AN+rlGVKLdjsQUNKPaIeGQOWi +EgNWkAsYLrH9Nrz37Fx5fJH0uan36LFBDcZ0asn5NMZZlpAVWI1kfX6zNVQzBOjOlImQ6kZ89ozmwa +qXh8NJaY/oPbKbFzSKZt4zTIFtmdjZnlgK824Vo8Yqyc4YZ4ikzhjO84plZbqab51gAZ8GhBnm7DRl +A515f3OtAoaFTHQdZa15WVWTc3yQFm/Y0BvOTK4w+JWLLan5B1YXepyrJuz5BLEGb1sE9KUqpjjdHy +Pqacfl+78v4Hwo7j06yI9mgbW2WsSNAvwfTUjNRJBUZLIAQD3BWAiYuIMW4+h3Ibh1fuKjed/bHbtu +e/WvW1s8RzG13RTSV8rnHiSDXgjRHGUoaJMileDOiEGZV6VVHVNSoGRF3LJGKwdww6W2B3P6UWBHK7 +MR2zHgpRnjHxkbGGKMEmBUgIlllFqgCcCLoOyVoxNaFSyrI+v64boNwZSQjGINmqvoOSZspxZus7Qz +ZTVnqWbFVhJrK320Kyg03EsrfUYDPr084yutdi8C3kXK2NyF8nzHIwlxkis5m+xMvuXRsb/XNz6Dwv +LlwyDFoCNA1/bPhN64Ae0yH4ZRb1xeg6y/EURMUfUzbQA36tb9DWz29DkcgMJZ1BsKrA6g2obf/2pD +46e//xPVpvP5VIOOUbAxjEpVKR6TvB1E6isieQcRjIk1oSipJ6XWGdY63aRgbC7MWW4B0Nfs2oyKjX +43DHLEluTMbP5jE07Z8fOSNFyfb7HOFbQ7zGtE8NQNYm1rcljLYS2sW2336GqPDE0Va7RdGDrNUlJr +i1HL9RVhSeBRnKTWOrC8Z5yYiVyx3LN8vGM0A3YvMJZQ+YsttODTg42I3OGzAIyBzGIqREzJ8kUTXv +fLXr8P0bWf1BY/5hhHRgg0kWTQxRS62o4dMLfWF9GzCthqhfge5WCzzZkgAZUTLs0E4aIY474PardF +x6eXnnqY9X1Z99jhpfpVtvkYYyJFbaqqOuKOpTU0RNRojT0ukk16gPLWYbVxMx7dveG7OzCuICQQd9 +06Ls+UWCzmOKLis3xFrNQE9YMS3ece6q/tvTUkvpn8l7/uc7S8uU/evrpjd/77L//3Vrrg3CSKBAjd +JY6fPO3fMuJc2fuXo0+3THaG5+ajEZ3b23u3Luzs/fQbDZ7tKrqR0MIxBhxNgOBmBI2h7X1LneuCHc +szRnIlCUyEgmkQ6fTpbvSxXT6YHLAkuUDxLomKkHmiKkwpkB1SEo7aNjJxdzxM87e+R4IHwT5EmRNf +bZWrVf0IKVK1dyU4vSKmJcF+F6dvgaDpoSmiDEBZxJCDWEGfkSx+dx7Z9ee/bnx5ae7rthg3VYsDyJ +pVlHNh2SlI0aPpAhWiQplnYihRjxIEqRWxCsSG4d5tMokwmYJ8+Dp9hMboxEu2904duyO3zr3yFt+5 +/RD937y9EP3ffrYqfXi+PHjdJ2lm/eoysg//p//GV+4fIW92QzyDnjfBGarcseps3zHd/4n2+e/9V3 +bBrkgQDGZsru9x+bmNpevXOPixUv9C89eemJjY+Prr2xe+cZquPHNV7bGpy5kJWeWTnLfqRWOHV9ib +bkGU2CyRNYdQLcPuYPctO1tFekstd6CACYh1mNsRZI56BzROaqepOY9Iu4zQvYBcL/UuCVsa52apn/ +EgU1oX0aqvbZUztsWfIojSUBMwJg2arHcJY2u4UdXPjG6/PT32XKXVbYxZoKppsx9Ab5ADaTUVBNTb +cu4ix7s1knbiM9sQDIdirJmo665XldMctDj8ODxR/+/1z382P/+5te98TcffvCxT9197330T6xjVwf +kq31cblnpdluvvqEeTukeW8esLLF+Yp2uXaGazyhGOzAe0ukf5/S5+7nn3gcwGknRI0mRRwUxOSkoe ++NJsbmx9e92h6N/90dPf+5nXrzwFNe++Om3msnVJ6cu/YdX5913dAtLbTJO33kS20vQyyBzIBaVCHl +AugZxDjWpkX42gDGISVgCQoVSoalAdEiQvCti/ycj+vXG1O9D+kB2xIbTWwDLvOZVztsWfHPAiWlqW +VJBtQd7zz1aXnv6l8vtS2/PptfpMselOeiUyk/xddXszXkHnxlCisRQQ1JcVLrR4MURbM64ipTGsVV +HLk2Va2VOOvXIH77hG5/453edffh/eewvv/PCmROnOLZ8nMzmuF4fBpZKGrwFLfExkAXAC5Um8rVV7 +nrsIY7dcxab7mVvZ4MvffGP2KmewWTLiPRIgPeBbu7Q1BRRIkXE5Kyur7C8tsq5mPj6b3or0/GI7Su +XPrV3+eKnys0X/l7Yu/rAeLr1nxbl9nfX4+xNK0lZ7hq6YsAl6CSkGyBXou01G45regY2RWEExGI0A ++2ACEkr0DFJLMmF77OM3yh0vxfufWq/M4U0RRPZDwpQFUQSt4MT/jUJvpeLV40iCIaUPKYcwfDFb68 +2nv0Vv/XsOpMXWLMVUo9JZUEIjVoaOzlRwUdIVommsfFcFKQ22EqoS6FMQpUN2IqWra4je+TRf/ime +9/8j85+3Tf/9j0Pv50Tp45R5nss5V26ptfEkDZNhvCAp6YvOU4S2MYeTbZElvpkp44zOHsX9698E9e +vPM/m9RE717fodI/h8iUUyPIOPswRgayTN61XmpK8GCBzlmExpjvocu9jb+Khx95ELArKve0L843LP +1EPr/3E6NqX3jk1o++Jcfw3+n5GT2qyvIasBOMJrkNmsobxwYI6iFlbCrELKQOTY6xBxZNkiEpFJH8 +7uN+RdOa/NuJ+A5Ebgq8PokTV3kB/vlbTmm5Lybcfr+m9J4333ldtXft42r2GLXcZaImLM0hzjFYkj +fgEPik+WRKCTwmDkIklw2A1EatELAJTn9A7jg3veuihn/26173548cee+u1/pk3YPp3NKU3gdwsE1E +CYAViVDxNFGSHHEtTidq6DggY5+gsD+jfsU7v5B1kaRmbL4Prg+nT7awgJqMO4AQ6rnPg0E5AUI/Sq +I8isNJfImGoGrlP3u/T651j6fg5mIw48+Djv11vf+m397Y/83cm1XPvD8Xsbw365VreqxDjUeNJhiY +bXg0kBykH6YDpgGaNamkMxiTU1CQ8ikGRdav6vyXC+61kn3jpzVNf08B79YJvvwqD9e3yAchQ7SAJJ +ArYCLZsJzEj0iGmhqdYtQEtrzLa/cxH6tFnf8RMn6ZXX6cfZ0gSfJ0obZ9pp0dpA9YnlufC2qhGxhU +lV1HXpzJ9rqaMzbpDOThJ/4GHx71TD/3kfW96x0/nayeLwYk7sUsDkgMvTZKgQ8lxbZ/0ANpMglODi +rRqZ02n1yrIyeJiYnloeHh4kjPXTrF5WgkZdPo5xIKODUg9o2MgaSK0PWj3SQyR5p7d5w6DHDpXjq7 +tDDi2SvI9smOnOH7u8WvzyfWPlNPNH9+bTr4/K/wPZo6V3ul/g8O0Lc48SAVmBq4HdkCswMgAMdrcp +ImmbTx9guN3ENP9OKyfhGM/CisoPSIdVBwqTXaEIbZpW9I0isEiWJLsZ078yYApC/B9te6C/f/slxv +j+2GbakEjSZp+JAo4Azq9wGx67aeqyZUP6XwHG0qESJSEswnNlTpUpKT0nMUqkDxBlV43Y7V3jp3xn +J1xzYQeq2fu4aGH3vrROx/9hh+zZx4eki9DtgydHvsmTRZBTERECAJW0k0exsNhxZJISPIYDMEp3kQ +K8RR4MitkxmBMw8tHX0NsAsWN2T9iOrg2+6CT/dOZfXLDHqRN7Wt5AuAskvdxA8Pyas7yfLmoJtt/b +z7d+fl5Wfywq9Z+IDlwRKyNDetJajYTX2Ftv81yaG8KaERN2w5bPRoFMdMfQbIVcB9uokw7RBXMfgG +q1haUtsOuIK8gFG0h+f5sh6V1lBug0+oqDXOmZr9ymG1CqVTa8KoKp03C53Dvkz/rp1sfCNMX6NSbd +MIEazyaRbxJBOtxNtANHkJC50qswbgOMe+wOYRa+3ROrnLs9P3/6/GH3vjfZw++/nOcvB/cEtAjkLX +2C809kWaVByXkiUQi22dJ9cbNoyEhEl4jmc0JTihsZCaeWRbpSEKMtv3VI1U9b8kfMPaw6bS0f00b4 +bKPdTWpfbW5hnqTOBDTgN9gIetBZuj0u8jy8tCWxQ/aNPsVpfi73k/+o8gYxwxjQTUQqXFm0Pye1Ep +eEsZEwKMSkDRHqUjJIzZ9SIx0IP9bhlZl1X1Hu6EtGdyUtDiQ1LIA39eMUJF547DVjJuFh0pE2x0ds +RhjMeIhjonVNn4+J3sJbgAAIABJREFU/NlUfOYDzIfk5R7dMKUrFUYitVWCicTocSZh1aNlRNWQXId +5EPZmJTtylpN3n9u4/9HHf0Duf/SfcOpuyFaBjEnlMZ0ugYjRSKd16DdxlglEiSQEPSKb2kWv+w5m0 +6Y9WRQhWqU2kXmm1B2l20qPFGvQSDkbU/s5KQasNBn3rtmBjli5h6RiPKD19QCeHKE4BAiqaFSMCJn +t4lxOvrKCWwmYSfY50vi76nj9vwrp6keTyCljSqwJGDJiDIh4DB6MYIySSFiNDfDjtJG2Mm/iZ0U/A +A6kBWBsxbc1bXpuBGl8s41/cAG+ryFh0qhjIhxGRQtgpM1gO3zKCkANYZs4e+an5uPLH3DheVwqcDq +lpw1IkiYSihdFxaC+Iq+bWibRdBipY6w5dZ5z7Bu+/Z8eP3P2b8vZe7dZPtYSDTlITt/mBG1URyMGQ +0JpJFUjftJB5rfZ93UdyaK3R1RqJ225Bm0kurTEIqmGUKOxAgJlNaepyZluTS+puQXlZI58hxslbyO +Vs0b9pAsonsi+NdntPAQ6Jo8r/4TY+z986v5MiLt/3eoca1oVX6vGpEw1ooLR/VqlCU1jjLUtW1pBi +IB8ANOpMJ0Po71Gapo2/pNmbjD7W9YipehrNmK7Z7tDjvpAcqiYg8zzxtyKiB+ixYsf8ZMvfShNnqe +fxmgscVpiUmx6HqREVEXFNZ2AEjgMErvsjj1b04yVux/jode9+f2Tx5/8RKe/3BAMCKlOmJSD67R9G +A4MLwJKTSTRqJj7nq3GDjOHdSqO/pbUSC2TBJzgIvRsRs/aRnUOnhjqJspGhBBC6+iX/RZINyauSqu +WS2Pv2S9LZk1HFDnTxp3LQV5e0ERKbeNq0za1dl3IeuSpv23Cyn9Zh+v/Noatj4c4otcFk+qmxIaax +vYODqKgSUhujN23CdVCjCQVjMs+hMgYWf1RzKBlgATIDtzxr6Vws1en2vlSmdCt8RKOTJEPu6TJc+9 +jfPFHtHge569hIxAFm1rbMQWSCjZZjOSot5jYJ3rLtHSUrsvKubOfPfvGd75Xvu6tn6q7ZxDyFkSCZ +IlcHfhIrCtsp7VDTaNm7meTpta+6rYK5Q3kkd78O2zj/EuJgeQcz/usZl160RKDPyiqiyg+xTYKxbS +M4iGQ9i1D3Y/AwbTf/Oj5jtRY0YTRhtiQNpLHqGCMO/CnRwtGOohkYLs4WQGz/gnPyqdSuvpLyvANa +iqgQJI2dnnqQuo0THQ+B8kgGdCMpAG0CfcTnf8I9uQm3PEJdBW0ByYjteqnvobaW79K2c7OgdUkN/U +VkNausQYsM2J9/dt98cLHmT6HrTfpM8FUHVJSotQEqcFEUhKcZOTapyoFX+UMx0rJEicefOJXV5/4l +u/hjvsKasF0+wcY8YBR25wvd1h3ZGGL4MQcQC0QGtuHnMOaMY1E0v2sb23ivg90Z4XMZKznfdZsn34 +URi3wQghoagKkkzSbUkwRZ83BJpUOKIvDQ+b70360sp+mG8GvjQFqjuLUt691laAGSQ5DjrErOFlG6 +HwqRvuOmMI/Smb2V50qIv5Q8pomtlNMTdKExPyAmVWzAzIlMsTK9ONodRmV34CcGDKikYbDIZG/1sB +3tLDrrRybL9f26o/jEH25CJSXjVAxDqsJlYi0/jNSE6lvAavg8IhuPTqdXviVevw0Hb9BHqeIn4NfJ +USP63ZJpmY+HZNj6CRHmM4JswHDMcSl05x93dv+fufhN3+YpbtAl6HfZ0X3yZ1WmphmXdZteUHVgJN +G/TSAbdVKpzn4gHZa8kAEpKmNWbU5bM6AltB1NDaRb36fVpHZ7hBnB9SDQdNUM0aoSmK0iHUETZgYM +GIx4g7jTTks/qRAaIkd00pc2S9Sqgl8aM7bBLG2z9/o4gkkjEgjuBKkYBBdRWwgz1JRFJP/zMTqp3y +qPiQpkhEwWjUbjQkELTHSO5BgST2aiqaqmdlkVmzR78VfEbvyjcSVp6CLNU1MbqBC94k2ubWvT1/OH +6GvbH3eqpnMV7O+bz6GO/rCX5QKxS/3HSQJxtiWSq9bQ1zaSAvIUkLDFuX04i+H0TPrprqG9buYUKK +1hyAkLFNfoXlJNrD0Uo5MHTY5ikli9eR9LD/wlh/iwdf/BMfOkOwSUfqoQB4OzSkVmqrSbU55Aqy4w +2jFqNgUW58jkFwjicy+2zkREWJLFhmg26XJWKjnzTMB6nJO9IGUEpkzDLo9+v1uQzKlRF2XWIROp9t +8NsXGxhJFbNt3r2mNSSA/IPGlrYZtDDhjkI5raf023We/h98NpE2jQps2takJSHGIDIBj9HoPkEL3w +7HubqFbP56kwEhoik6RwDbBAJKkFbgBbIExU8SCsVO8H6xnaf2Xxa6+w2oPHzKS9dibuiztO+5fMfD ++hOvvZuHzUs1Fb/X5l1rP7uY3vZI6ni91kldaA/Tl3vdy4LOpZTFl/2InEgHBYlSwcUQ5fv4Txe4X3 +h6nF+nGLWycoqEE39gW2IBPJZo8Wcfii0Q9KYhTh1s+zfI9r/ubPPaGX2DtLtT0KVu/nblpBxVpiB9 +7YJHs49K2722/6JEAfm0dx1E9QSMYiyUjxzblKzSBLyDMweYwnzOa7jGtZlCMkXyV2XREVZUQPcZ28 +VWJL+d0yKGqGollLc4KzjTpO40rXKlCxDmLaVVdrNnfxg4k+kFFQLtPc8QDTtSQHS73NhNdm8A5lFV +EcqzrIaH/E1H6E5Gdn4ddMGPQEpXG79g0+GxYUCMek0rU1DjxBH8FwvG3590Tn8D03mdjF0mCtY2mc +HQN3gy4l11fXyVpc6v2AEcfH+1S9cey+f44nUn/pJLyZSXby33pVhtCLJGGZDBGMaaCWMP88nvj+NL +3yeh5OmGbrpnhYgU+NiUK4ghjPZkoSS2pFHb2avykS69zgpNf943fx+lHf5GlY2Ac03bh2YazBBdvs +o9AVHF6hI61rSonN15lVZAUcAYy0UNLLHn8tKAeTxDvcbEexNnsLWUVX//czviR55979r4gHula+ks +ZOzs1KZTgIDeJK5cuvPj7//Zfby0hV06vrV9a6fafXhks/RHdzh/QdTP6GS6zoIG8dxxIhNRE/9AWk +lKagsLuyBc2R5z1+56drC2QpHJoUR4GrPWBHmgXMX2s7f4C2gkq+j8iHpGIamgiXlqXkW0rCxAbkid +Tj4YRKV0hsf59puM+aczJXzLSBbIb1sefhbZ2Kwy8Ekwc7U71Sr7TV0243OrH/1mrrkY4Qih0G3cCC +Sgg7T48Hz3zc2lygbzaoisVOYEUEj427B1phI1CRyHFLlUtlJMe3eX7OXnfN/5NHnvHL5Ktg+lRqCB +isEdyA8qWUbStH1H22Yx4pPx5MgcZ59q+FFoZ3Q+xKfHgmwrXlCVhOGTvyvUnh1evvHu6ufmXs1S/d +Xt7m0sbm3zu2i6f3Z4RTtxD7+RJlk2grqfU9RSKERvPX+VX/9k/vvu3fi2/u1f5J+4/eSf3nDjJfWf +Ocufpuzh5+tSn7rr37v83O3Pq/2Z58JvIDKzBSeuwbsPUQsuGtl3jOdobQY644yW2Es82AFL2k2JzI +jkSwNJBshyxFoL+Yki1A//zog7STlPZU2qMaTYEUgahf3DBslBR+WuUlaU/kJ9jIL+NnPwSVUI63a9 +q836lNt8fR7rdvCG8kk3B/XFVwj9NCfgn35oOJU5DrxsSFXUcYYvnPlbsPdXNi8t0w5CcAgioT8QQC +Ah9U0MEVxl8mROrHl13huN3v/2HePibfoHeGdTk1NZisY2/jyYoWtQQJR7MYcQ0sfpiGpZyH22tmpm +SIpaDpiqIgaKCvR2Kay8yvX71yXo0/Gv17u53za5vrs23tqEsMAaK7Q02r1zhwuVNNjTn1PG7yHOwL +tEfZJw8tcbOtSXqnRFXLj7DKFQci5Bdu4ZdP4k+/yKbS0ssrQzeevyuE289fueJD/VW+sO1Bx75tWM +nT/2L7Mzp32RlDYwF63DG4Iw9KPLHkQYy0jrkD2NEE6i2Vb1N6wDIGvZVW/85A8juAJ0hqfgFH+Ny0 +v6PO7fX2HmprasdXbMz+W5zXwIiAak3CbGkVNPtuqWPkS//B8T8K649Qf5U7L6vBg+vlKR0f5onOto +W66vZmV7281oB3QM1LkkTMjWfbnwwbT/7nlC8QF5vYutJo4a2XiJVIRIQmWNqgxQd/NjQc6dYvvdtf +597/tJP0HuAQrt4m2GBjERGQmJqYxWhk9mWRVQSBm8EPbKhxnbBWtXGPk2KpECal1RlSe+ZC4ONF59 +//+aFp98737j6qJsWZPM5bjpjuZiT+Rok0h9uszyZ0pmUKCVaFxSzEWa0RVVPIFWkOMeIkpnIshVWj +GBnE2zWxboMZjPme5a94TbF1Rewzq25Zy587513n/3eex58+KnVc/f8EsdPfJyllRm9JXAGZ8CKaWy +/g4Brc0TNrg9tWFw7n47U0r/Slg5tNJQMslWsnqIO+hPR908489SHNNaEUGJjxHiL+D7UDfhSmhFkQ +qljqrhLVUbUr7ynt3L8g3TXPnYrhv6l7L8/TcB9JSLmK61ZERE9fENPmgMVr9jV8Oe1W7yikWqQHFV +DbON3vff3TabDn6z3rrAUx0icIqGEOrZrRA4CSUJdYKocKTNc1aEzOP2rnH3zh1l/CFgi5IelBM1Bn +ficI+Kuec3YFvjtxn1EUcuATJqQMMqaajRmtLGxMtkd/kD1yT/44Gjj6nKxcY1+PWcZGJQVrvBk85o +uiUkxwQ3HdMuKbmqOlwOZgLWCMeB9RZgMkQRdJ3TEYuaBPIMlY1jPM1Z6A/KOJe900JiIoaS4fp1r4 +zGTzZ1Hj794+aMnH3jkI8fuf/BjnHAfpefGGHNY0u9A05BDt4Np07hkP5nWNoqpHrg3CandfCwgPch +Wcd7ja/fhFPRcivVfTfUEao+pM1xtMFUO0VCUFTUTStnCG4iaKKcnOBUe/Mn8xH2/Dlz6arrkyks3C +UhH1m9HRPbz1dZEZNZO8TERWQMuA7mqPqSqQVU3gHuBu4wxW+3xHgeSqu4A94vIOeAZ4F8BTzXcfDB +9iaIk5tLk3giaFCeNgh9KxMQmUxPYMeGgO52haRuV7cdNaLsDxcP5kXaBHmiLDcF3JLjpkF1LNz2+l +bY5dT2WrCEHuuUYW41h5+kf8xc/mevms6juMPVzbL/LbDRkdWUZrSMSPC4lOuEBtvdKtuou6w9+w2f +v/Pr3fA8n7yfhCVlFB0enVaYEiEZucHd5tP3VYFKiiyG0wcwekKgsKZi6hs3r8NyzuMvPfdhcufTfh +Ssvrg2KbU7UEHYnyLiiqxmxKvGxxvU6bO/uIcYy3J1TxUYF7HYGhAxkxeHSEK3HGFUGa2cotrcYT3M +GuaUT5tRqCHUkD4HV6OnOazq1xznX9Fxfyumh2Osj4m5BcfH6sr3/0t9ZfeSRD3Dv6b/HXad+in6Xm +TFEDF3pNo5t38xKMA3pYWj7zRMRIN/v856aKAfV1IRtsgRmmdQ9g5qa8rnf+p6Ujj8ymY3fsLm9waD +XJTeGrRcvMBCHqQJhpiR/Apd3yQZLXJt+hs215/O3nH/+x6aD7/7PnTEYYzoGU7VOmxzVgaruNQSuv +SdBGVLYxshZhzsJbHpiqsget41M34B4nyBnLGwJ0aZUvz4zRGLcc3C/GLmLFDeoqi4hfh1QlfnWrkl +6j/PhjPH+ReY+ow4PoBIxnU0/nJ6oxA0KsbO57SRZXV9eO3MWZOkLFenasShBRHBN3TbuxfJXCOmhe +lK8kCRdNJbjucNA/Bz4RMedoI7XmIyfO35icAqs06TPpCC1VXc3JgzB7aImQ+yAyLDhoLUDVC7UjY5 +oxGCzdFCcsa15KSJou9Ua85Uj153N0JiQELC2C+Od77hy4ep3b17axPmKoIlMG1KyLjsMQ6AsC7Lco +GJIwTMsEv0Td3HnPQ+/l8FagVpM1m0Dec0BvX60n9GhVLOkFKk1YK29octcjtK1ApMZYeM64y899eT +u5z/7P8Rrl5/ozEbEYooNNeoTqYqkOpJiatVnS/IROl08Qr6ySpzMmAOTqqCbIikFOp2MTsciLhHFo +5LwyVPWkb4Gsu4ynW63KSPhGqlknSXLWqYwyxCbgRFCiISiwF/bZmazNR2OPnpHFf+L/K6T/+1gde0 +3yZoolBgb+87YW/Wbb6+SafuqmUZsitjW4dIGutqmH3zgdPH5L372vdvb258cj4eUxRT1gfloSCoq4 +rTCNoQoSQXJOkyqimMnT5Fl93z3I39lXnT6/UhmniPEjKRvwNqalPaoyvuAu3HuslFyF/zjpDTHmG1 +SOi11fVdP9Wq79k7XdUUK9V4KfjWG2sTgVVVDDHUmMYCGqD5YXzZpW6rKXrhOMZ3h56WapMdS5ZmOZ +0wmU3zg3sIntouSwuSDux5+HW/8xm8ql1ZO/EZ/dfmjFvf7+6qTCz7hjA0YlqpUfevGePN1v//7v0t +ZTCYrvdycOrYyyJOfGV9tHVvqn7xjbd3ygr9gjPFG3FkVc0Vs53nT6R0jH3Sw7vMELcGcwtprOHcRY +9ZRtaj+ESIRl5/AmCtgLqHplAHBuc+Jyw1GTjIbb2Lci1hzByJdMM+3qFzHmFnecTVFaBLs5tPq4qe +++JHf/de/zXTzixwbVOQyoyORfidnHxp1rDl2bA0xifFsgnTXeOz0o+/n3td/iv7xJv7QdJA2/lKOE +A2N3RMPOtCikLB4E4kHCZ+JTBM2CTocM3rxMnuXLv703jNP/e3Js1+iu7vNegwMFOaxRH0T+WJtjg8 +BtRlJEsO6IACzsmQkym5o+ujWAqbTZHGrlKjU+FDgfYlYxWWCNYY86xCtEl3TOdCnSMdYTJaTd7qIQ +rSdRiUxGc5ajOsgAdJuga+Umek/Yefyf7q77c+wsvL90usgInjTBGwfePn0JjNlP33qSHaFtBRNg8n +/n7k3DbYsLet8f++whj2decw5a8ya54GiKCiGy9iIeJ3AFrBDxBuBjY3YHd1BBNGhtqKCVyIE2w4pR +em4tnJF7QtGKyiFRQ1Q85BT5XTy5Dl55n32tNZ6p/thrX3yZIFfbDvo+lJVmZVZO9dez/s+z//5D4p +IBhozr6L/7c1vP/rYsZ89eeLYZ7vbbYIpML1A5EtuQVTtc60tDdSsg5HxjKz7LMI98lOjo6M00hrOF +igPSRQHEZzI+wNsnoVYRzcqITCmwBlLCOGg9x7rClpZb48QAZzH2BxnzLjzecnxtVZ4m0WuyEtjZGe +UNwVFUewUHyLHGUev1xVb3R6Z92Qe1rt9lre7FHHKzOGr2XfkCq49fM3Rq/dd+btj6dgfEcQagK+el +w5BeCfCcSnFr5iIv3Gp/Nhm1n7Hdx5/uLVw7CVaEiYT3WgF0ZhIE8YbDeZ1uD5NU5K0HmSkJ5SObkr +qDRrNEeKkdkdpAy6dkpGK45hIxUYIpaWUQkrpXXOiLaUcr76iC0Jp4ijdoyK9JIS6gFRTUquaUPHzC +FUg2AfqPEqdRspxW1OxQj0rVN30Fxd/+cRjL7H4/CL9rS3W2Mb0V1EyoIQkjlOEVOhYMz4lsd7QTR2 +33HnrH4/uv+VzNOdBjoBPL6PsDmPExM4iePi2lTsDGZdyl4KCgCfBorICujnrz710++rpU7+7dX7hT +tobNK2hiaRlPEme47XG5AZvJcZKusbjRSAjsNrLaI6NsrzdZ90Flo0hB0KiQQaMzUvwxQ/Iiw4u2wQ +PA2vZdgHhAgfmZhG1BNFMkTouS0BHFD7graMWSlqAlBod19H1BrLWRKkU52LUagfHKmrgPiJm8/vZM +/MzshU/GYSgAJLqEBqCGyUN9PIkJMTuG7JESX0IZVczdgOHr8swf/vS55567rH77aB4r3BQBKhzyfJ +iSJ9vRnV0UOQXJC88sQorf8xIs0WjlqKlItWKZpwKFTy+yBlrNEWqVZmQaw3B2WpPWyJIPlsr52YR8 +N4SfKmDFMKhgkW6HOEtwReltX1wRK40HPbekm4VZM5AYbBFRmYsfR8wSpEkCQeuvY4H3/mDxc33Pfj +fmZz+JLXRRxEaslDupnQ5muko0riKmyhT/fjo7MTPvvEdb/qHgwenf+bbf//1I8ce/Rar58+i4xpFr +cb68hL1rI1vtQjNhpC63ABlSYxptEjqtdLXMihFkEgZoYSOyn9WKBVJ35gcF1WYYgjsCUIhVQTIeR/ +EvPG+5CYq/XqPJARCQN4ohEBKGfKJpnCFfzdW011rs/jyacIGuC3F+nqXZnMECBTGImSMFQERSc4ub +ZKZnMl7r7w4de29H5EHbgBXA1GHSFO4EiIXQ3uTcGmlcRmI5i79u8WW2y1vsReX6J84+xObzx/7/GB +xUdPeoOYtaZ6T5gW6nyH7A/JIk2cOKSKciihSTRFFdDCsqR5nN7dYaW/TMZaztmANGODoFQOCy8t5W +wyItNsR8jdHWjQD0O5ybnOdVDgSKSjqDaaSOjJOGEnqJErRiJt4qRAiBhUjiBBOIgpB7ANprFBtgwv +bBC/u1JF+DDX+AVHXf6SE+se2r5ev0XaSoAShCuUU1crGOMWBa2/njle/iaeePfGR488//0YT8lkP9 +BDEOi5vcRWhnYS4UTF3HFknsH5umbZcpZ7GjNabjKQ1CiVJpCAm0FFtrJLESiC9QwZf3fCqnHllmyB +FSQn0BQSLV6VjOcGQ5Z2y6ERFIJCOEALO5BhnmcwU/U4Hgiet1ZAqkDlDfW6ewzfczL1vffvTh2+/9 +z8zOfeHWNHbATiUqDSK5cGkh7YYttJXp1FtTc9M/tb0/a969PqDe3/xxcMH3/7M178ed86dI/WBuk6 +p56vUQ04jSKQD7y2R0NRUThISIh1jfSB4RRAaQlxaqcsYJSP6WwOElAhRra2FREiN9RLrPEJEOCHxT +uACWI+wLuB9IIQgtluaYhDAxQiriLswJiap1SStmREGRRfjyodWBEXfFJjc0+5vMT41w76bH/jYnhv +uW6M1j80kUuoStQwVMUVUKGfYDfVcGl3QQ1JvICIQY2Frg/bJY/9+7Ylnf9ktrZBsbJEUBZG3+O42R +a9P6ktl+GDgsSjQMSaKWA+WC9ttzm6us7i5wUp/q1Qf1Jv0k5ioFtMaqaG1pNlImRyt0WsnjDajSnY +OQQaS5gjWONCKdec5enGJJRkxGafsG5/k4Px+picmGScpleEyAZXiZYStDhgZFErFEJVkNz8wmI22R +okvqMnWgbhV/5VhV7mDGsrvxRCRVcBJRT8rY5OQUtLXnlpS574HH+Dc2dNri+fOfuziRv6HzTSlk2U +MQo4WEc0oKm+ioo8WnoZQ1KVkc6MDwVFPUtyIxSR9YgENJWhEGpWm5Q2HRxGIZCjzFSMNkSSvuTIqM +Bh8MCjp0TgEFu8zorreIS2GapfssFgFRW5YMV36iWfLedZsh2xsgsNHjnDo3vv8/I23f3nP7Xd+kqj +5eGa99zoi0RWKUIVjiZ22cxch1VftQUyKSMKje/bu/5fzb3nLT16/7+AHTzzx+K3nXzjG5vIyjZkx4 +jghisseXgtNLZLUIkkiA/3+JsILPBohI7xISmsHYUBHNAa2/IKkqiDsCCk11guMBYSlsJA7CM6DlwQ +fsMZgrGN7JUfJFFdEmEJS5I5+v0fhCmScsr3ZpT3IcTomE9DJAoVw5D7mrlvv//M7HnzbFxpzh0HW8 +VEJBLwyoy9Q5thdgl7lkMS4o/FUeOI8I1tdYvvYS7+x+fSzHzWnz9Bs99HdjMg5grPkvT7O5uRa4YU +k0zUGzrHZ67JuLBezgjOdLdbyHJOm7D1yN5PTU4xOTy7oVv3RIo2evlh0jy52239W1xJfdAi2TxpBs +yYIkeZNb3nzHW978I2H6qgj3cWlW+3m5r356tr+fGWVfL3NxSzHdtps6YjECXRaI1UpkYiRKiFEETK +pIdMaQSlEpCFKStex3BM6GUrrXxYqniDSv7CL6LlzKA278/LlEpdZQ4UQSo1HKMkIBsPcgTne+JY38 +OzTT3zhq1/563fnPnuXoVxTBGtAeyIHkbUEGYhI0DbDGEUaJ8Q6KWdY5xFSILRESolUIIJDCI+S1d5 +SuYqSKPBBE4IjeIFElmEwFXBmiSgGHZywWG+w3uBF6bmTmYIsy7gQOXwck8cJjE9w4IabueaBB5/Yd +8sdnxNTc1+0spkNkLgoIqZW6ksDeOOJlKRSfJVLdgUkaCy2rHBvSaVG1kZ6RPXf3Xfn2FN7Zvf94qk +Dz/7A0Wefl/n5fyh9J4MnDo7WUOLvLN4UNKMIHASh8SrCCYVBlR9CBlpxWXTOhfKGDKakJTuBM5X63 +AaC8eAFIiiEC4TC4KwhjQ1xlLDZ6dJez0DEOAKdXkbP9vCJpp05Qk2QIdiyYLSkMT7FHQ++/uNX3XQ +bVicQJHJXhJz6Hq1UEENx6qXK7HiIBSTBItvbrL700m8vPvrYh83p00z0C2r9gribo205RQovGKiIL +RzbRYctH7Pe73FqbZWVIseNjhIfPsid1x7h2ltufvi6W27+8+nZ2a/Wm/UX09E6XTPgO0ef5Utf+Qt +st0NzrlHKdFxB0S/9XGZnZ5981WsffHJ+fIoUgW1vUWy2r+8sr7xl8cTJd507euI13fUt+kJy5uVNa +i3DRJrScqArNb0TEqEjBiIQi4ASAa80SqqSydC3EHofZWY0RvBzO7jK7uy/nZtuF/F6SLnaxQ91BJI +o5qZbb+Ud73gnR1889vGjZ868S2jQGrIccuOIiEijmKaskRZAL0fZhGYSM5Y0SQTEzpNqTUPHpBKiA +FEoV0WR8MRaVvYWrvxgeUzwgeBceSPHlO+B92ALalGK9wWFFxgv8KqMW5PaoKKE9cMNNvoDRuf2cc+ +b3uyveNVr/oqpuU8SNx51suUMcUVEjMpLLQhSASKSVcb4TvGVT0xVaJSvAPbSc8OXfg210Uflodp7r +mpNvmf6yE0fWnwqvuvCmTNsLS8zJkEnMSFclcyBAAAgAElEQVTLsL0+0gZM3qdZaxAlKbkXFMZhRAC +VlL22KZBSo2QJa1hX0rAioYgSTadr0FJTjyIy68kLj7UWUxQUucGYrDQosim1KKaXOTJbYELACMHFr +XVcFBO0ZBA8F/0WI40Jbnngnl+/6f67nk/qjYoU5odr9J3TCMA6uyNIdVTzZygTgbQqldwaT1jZYOm +xp39j8fFHP+wvnGckK9D9Ab3VDUaiJqGXM8hy9GiTrrCc7G3S1YEzFxZZbm/QlZLpI1dz0wMPdG589 +X2fO3Dt9Q+Nzcy8mDSaCCUr4qgh8QkTUxOM1uvEiUb7jEYsqxcFigzStE69OUrcGsEai05T9NTsi/X +DV744e/Mtn7pldeP6pbML71+/uPKhTfdY69zSRZYvXmB/HDEmFKmIUPWy+SJK6HqHDh4pBdp54qKag +YKhaHc/HCdJQRL9wk7xKS6pJLh0Iw6LUEu98wNWSFLKApDUec39b+Q7jz/3/KmHfv/XpdIfa2d9lNB +oH1OTCZFPCIUiISEmpk5M2veksWeknqJxJLmgJgOJD0R4arEm1WXBae/RIpRWi9ZTeEG9lmC9RcvAe +KOOsz16nQFRBKY3KLkDwWOtY+B9+d4KSQgxq/UJrr/nJnfLPa9+bOzKI7/D2NQfE9eBhKIIECuScgt +caktDxf99hSxGD+OCGQYoBlWuz+UwRSZCqABRPSOp/0FzbOrYdRNv+8XaiePvOP/iC9KtrjHIcoTto +5IYKS2pLpEll5fCTSUjUp1gpMQNeUcyVK0u2ODYmenKFMeKKlQJVqUoX0atEM4TnMd7S5Zn9AeBTmY +ZeEPH9en6LlEzpe8K2v1NehI26XBw39Xb9735Nb8yd/Veimo1IIYeyhVdYJiYIxW74qKjHacFKirbw +HeJs4L+saP/fvU7T39UnlqikXXR+QDyjGa9xvb6Nk2RktZHOLvd4RR9ToQBR5dXaK+nXHPzDbz29a/ +tXH//q351/w03/Nb4/n19kTbKT1Be+JW7Q0A4i9aaWEMqBc2aJlGgnEFVB0KsYhCKzCt0VHYZKqpSe +NM6amz8xX1zc7840+l+ws7v/8j5k6f/3eLL51rrW336W1tMeolIGihlGBlPCHGMiyK8kGUQSoCosJB +bQipBqI8SRRvAr+y0nvry9WwQl9Y1lxGaK2ArVgJRi9k7fwWvuvd1PPf8sV958fixnwkuHXHWoq1Ai +5iEGk2Z0hApTRXTKhyicCR9y0gtRgqHNAVaOVIRkXhB7MqbO9YSrQRxJAjBYYVHxR6hS82jMTndgUE +Fg0wEUZqgRESn36FvHCaKsUAePGmzxfjEOG94948yv2fvX7b2H/oUrfFHEUnJPxIJtUgRnLwkLduxC +AmXuHpVBZZYZZCXhh5BOShXg6YVpf+WlgJU5Ega/yDGrv+Bw+N73zsxc/j/Wj1+9J7OyVOqXywhVEQ +kIA5lgQgf0D6UPpBClR6a3uOjMo65TPvxGFdasgt0RU0yeCkonMdYT+HBBI/Fl6RmKTAOCmPoG0dmD +T1XMGDAIOTkHtqmz4Yt8HGM1hFH7rz+k69+06u3ZCuqhuuww2AZvhFDAEEisZVbyHC5LocKoQCxGTB +YvPATq8+98MvF8ZcZ2dqm5gryojwxe6aMZu52MgwFy8Hz3OYqz9otsskmDzzwDu5+8LWfufuNr/1E4 +9D+DZIYh8IBxcCSpro8lHxVfKJ0ftaA8oY4glhZlLQlCQmIVUmKhhKy95XaQgZBrASRkjA+Rjw21o8 +nx3/lmmsOf6750sufWHz22Ic3Tl+gv7aKCZJ9I1dgjcdpXybOWtBG4rWqZjGHGOR4IZFS/TJJdA4p/ +qiyGi0d1v4xMnz1fOtyV0F6UKnmjjvu4DUvPbC1cPb8J8n5JYGn5iUTKmUkJNRDTCOuMZo2GJEGYww +1nVKPEmSwWGfBC5SQKCkJwVZc3kp1HwTOB4x1GJmjQ4SKSx1oVhSlhSGObOBRaUxPeXpBkEkwKqI+O +cGBI9ebuWuPPMLdD36GevPPiNLKHEpWORWVT6m8dPiEnUWx37WOkbuI1eEVJ1P1tg2Nd1xlShQA7z1 +NX0eON/5ktDZ1brQ18282GnPv2mqeIDt/ns2NDQpnGU01dR2TBo8xhtxYNIFIKbyUeAc2WGwozWFLj +01QWmMHBdYV5CaQm0BmPcYHcmvJTY7XksJb+tYxcJ5BMGTSkGMx0tHOe3R8To7DC8HeK/Zv3XbvHZ+ +ePTDPoOgRx+muE9nvMqy87Ecr0VKl7fKgREA4T7yxdvu5p57+fOelo0xkBeNFwPZ6ZH6ASWNWum1at +Ql6ec7KZo9zZsDLuSW96mrueevrn/uJd/yrj8wd2v81OTeBVYGezdE6IUJSS0rGX6hWil6UWsWyQzE +IFzDBIGTJ4dSq7AZV8ERCElVroyFGVCUPwrC1doGiIUnSqY35RuPnJmZm//z8M8d/6+UnX7hpNeszZ +sqViNIS6SKcDdjc4JQijkvGjM4KnChRarz9PLX4RSL95BB0eSU3MFQD4fDdU0LgnccF0EJAJLjimkO +85jWv4qknHv30M99+8hdSGY2NpTXGRY16EVC5QQZLFElCocsxKYkujVBKIOME4qgiwEqc9DtKe+Md3 +nu8EMTelI4GMiBDgfWDkoMqAwNTYHNLoSOyWDHQmtbefVx9y+3M3H7HV9i3/zdpzT2KrjaRjtImvAo +cDVXtuF2+POEVUpx0p+3cbQ8gLqFWvvryA1wW4iSlwPo6cZCGuPYwe656eGJ05ocm9h/68Mpzz9538 +djRqNfZIgSPEYLUlbptCUhX0sh6Rcn7FxXxWHqFcyWB1psCpUTZngaH8wYfwHmHcxbvCzo5dAcF2wN +HpwgMgicXhlwYCixWOTwO6z3G5Ry58chnbr3j1r4Qcif55zIj2WFfOUQLRDXzivJze2dLNXjw2H6X9 +lPP/u7y49/WyZkF6gMHm1vYvAuxYLXYpi0lq2bAQAleLnqc2t5m9u7beN37fvT3rnvg3g/tmbnekyq +8khg8Wqc7i+UhP3Z403qhEGiiSBGpsrgKv4mMLGlNksSQZUCRI60lGn53cpe6YvjHLOcKnIzJVSCdi +EibI1+7amru1nR0/HOnXzrx0+fbm4zIQCPWNBp1IhlhAtjcErxAxxGJc5Dn5cEgUk2sfxe4i8qx0Iv +wXQqPIRpTjoeGgEUqXa48coeoaw4d3suRa6/qXzh+4jNy4D5ed566dCS+XIYZk5ObjCIzJEmEEYHtr +I93BbVU04g1XitCVD5bpQJBeIpQgHMopVBRTNPn5PkAby2I8rvVWuJLoxiKADaqU5uYYHb/oezALbd +8s3HT7Z9hcuovEIJyviv/TEHLnRHJDf1x5OWrYf/dLQBDPchug/+y7dTDX+SrGVGidnk7ep1UDzUgE +glx9Jek6epUEn1Uz068c+3kSQbrF+lurJMUBU0FKaXnii0yrBXlg5AKrUuU1BmPMRneFyRpnWA9prJ +EF2HYJjokju2BKYsv92ROYISgCI6cghzDwGYYAkJJWqOj3HXXPZ+94vA1BASxqjGM4RBhF0S3CzuXF +YtfVYZMerg07ndZO3f605uPP3WnWrhA2uliO33c5lZF/VJs9npsNxssZT1eOr/CSi/nyL2v5p0/9VM +fvfOtb/hUfXYajMKJco4IojSgsN6g8gJFBDJCiPJWs0N9mhRILdBSIBOPrgmiNBApyAVIb5DOgC1n2 +FAFyVo8zjtE5Q0hdqhzGqtduejdO+73xbd90I42j144cfY3V7e7DLoKF2laYhQda6zz+OBA6PImDhY +bAkoIVKTvJIk/jeTnv+vWC+VkP+w6Q/XeREpirUXqmCIYkiCZ37uH++66h1Pffv6z3cW1j7utLkJ4E +hUTSY1UEVYIamlCVIsRkabwFm8NkRdVEI5ByUCkS/K7FKG8jV35AZRSYCTClN6sURwhYkXhDZ1+Tl8 +qXKNOc89B9t12O5O33/kVDh7+NPXWY2UvL3Gu7IZKFUcJxiBFNaeHXQYiofIdF99TKqB34Jfhzwu/Q ++AIuMrc1SJDQFYWc0bWKuMgURJ0nStULf6GPLD3GxNzY++Mplof3j5z6v7Nl0+lZn2VojBl22AcPli +ULjmXIZSkYudc6RcpBFIFgrcI5/G2wJoM5xzBBbyxOFvQyx29PGdgAhaFkYo8WAahoOf69MkpkFgvO +TS/9/evufrIktYxphgGOsqSElWZ+Ow8mF1tJ/7SjFdadDnaS4tvfv7bT3xk/OQZJnJHnBe47S6xD7j +CsJF36eE4s7nBmcJyMu9z+PbbeOfPfvC9973pLV9U9WY5I8iKSSOGiKsnFpIo1mDkzm5ReHDK4LF4X +4as6DiiPpqwvd0F4fABIgX1pARhcIY4jncZB5cvRrTL8kIZj44CQSr60oIP1OZazEZHPhWNjy6fee7 +4H2edPpsbW4ggaDabJejlAKGxwZQng1dY4VDKk+jwERq1r5LovxY7raffMQpmt++JVwgpKUwfqSTIF +GOAEDE9MUci60uW2u8bb3+qplISUUNpiJKUen2M0bT8vSOp0FLiCKV8y/kK8fEEawlWoqPSXMuZQLA +WZ6AXwAuNI+CERuuY7QIGkSKZnmLq6qsHk9de+3D9jrs+zd4DXyVOGSDpywiJZrxCAkP16vjd7bW4t +JiSiFewpORlKlp9mUF/lZFty3sDWUZIVhbml2aj4a55KP9RKsYjiLVEJOKrrRuObDYb8c8nmh/Mzml +YWydstQkGIjTaxWUmXV5QFAZrLCpExHFEpFO2tvsUhSUfZBRZjnEe4z3WOIwpyEwgN5aCgKXcFRYYM +nIysp2Tp4+lXm9+IU1rdLa2GZ+eKjV41aPyQZWOmsN2c7cL1hCccq5k95qMtQsX/tNLzz3Nvett6kp +hsgxX5CRpwtLWOgtbK/SmRljudTi+bZm/7Tp++EM//UN3v/ENX9Kt0UtpQOHybCKNJBaU7GF3yftly +C0NovTlFFoRx5q4FiNUILcDnC/3YrUkRkVx5e1XHjKqaj3V8H/sPThPolKwDqcVSmuGQWvxbJ1xsfe +Lzvhs7eTCn/UurjPo9kikRkW63I0pRW4zdBpXyU4KIwIukiSR+k8qkn8t1NB24pK4tZQeVc/WCIgkU +qQYK9nu9Dl/6hwLR0/x2Fe+Nr292fs//cD/VEKdWNXASaxzyDQhrY8SD3rkgz4+BKJ6Sk3rcp8nNQ2 +tkMGhnCSSksiXgiMTFCE3YApMM8F5QzfLwDkSrTA6pjU3w6HbbqTxqvu/wp49n2Zs8nFURBtJLmsMg +AwYt0NEvjrMhC9HJkLl0you8cu9vDT4+Uuo8PB7v2ypLIBkSBj8R+h7tpLaaGS5wwiyMrJN8LJZWGE +f5oqZh5uzN75FLV38+Y1jJ1+zeezlmlvZQFnLjc+9TKgn9Gopg7SgW7Nli+kFsTF4Z1CFoDaIKPrQR +9KNIja0YxtHMThJYQu8gjxWbHjDVihoY2hbT88DkSLoJt88efJvLvzHT37lvte+5aH7X/PGvzp0+Kp +8vtVlz8wkcSoIhUV4Vy5dhMLLCEO1yxMgXcn9C+dO/cLZR/72ttb6ecZWF2jUWyxsroGucS5zbMcTL +DTrHF/vcizXTF5zAz/y0z/33vvf8q4vqZExXCX2UwGyaGvHvzoiQdIsB/WozJgsDXAtEo0mRRpPLUh +qaZ+QrNLoDEh7OSNyjCLvEEdj9PQMfRGTJgEhsqExYKW6jKpTNxqGV5QAVxWmOYTDPZBMpMzcePWXO +iq8d00Uf2ysw8cFdRlKoKJf0GKblhwtV0kOokaDYiNHNPPbOHzgF5D8hiJAQ4Hw9Is+cT3FESjI6Xe +atDsZy+sXWVg8x8mTJ/Y8//RTP3r06ed+cv302VvrxnPt9F4iI8m2+sQqoqU0jWCo5X0W4i5JBKMom +jhaARpB0rSCNJLk3hBisMrhKBDOoPBEKhBLyfb2RWwcYeoRvVYTuX+e5jVX9mq33Pz3+vqbPuXHx/7 +WqKhSbSpqQtCoDhGFKPMy2C06lyXK+r3qRf4vMFDa6VLFrnt3F7qjdETUbH0t3au641H68716892Lz +x9j6cwZzMwoubAYEZAioHND0R1grCcScRkSqSV5bOnnnn5e0CsyBtaSFzmFMRgcJihyZxmYnH7IyHA +4IIkkPevwto/JnHrumWfesd3z71i+uMGhw1f9j/Hx+KGD++a+fOXB/b0D81PMTo6iRelPGyqvWudKe +RpIWNsYefnFF//D+sJ5+hubbNqCXtZjzfTxhSFHs4Vkqb3Kqhuga01e++YHP3rXfXd+sTGSoqLyFho +iH4KkojL4Sox8qW+RogJMqmyHshFO0aqGVnW0Aik3gT4+DEpARTmCLzA2J/aq8k8Rl+CWoC/np6piV +2P03byeNIWrrrrqiyNxMrf88unf3G63CTpCpTUIhl6vQKkC4wP9Isd3+6XaIW+xZ6z5Hxhp/Gdq8fa +QvSDjBlvdAaub6ywuLXHieMHyysWD5y8svGd9a/0nep3t6zeWl1lv9+j0DY2ojgoRtaRGXIuoW0Ejx +DRkgio0iS/1mlJ6nHRkyNLzpdreogQhlLxMjUTrGOkNWEtuDIyM0LcFPQSN6Wmuvvte5m6/9a+Yn/t +tRka/7aXaSdQQQlUd4P+85eA/S/Hp6mOo4QS9y/lYiHLnEfB4pQtZq32TvfPfbDQbbzicpv9GjzZfe +/7JbzUGnQF+UFCTklrQKKvKwBEV2BoMMGi60tKWBd1gyK2HrJwdCxlwXhC0xIlAESwZbgd2zm354IW +U6KRGXKvTrNeQItDe2HjT8RX1piePr1DXz39j79TIQ1cfPvClwwfm2wcO7GPPngamKjypyiX70umzH +3vsG98cW3jpGHZ7i0VnYFDQVeC8xUURG3nBBdel0Jrr7rrx9970L/6PTx268RqsKOU2oZp7yvarhqx +sisSQWLor7EUKv0OGEL7S/YUU6RsoL4hTQ5wURFFGnEJaEyhtCcEipdgxtRVVyAjD2WPn5MyGE8nO6 +R6ErhJgS5g8GZHM7pn+lOm1j6yY/k9ngwzXGyB8YIYWg1xQGMtmv8fWoMfmYJuQRiy018bueu39H5M +y+fjK6hZbvYyVrU1OnllgYWn56jPnzr63Z/a+N7f5VYiI2vh+0pEcHxLWVzp4sYV1EYVVJHGd0Vqdt +O9peEVLJtSKiHEUUkoSytnRKUmmAjJSeFmyFIQrXQucKhOelCj3N0EIVqRk7MBBZg7u783fcN3fNW6 +/7dfZv/fv0XGJhleO38Ojr5Ix7hAIwvez+Ia2eWJ3XJO4JMUJDHeDpd1eIj2Mth6OrrtmcMWe2c7Ku +P/RlTMLbJ04i11t0xhYdAaiACMKullOHjm2hWdbFPQpysAOa4itwWqBEVCIQIEnrzxUdtmrVCOcwAw +GeBIatYTZiQlGxiZoNG8g67Zpry0/cGqh88D62qnfP3ps6bHx8RN/MDU9/t8OHZhbG2ulzI/UaYZB4 +4knX/jX33z8SczqBZQ15L5yP9MxwQvyvMfi5hbLwJ6r9j/31h/7oQ9dcdMRgixDtSQO43IiNEpopCj +DkeXueLBdaLMSnhBM1S4ObQk1wkUEG5PGhiQ2aF2QJFCvS5IIlHAVxStUFILSRPiyutu13S7/G7cjB +g4IvBDoWIGFuBWz79DeDwlv7l04fuamTq9PGicsbbYRGx16eY/17gar3XWWtlbp+Iz0+Cgn2yv/ujU +986tnL6z22n17w3Zm/+X6eu/HVVI/UJgR6hP7acjS38X5jPXVRVa3umxs9xg4S4ak188IqaKW1onzD +JV7oqDRSjMWRdX2WiGjCBJJUIJcljtQiox6JEmiMhOjbzJcsIhIoiKNP7CHvXfewewdd36Z/Xs/Q6v +xHYQEF7BSlmLNIeGimv3F7iFdfB+Lb+hfuds0dvcH8jtlGRG0xOOQRVFQTx4hnXlk5g33f7Z2auFjS +XP0dZtPH20Mzq2QVC+OwxOkJJeBgXP0Q0HXZaXhrTHYYMgU9KyhXxT0RCDDVlkJ5YLZhdLuQMcxuSm +t17c3N9jaWKeWJAzyjEbSojVVQ9oBSgac7d+ztNS559z51d959PGnnhodrf3heE3/Pw1RvPelxx9tP +XdqCd3v4vMes2mEzQtGR0fBCzpZn5XMMLVnmrvf9taPvPrtb/PJ1Dg9a9C6thPWqVS0wzIqCfbye/T +yHsiro6sA4urULW/NcoYboJRBi6LM5o1A6aFr9CvM/sTlXqdlJTZ3LZJ8dXQNvU9D5b8dEFFEPFb3j +dGxj3gd/e1WzyB7jni9YHvQYWVzhdXeKhuDLdYGm3RdhktiXri42Jrad7C72S2WonR8fmRkDp1OMju +zD9Bs2IQ8H9DpbLK5scy5c8c5f+YUnc4WUsB2aLM90BRhCpHUEap0IsidIE4EDSJcGHrrSNAR6IBxh +pAbkgBaxeg4wYaCbihwUUx9coT65Hj30Nvf8HezV13xa+w/8E3SuFy1VWwuVBXeMgyX8t+DhKK+j8W +3U/yvFJuKS21pDpgqe7VAIGOBkIZISKxoPdI4fMUv7Ze1drM2+p6t5gn6Z5cYrKzR6/UYCInxUBSGL +DfkpsA7h8XgsPSFpBMK+nj6oQwo2Z3EQ+U5Yge9yrouZmnxHNZ4Zmb2MDmT4MfGaTVToliSpglWxRi +ZYAK0B93b2oPt207b/qdD1qHbCfjpq+i2N+isr9KxA7quoNUuVzCZtwShefX9D37mwR/8sa+N7jlAo +cvtaJlcDtFw82ov6QEvfWK96/AqsccgKsRZlsigji1RYlGJQyJIdFQaIklLEmuSeOguuptZcinJ1Q+ +PAOHB65KzuSNZlEBR2dh7HA6PR3uHiGvM7N/7tX7PfGZpZfPDLzz7EubiKpvtTTb7m+TC4FIQTU1ja +hLVbFAfn6Q2MY5qRfON5gyNxgzOxOSZZ21thbX2NlvtDdbWl9jcWmZtbQGzdgGybXyw1HTM+HyT+nR +CcI4iLlCRwQoFqSh9aaTYSRKVPiBdifIGF0jjlBAEnTxnIC22VWfk4BwHbr6G+cMH/zS+587foTXyF +FqXaySlsKoE2iSXi6hF+F+XCPhPKr5hVK8YBi76sLN/kG4YKlruV4oqxDIiQmpVtYdNI0cbj6ZXjz4 +6Pzb72dG5/f924cnnX7f6zPPNjYXzmFDuzYrc43JbriUEmEgw8NDH0cfRw5GhyAjlMlqU/J7Z+Wmmp +ma+luXm9ReX1xlkjvbmKu2NDc6efpnxkQ5jI03Gx8eZnZ1lZn6OWrNBiGNarRbpSJPcW/J8QNZtMzq +1h/1X3sz6hUV67S3WF49iLq6w5gy2yHFopqenOodvv+8TM1deR89FeClLVkxF89A7ySRcXmhi11ch2 +GmgQ3XzhaEZr+4TdB90j0jFNGp10jhBS0sUlfYFWqvv8V0NjW5LHqPE4UPzslM0EHHJe82WDasOl1y +jmoL6RPSJQnXff271ROv0C89TeEfaqtGaHqMxOUJrZoKxuRnikRGCroFISVyMtbC+tkKv41ld2uT8+ +UWK7jprG6usbyxBvlUC+DXB7IEx5qcmeM2tt27ftO+K/3cklw8tPXPi79r99rJ2zA7jybJQtsZKCax +z+J5BKkEsA4oIGSS5s7hEE81NM3vtoe78bdd+ffbGa36N+Zl/IB2BuHzeXmg8ijx4nCvpj1oMxyouy +6T436L4dkaUncK7/Ea0hSOOy+bUIHDBVQi3onCGhqpRmAKlJGrf3kfrU1P/cWZsdK072nx/fOocRx9 +7EhEGBDK8E1gvKKSgB/S1p+ctfSwZkOPISk/qHSLrvgP7/9t7fuzHf+Tw4StrR186+S+OHT/9/nNnl +968cH5ZdvsZ7c4ZNhdzTp+D1tg4k1Oz1OojpCPjjE5PMTY9h0wSarUacdKildRIhMDbGlNTMHNoP4s +LZ9lYW6O3vYG1GeP7Z3916vDVGzZOMdUtF1fPKSkRd0zXEzVk1eyZCnSRpXJiZzCLKwv24T7SIvFYB +tjQQdJDSkkUxWitKUUHsiS+7xC69I7RbbjMkLFSk1f/qRue7jvDYIwkJs8z4qj0R+22l1i6cI7jx17 +ceHnp8V/rydO/NH/jDHEtZXJ2htHpKYyUFEJAHJMHgR0UbHc7FLlgdWmT5cU18oFje6PL+vomorOMk +I6JkRozh+bZe2CaK686sH7zLdf92ZGrDj90xdz8tw7vu4LNl07z1e1ttpeWvyGK8MMiSKy0ZMZQRxA +FhcsNIc9K4XMSQSzpmRw/EtPYO83+O2+0h+679b9G1x3+HKO1p0vLCE0QEuMcQVc5vUIi9K6iC7u44 +GL3QfXPh7jof2rTGYZxwzJclmwqBNQjtQN+yF18NUnZi3vjUaqBkx6LtKKePDF2+60fODI7/18G55b ++7WbhH1x8+oVmZ6tLxwuM1Kxsr+EixcBZOi6jR2VgFMr1glQRloAQnkMHr3jkne/6ASbGJgevfeDBP ++l2sz85dux0dPr0ubedOHnq/U8ce+btx4+fiBbPLrHR6bDRuQjGQ22E1vgUoxMztFqjjI9PMDM1C3G +d7cJS03UipQlxwTWTY1xcvoB3BUoYrMkOfv2Rb9x2eunUUzfeeB1HrrmKvXvmqKsEbwzBOKJmCs4Tc +JgwQAWPFgkylETzAMgoYmAlKI0SUVkMpoOQEuMKmmkEQmHMAKUkWkOcSGr1qPRWHapFUHgPWpdB1LJ +KRaJ66XYsDytrA1kRkK0JBOdpdzdZWDzOiy8+rk+eePat65vn3+9s/917r4EknmNkbIxac4yB8XQ6A +wqnybqWzfYaKxc3ubC4ysZam/Zmu7QkGBSopIbLB0zXNVdecxW33HLD8m133vQnt9554x8evmr/d5o +jdSIt0dUYOj45xp5985xLjj4SJ+6H6yHFDzxWBApnsXlGZD31OCGSgqCgiBWmmbLntmt7+++8/m/nb +7vuVzly+FtEYIUlyARdcUu0luyW2Yldxk2XuSMKf8lWAtBCfz+LT0OZsBwAACAASURBVO4C6OR3X8k +Vy0eLS9KKy0pXVU7TSPLq98tljJyb+VYtTj/xwI//yPIL84984JmH/0Ff+PZ36Pc6yKRGUJCZHoUKZ +Uiq8NhwSQ3lQ+nVUavVnoiiiFotIY5rjI6NMT42YW699dYvb21tf/l1qyfEyydPv/npp154/wsvHH3 +nyRPnaqvLq9Bfp2N7dJZPQdqg0RhhrDVGo9ZgtD7C9OQMzVqTYiynNdJgZn6MRiPFu5yLFxc+uLm98 +sH8+MbaqZef+dMn5qb/4ODeuUdvue56rjl8iInREZAZOEvh4lICJFRJYneXoGxvIdEjFH6AcwKtU6Q +MxFGLOB1FiII0rSNVjoo0JbuvVHsMD0Yty1iXIcteCHBWY51ExhBH2U6RImUVVhLobm+y3d7g1Omj6 +cLiyXecWzj2gazYeHNaD+rA5BhC1ksdpWtQmIIts06/71la22Zpqc3S8hbrGz02ltfRSQOfG+j10El +C1AwcuXqe+bm5hfvvvvu/XnPN1V+45rorn5+fn2Z0cgQdicpzRV6SBkQNmvVxmvHIE9guFBKdg0sCk +VQI4bG2oGMLRCTQtQQ50eSmN93P3juv+0Lj0PxnmRp5lnjIolQ77BO5SyrmX7ETF2E3HdrvYMPhu0j +S36dVw3fZSO/OFReXO36JV0C0QVyea7BjixIlPp6dfrIxOf3B21utz4/tm/93anz0nc889i3a5xdLG +7gKXDGVM/LQor1UYghirZnfu+epVqtFHMc7XLE4UdSbMSOjNSbm6uGuG2/56psfeP1XT718nmeff+n +BZ5958f3PPPfsu86cOTOy3RlAb5teb4neWrn3iZMmzeYIWseM7m0wOTnJ2HiLOJqjXo+ZnEgBSz2RU +4TiQ93txQ+9uH6qvXr++S+9MD350L75mW9cd/XVzMzMYNIDpPX6DkkhVEz44QtgHChZYyj+Fq5OsC0 +a0Tyx6BPEFkJb0toE9foqOkqRsgyNNDsuARWNbXgQStCilL04u47SCikdLu+ytrXC8vK55vnFUz+wt +r70gU5n6w29bItaU7N/dpLmSIPBYMDqxjqD7ja9osfLp86yeH6N7e2C9dWM9Y2MPJMEp6BnsEWAIie +txdx5+w0vH7n6ii/ed++df3TjTTccn5o7zOzMVBnuWSVeWG8qdU5StpBCQZQwPbqXqdbsU73gifqO2 +GhMVAJDSil8GmGFIY8CphbwNcc9Nx2mcfdNn2a0dtxgCaJE5/WuOOxKo11BguzkMu20mrtjsnc17+H +7XXy73S3DK6/of6QAd/9V+HKBLQQkHpy85MNTAF4GWlfs/9at81Mfj0brt6/3t/adv7hE3s/QaBxmJ ++bYV6o77yAIQZrUj05MTPWVkJVdXUnKds6XangEYyKFNGJyb4srpvdy1/W3fX3xgaWvv/jSS5w8ffy ++xx9/5H3PvPD0BxeXzmNMBh4Ku83G5jIIRS+vsbVcZ2SsxfbqNKNjLWq1mPGJBs36CM36CIn2mKw76 +oreB86eu/CBhQXbu7D0/F/MTE19ft+1b/ofY2MjjLeaxLpGpMZRjO1wu6X3BEcVTVbmkrh+naLXoL2 ++jXAdlhZ7LC4atrZAKEGeS3xQpFGCD+Hy5z/EzN2AYDJULZB1lllcOjW2sPDSD62tnXp/P1u93/suQ +lqmZmtMyZg4aaCUZqvdZXFxk6XlLfqDghdefpGzZ5dYXytv6iIHBiXpWuk6KkkYa7U4dPB6Xv/gA2u +ve/C+qw7u38P8/DSjo02sGi3hpgB5btBaInVSuh8gLr2UacTY2Axjo9N9o7eOCt87EoVSHeO9x0ooE +uhJWHV9VrbX6YQVbgldZurymiA5bquSqg13qu5SjyleEYR2ufHoP3bdhO/zzRfkZWyl3Q57Qrxi9fA +9UCJZ/fIYiHfxTi1gfcmxyhWkrfTZycP7fj2ZGvm/iygwoKBGhA/msotWUjLbhZDU6/WjY2Nj5e0aP +EKVLIgkKsvbq5I9P0w3kQHGR2PGxw9y7aGD9Af3PnL3rdc883v/5Xc++HebC2wYhxXVHR2AOCZb79B +fg/5GnfbKMkktpjnaYHZ6nK2pcQ7sn2ZyrEE9UaSNFm5E0h+0G2tbF378/PLJH3/66GI+PTP+36++8 +tDnrzx09Vdnpw5aFfcp7QgCWmsICmvqmFxRdGFrpWD9fM75hSWeV4ssnF3h9Ol1Tp2FsdU2Dz/83Pv +m5q//g9vvugPnHPVGRc4OWVV8A5xbY9Dbmt5eXfvhxYVT7zt16vm7tzrnSZOc0TFNrS6QKqI/6OGCo +b9tWN/YZPFCxulTm7x8ZoWVi1t0Bz0626Wdu1YQm7KbSVSCkopmrcnYSJMH7r2Hn/5X75u64urDDXz +RQ4nyMCuFHThf2l8oLXa+/1C9R7p6O3WrTjrSgISjVtojTnu8lmTK03OG9aLNUrbF6d4qS7ZLv6l5V +96lr/wVEo+uIt7kUB1+WZHJaq96qcFUwxMwfPeF879F23k5ZeLy61hcsur/7gV89fdoqKOrwiSrC6k +0862gOOMNuXf0XX5gc7DNZtEruZvSs5u5WAbUKowrJTfNZvPE3Mxs+QIPBY/Bl0bTrtzkxPjSrirVl +z6jgyiF0doYN191xR2TiSYtchpF1Rqb8uVI8AgfkWOwnQFbnRyLI04jVhcuMjZWZ3VxhumpJiMjmun +JJhNTNUbHRhmbaJQyKhuSbLD87hPHTr373KlH3MTI7Ffn5654aP+Bq/5ydn5PHpxCqEl0JBlsxZw7u +f6+Yy+8+InzL69z8WKPMxcdFy4Etjuj+HyEtYuCL/3pNx5aXOp+4i1vPfWJt7ztwT+opSCUJ7BJ0W3 +vLfLVH93YPPuT2+2Lt1y4eA5vc0bHDXv2TVNLFcFl9Lpdup0+vU5gfX2b4ycv8sKLy5xbyNnahn4Gh +amCeT3UY0FCSpABrWLiuNRopxq6G+t0NjcIzmOy4o4gwzdiFaMjTSgMMopKBLwM5qms7cMO8dsIqEV +gmwI/IrBNfyKvDcBAB4P1sFJsc3Z7hVOdiyzQZgDEssF6dxN8OCC8Q8uojKCuXjkpL38fPfKy1zl8r +/ui2qSpf+aNwz+t+Pylt19cdiL4S9zd6id38+GGp4by5pJLkKgwJlFZaAuB84ZUlgLefNDbu97eoJA +Op6BT6XEqDyakkAQpwXmEkNRqjTPNZhMlSoUxIlSaMkmky3jHPvmO7AjKYEYtS8UB3rG6sHDT4OI6z +aK0LweQKiV3noYcxU02Wd/cQKYpmTVsFz18rtjM+mytdVk4tcT4WDkH7t0/xtyeUabnxzh81X4mJkd +I9AqtCVcJiQfKmrNvP39h6e0Xlr4DSv3Nddff9tDE+OEvx/qK7qmj+W8//a1zH37hmaOcO32WfrfN4 +oVxCFOMt2qMjyiMz1nfXOSr/9/Dh86eO/VQWnd33HTT4U/t2TPynnyw8hPd7YXrev8/e28eZFl213d ++zna3t+XLvaqylt6rW71Uq1d1awGEBwxjjywghmHMIDuMgcByGBs8eBx2yGMTMTM2HhxjkOzANjMsM +RgBZgsQGgNSIwn13tXd1VXVtee+v/fyrffec878ce/LzKpuCUd4PN0KkREvKpeot9x7fuf8lu8yWKL +bXWTQ32VqtpSKFwEuy2ltt1hd3GJ9tUOv63j55cv0hpJW27K5k7HdglEOKjBMNCocCef+OE3T9wdGE +5mALB0yGgwZjQaMRiPae216bsTlSxdZW17h6InjD0Rx5fPjMsHIHGx+SD2ghCOoAmMzAtCOWEhs3eG +aYCfsteFOn7yfsdTrs5cPWOu3WU53WKdLD8g1BFqxurQMg/SYiRQm8IxGGSqMsLqENLiDscHbnWbqM +IjkluRTinfLyecPg+VvPr4p0RWHc+rxB1V5IYJUtENLJUc7jqjCghmpIE3Za7fmBqM+1WaNkRG0W32 +w5aknCx0RJwrOthCCIAiWwjBESllAj3A4Z0u2uEdqTZe05FJ5BJ5QF0aYWPC7exgv7mlGFU5OzpLuD +Rn2U4QvEBAVl7CRS7Q3NKqTv6LC8H8cefs9Toq/vNtpnR72O0hl6e7t0dpJ2d7pcOkaRBU4crxOc6r +BfSeGLCxMc+zoJNVKiJYBAkGajuin+TdfvvLcN19XN8gHF7l6znLp9T1uXFpjdWmJne01dtNTzM0cp +RrXccozOVNlPj3O5evPcf3aDf7X/+1/+fif+3OPfvz9T72HxoRDqxZJPGB6VhKGEwzyFbrtAZubfTZ +X+yxe3uXSG1tcuQQ7m5Bn0NqDYQZBBWanZ5icnfuPR46f+Ln5o0f+wx3Jfd2rVy//++Wlxe/a3d6i3 +RthhynSe2Kj6Q9HVGSITUfs7e1hrb/HAcMyTd0PPJsVR5E0Bal2DJaAEhdbKPlTBVdjKYtysnzE6uo +2W3mbFbbZJScTGieL589bHXa3ttGOuUiWGFDn9/VUUqB2iAT7pzZRbmkminca24l565Por0JcuhV3M +QhLzRLvUGMjEqVASJwQ5ELhbYFXbLf3pqYDhYwcw05BXbniCkJ4Xzr6mcPbLg0KNbOqyNddGLBrYoL +CewiZF7o6Vhe7amwDjBKFjK/N8dLhhGIoc3zg2N1Zv23OpcwkhnDQxgQZg1GfAZJBugdpyAX6zB+7/ +eX7v+cjVzdC9RO91P7E6sVrxzbPX/3u/vrm965vrD60trfJVs+BNYgduL6UEqs2F051OHHMc9eddU4 +en2J2JmKmCRNVmG5W6bfg9bNXWFpc5Nqi4/zlHa5vbrLSWgfbh6CBVnWkrDNXn6GuYDKZZP7Ox9ncW +eXcyy/xu5tfpOL2+IvfcTuzM22E7ZD3HNuX21zdqXJ9cYerVzdYXGlzY7HP4ir0BmCMIXOG6YVj9vT +xE585fnzh3915x22/ffr03cOTp47RbNQRnYw/+n3xssr4rqgXY7KQCd8kiCzejNgx2+QRjPp7LC/dQ +OX5bcpBRQBZjg+H44ofV64cAcTOEXtLb9CnUp0oHKNVHTVznFbl3PpVUtY3r/J74TJeAVagbIzwAmE +1FZmBcOSjIRutralKs1kIZgRh4RBcME6h9AlRXw2mKfgvhyv7z0W4/Jf8kqJUf7IZWTZq2jxFSAhDi +KpwNC8pJLlHSchGB7iOahRsBao4PeW+QdXhwtnhyjRHlSh+xFjavGjOxHF8LI5jdLVGDU9NaJwvZpF +D59lZ7rGXRzx05sHz3/YX/iL5/DRDB7tLG8ujle2fXH7z0k8u3bg2e+76he+6tr32fVt7rcd2d3fp7 +XQYDoe8eQHWl7a4cWWL4wvTHJmvcmQu4MTRCeanpxB5he3tISsrPa5dGbC81KY9SBE+xlRrNJLbmGr +OUw/qxIkhCD2GiDCcxVrDyaOW9uASb15a49q1GsNhl531RVavbLJ6o8XrK0O2tmBzq7CH9wLmZivMz +N2ZTs+e/J0773rg380fOf67p06dyo8cOcL0VJPGRIUg0IUO6F7GiRM3zu8ud8jbHruXkfY1Uo8YCk8 +tqjKSRbMryzKstccO0ypECTR/W6apEERRVBiT5IIgKBoyu7vbW6urS+x0NshVCcn0viQdKxwZ1lncC +IbDIaPRqOkK0We8EwcqUuLds87fkeC7iYh7uC1++O+iFN+xeRWbE0iBiTVS5xjdoO8yonzA0FqGXRj +0YOSgEYh2oosdTpSOemNFMC0sFouUJVMAhRB2H4blhS/k8Kyb0UJidOEJUNUhQmkyGTD04NqSyiCnF +iXXZiencI0ZUiRHGzNU7xb4xx5je3tz4/rm4k8v7Wz+9Hprq7m6vPodS1evf9/26ub7r1z9Mq1Wi5X +ljNXlLaJgi4k6LByBhSMzVKMpdtYkmxsxi4tDNlspQyRBOMVko0mzcpJGtU4sFFoWAsJOCjRVjA6p1 +yTrO2u8dnaNuN6iVt1me7XD5jK0N2AYFUSA6emIqdnj/WPH7/7NE6fu/3cnTp7+7NTMgp87cpx6Y4p +ms0kYjMm++T5KRmQB1Wr1mkDhnCP1tpDmS0f0bI8hPfbsCD/ssbi4yNbuzkxSqyKDoEAU7LfLvkKmp +DXWOryXBKEmy4esbyy31zaW8GRUwyJzFbYAxAkh8V6TYbES8mxEno2qztqbrMtK3fp3TQC+K08+50G +4IiMXzsZ4i5aeJNAEypJoqEpNQkiGI69Z0m7Ods9T07ZXlQ5TMun0GB3si7mOOkS88RSuQXCzB7tWq +hFHAZVanQmhqMqCIJypEO0gPtKg09ZMJNU17Rx9NySXIYFUBRXMx8wmC0ydmOdeMoY22+22Oz+7sbz ++s1sra9XV1T//keXl5b9y9erVb1peucH29iK9vRXevJJz9compJuQV9BygV43AKoYAiJVoxbNUw2bR +CpAuCHWZmQ+I88dLhe0O46dHY+zk+zs7PLFL95ASks1grn6BCdOzTBzx5H23Nz8rx+/7c6fO3Hizs/ +NHb2N5vQxKtVJtEkwYbzfKMvzDOsytCzk1kubNpKkumbxpM4zSlMyl+N8TppldO2AvWwAuWZzc5PRa +NQQquzOGQ0+Rwh1kx/iPhrDg3dF098EApdBng4Y9Ns9QUoFqGpIbSFhIRghUUhVQOl8AMpbJC4uOuk +HXvE36df/WfB9hZOxBB3afEQ2Ghg7GqCcxUhPJBXOD4gDRSg8TkJQiRANw+pOj4nAp5HICEgLFAxmn +04gfCFbsd8A8qWr7FjcxxX/uiyPA22oV6rUECSZxXmJMSFGSAZ9x0Slxky10ZImIpGmWAAcKBQLrVB +SFKYdQcRE0uDo1FHS2/vd0YBf6PeHv7C1sx2tr6/+hc3tpb+ysvbmt1y99LpcWrzGm69fZXsrx7k9Y +JaECXTSIKomJGqSSmSItMDnpYU2MEhH9PYGbG0N2On0cDJmonqS6ckppudy7r3rju37Tz/66bmpkz8 +3vTD9J41Gg8bENFG1igkSZBABhsz5cfe/uHraoPCF0psohG+F0CSVWguhyF2hJGfTEdYPGdi0ICS5o +tHVardJ0zQ+cK+9qZ94SxOvtChwbv9zCeGJEkVzKkk7kyF6NKIZF6OIXIIvx1VeOLwez3EzvHVGlCO +C/fGC//+4Xfk1nXaOZxH+rQ0ai8NmKaNhT9pRH+1yYiWIPQhbOBNpmeEE1KOAOIiQ1jKZKBeSgstQt +wJgvS3HDmX24YoxhBcl87vEYgkhVKACwiBA9wdQWn0hLFIWEnXGC5T1Q/ojbGSQiS4oVN4ThuqQXY/ +EOYdRGm0UQSOgWoEpBcdPzg/7w/f8Sub6v9If7OqVlWvftnzj+sf++A+/8Jd+97c+z5Vr24QIavUqj +eYcYaVKGCdEwQCtDHme461gaHP2eh3ae3tsd9qMrMd7S6N5nA9+8CGeeOruR267febFo3OzNBuTiKC ++Lw6MAGc9zolCeFkKsnLxj2FXGlkqr/nSqVUQBNEwy3L6o5R2v0uWDnB2jx5tEClDn0FqabVaDNORy +qxHK4/NHVp/FWUhIZFS7KujC5EzMVHlxPFZN1iu0VkfMV0R+FDhrMbnisw6BvmQkacAROQp3qbS2xz +MAbZYiP8fuihfC8H31nDztzRdCtGhUEoXBkbFpjBc0i4nMuBkhpQeHUqaMWjl6RpHM1JSZanFu0ODf +nnAxBjvu4eEcguq3QEQdao5aZuNCV3Pc+JhirICm4MzEVZqajM1er1dEl1IjRlbbCR5eYNH1hXS8hQ +2yNJLcMVJJXJ3MGKRECYQqYTqRJLPzE3/5ul73/ObSdxMX33tqlld3aOWxDRqMfVaQlSto1WEFKsIn +2BTT5p5+r09dtsb9Ifb9OwODk1gakxOz/PQg9+Yvu+pR16caAKqg9AO0gLQ7csY8FIU7lilvfOYh+i +xBZy4hFspoUrfdUUQhIVIrfeFdLzR5EIXU4Ryqi100XARQlhT8ueULtJODgHy3a1dx3JDdi5HkhMGj +lpDy0bDwBBy5fHCgpQ4KRiMUpwvMhohi9peFrnrLeNpf8tI/es47RRv94PwJfzOEQQBSSXKGpVE6Sz +ADPv4HMIIrPAYA9XEUEs0djQicBmR8oH0+WAfn7evfFtKoXAg8SZ8aYBZOhX5EvVtgnCgg7AmS/dcJ +TU6NIggJpUa1/fY1EKaR1j6lIZjY0NItY9qtkUjXch97wSMBF22GIVCCkXmLLm1COmI4oTmdHM5jM2 +pSlUzORkTKAkiQ3pXdGj9XuE/kEuGfUervUer0yL1O+Rsk+NoVCJmZhs0J2dX4rhgdWXCIRgVkhPuQ +CO4PKCLsYsYa74ckspDgvM4Uaa5qSfPXNQbjhilOTkCYwKE0Phc7s/UpPeMRiPSNB1kuUUbhfPuEMD +hoATz4mBDtNYihCqV8SxZ3sfZXhAmOdNTAm8F3ilsLsjSgiAsFEQKbChLIxmZqbdTzxbvnrNPviOv6 +r9CoScL9rtzrqjHrCXQauBdTiUMMEpST1Thg+EhCQXKpTRCzWQlYrZZZbZRqwibg1TkWRmA5UnjRKH +FaG0ZeGIs++1w3iGEAiXxUrTjSo3cK4TUmDCiWmugg4ikUsO6Yh6mvZqgnxap5bDQUyn454VXRKG/6 +Q+5Ro5Bghn4FOdHeDKkLNgYRhZ2zWEcvrBwfBbr+vT7WzQahuZETCVJUELjc0E6yun19mh1dukN+gz +SId2sS8aQZjPg+Kk6tYZAB/aFKC5eV8kAhy9ItJKbFJcFoJVEF0rB+9A959x+MEipca6QpVhdXptIR +zn9NGOYpfSyEb10yJCUgS2A74M0p1avoLVuj2u+fIxsGm9+4hbWi/cHgectUnlq1Yjp6WplomEwxpM +YT6QzarEj0hnVGOamJBM1qFc0jVqMkG5QKKEfBLgUEv8uOvnekeAT4qvnoUoqhJLk3uGc6zqXY7O8u +BkelBKEBiItCRWE0hIrT6QELssaNktvfmI/dlySeGThOckBYxlf/L7gBSp0EG4KrZEmIEhqqCBBhTG +mUiv+jWOQimFvME+vD6lHe3lI23Gs1ywOlK+4BeNa8ujEWOChtEpz1nH82MJvve99j3Dq1CzIPrnbw ++YDbJrS2W2TD0N63ZxWe5et1jrbvQ32GGBRGJmwsHCM6ZmYkycjji8Ev4UowCSisI3cP/GKE2osoJT +DIaMAX/oXCiEK3Ut54P6Rjzzd7mA+yyzWwcg6Bnla2qod2EEbCXEYoaXaPLj3f4r+ni/YKO6QlqLSj +iD0jSSBWg2qMVQDSEJHNYZaFep1zUTD0GzEVBJDGOiuKY++cfA53l1f8p16UfW2AG2/D/cRJTYzDMP +dMAyRCoxUKAmqtKsKjcEoMMITKQiFJe3vTbs0KyDzohjmukMXP983Az1UCYiCjmRlaQRpgmVfmANgk +mrhU65DVJQgggpBtYpUIb3e4BS7e+Vr6QMW9L7dZqnjViLn3RhLno/tV1RZcxaSgqE0GKWpJcH/ee/ +dJzdPnprC21263XWs7xIYTxgG5KMq3U5Gp9ein25jGaAJiMUkE/UjTDdnmJk0LCxI5uaHn1a6j6eHw +CCo4USGF7cGXAHBE5Spsh+feGJfmGlcRWWDjN3N3VODQeGjMXIZgzzDygJDK8vucagVlUoFpdTy+Jo +L+dWXnBfjgU+JzZWFGUwSi+l6TVFvQC1RVCqCJIZKpQi+Rl1Tr2uqNUO9GpGEwS5S3hTo/yWEb7/ma +j75dk0XX8jcHZ63KW2o1+vbExMTyLRFYAO0A2MkJlZEgUD5jFB6QiGpGEVn1J8bDfrgCgHew3g8dQg +Tvs9WFjdnw1ZIZBhfVXEFGUUYHRU6MmhMWMU5j6poVNJilNnTg96AOBf7SF0v3Fvhup6SWSHJAenDf +VrW2BNCjmXbsUg/JFDDmePHEs4GHW4svki7NWSyYVFimtZOznZnk/ZgkwEtCvnYKlLH1KoRlcQwN6u +Jky36o3O/VPXZfxMGM0AFn0uUtrfsfGOe9sGpJYXCy4PAs9bjfdFAGg1Strd3Tw/6I1Jryy1mHLqFC +JHNc5RS1Ks1IhNcVWpcFY8Vlt9uEbj9X+43wZ1FSEtg/FycSORIk0rDaMg+CdkpUJEjt4VLUBQbtJH +bX7nB92cNl6+Yerr9FghESWU9jivk0qB1EXxRpIliQxBZAm+JjSIS0EhC+riFbNgDm6O0vAkbWwR9X +uIK2S84itpMlsEHYaV6oT45SbaxjcwsKgebK4hibOrQCVQbEzgdnEmHGXG5Y4jcj12kkftLeXy6Kmz +J5RSl37uzkDtbaIcIifcjhN2j01784V73Oo8+ukCrfTv/z2fPs9u6QKeTUq0cZ9CpszfcwIkO3u/hh +CUOKkw2a9x9ep57Toc8+LChUt1kdfmLfzGJ/Q9X6+ankRW0CN8m4yvO6XF+JoS6CUDsfclHkID09Dt +ddrZ2zwwGRcNFK03qJNZ7LA4jZUGUDgImJyYIw/DCzXxU9zaoSsdbUlPAW4u1GUK6hTAQiAgSYVDag +RdI47ACZCTJRoU6tQkEQrA+Fsa5yar6Jjfir9dRg//KfZiiVyhL8Vu1LJXC+nL2JFTR7NASLSyhURj +h0DhiExBJfyrr7UE+hKBseZdiHbJEuAh/06xhv9O5byITRq82ZmZoL63A3gAVV3ApOB2Q+2JxRY0GA +62fHHQHNEYpuAqoAmCe75/fHJLS8GV9JQ/SYO8Q5GglEMKSDzqMeivvWbzx4r+0bpWHH54jTB5mY2u +RZ7/co9O6xGDUJc+n6bOOEF10YDEG4kgRVTOakzkPnJnjsccrpOkNdttX2N1q/kujJv4oTOLXURM33 +XaBKsEGB8FXSLvIg8ATrrB7do4sT1ldWWdna/vJ4XDIcDhEmgDlMvK8tx+xWkOtVmN+fp5qUnl17Mx +0kx/0ftXjbi4DxaHupLd4lyOlO6WNgFAgrcUgC689U5zbBIqRKHC7URSitVweP2nJLHtXdTrfseArU +i3PLcXXWy6Ml4IwjG/EcYVMBwQ+LAwy1Njt1JWdT1v40qmAQKq7RoMejEYQpQU73BYkTbGv+RCpogA +AIABJREFU/hK+5UX3hfUEiEC/0JiaZhAn5L0RYRiRCY9TpkB6KEUQJ3T6g+M7Ozv3zXd655hrFt1ac +3PDYjzu8OVRMtab8SWKR2kQwuLzPq2dRbbXz//aXmeRRn3EKN/C+WV00MPEcM/CJLXkGJ5prq/sEVY +TGtOTTE+eJB8GrCxe5Prys7T27sIyT3MqLwSG2ssI3vy12SPVe4KKw7s5xs7AeHGoDzROMQ+QEM45l +CpSRetS2u1drl+7dt/29u7x4TBlMBghRPG5rHcYrXEuIwoDZianOHbkKNVq9YXieR1Cy1tOO/n262O +M7XUO7x1KiruiUOHSAG0NJvDoIECnKZn3OK0JpcUTUK0mhJG5wf4Gwj64gq/3Od9N2Na3QZqPZTaMC +qhUKleq1SppFKFlisodWhYSgUIUkgtKgHSeQCtCqU7naVrkdM4f+Ao6QLmipym+yuRDgNRhL6rXnw+ +TyqNCddHaEErIlEFLCp86IRmMhrR2O9867HbPRbkFLYq/SV92zcvk2XNw/OKRWpT1ngORF/qYnW1WV +678qxtXz949N2epVjwvvPIlXnn1DVp7cPwkfN//8N/z4P0f/kJ/aI699Orzp5zM0mMn71g5ceL+F1Y +Xt5779P/9s5+4ce13o2dfuMLxk6d575nbqdciNtZ2SNOlu6v1o/8qCNUPeDFfSNU73gJq520RWMUFT +NMh7c4ua2tr39rf65JlGWmaQiD3RzZKKWzmMCakXq8zOTn5fBRFPcqxhWYs3aBuOvXcIQsC5zjolZT +mMkqp08YYfKiJCREl+yFNDakrRJVH5HgfkFQiVBheKe2a3irJ8vUcfKmEEIHIS2076UDZ8g0plJcYw +Mkqo2T6YrBwEn/tZaqjPpNpiwSL0Ak2jOk5zcgIKgkEPqeRbZ+WS+cSrl3o89BxkJJeVNzqyIXoVJI +GpVmjUCgUykOMA+eRzuJ9yiBUn8vvvv3RvSCm1e5SywRhmhMNU/biGdAJQS8jbw8/Mrix/s+j40dgr +o7MLanyBCpkLP0yppBpVfyYihYBFYYDB5kkSTTLN85+54U3f/Ov1yfbRJMxV9Y2WVp3PP88rC/Ct// +5v8wHHv/vvvO2k6d/tc0WJ2d2aeo+jfn3kMk72V44TRwOL/3Sp65/evH5F3lhokYQTnDi9pijJx071 +5/jytk/+OsPnTn9Wdn8xKeFq+NJCjsyDY52KT9skNSQGLJ8SKwt3o4QvkKNGV54eYXnFrsf2RIJ7Wy +dIMgZDrdIyKkJR3fURaEZpJ6w2WTmtuOfs5FEkBMYRZ5l5Kbg8GknitvuKOaruksuhgyVIaSB0TGZ6 +5LLi0kwsXTa9S2IBayyRMZhzAjLHmGWY1QNX2nSiG9n5ugDZLJ20UvPINujYirlri7Ah++aTod8R1/ +9K7i+jAtkqSCO44tJkqSBidBBSBAnJElCHFcITIRSCi1VaREsMEqj8A+TDcCm+8+/70ki8v3BrvSH+ +y5iv9gXUUJSq362UqsT1yqEcYWwkhAkFUyc4AVESUJjahpp9Ad2O+376PZBCLQxhaTdeLrrfIkNdfv +i3hLFKBuRJAFR4nn5xT8+8ual135+cqrB1NQM7c6Iy5fXef7ZC7R34cyZB3niqff965m56V81kSSKE +oIgwhgDQYCJQyYmAm677bZffeyxx/51pVrn1Vff4E++9CJr67vgAyq1CWwOZ18/9/OrK+ePONoInY1 +RbuRekDmNJN6vWMc6OEIZEJLdrS6rq6v39fv9D0hZYFaF89TCGpGJEEJRD+pUq1WOHDnGfQ/cz9Tsz +GeVUiVOU2CMKQcxvrgnkkNqYqqUOlL7521u+1g3elhIhwkNcRLSbNap1RIqlZg4DjGRIUkSqtUqQRy +RJElqguCiQh1o+Yxr2ndR0feOBZ/jLXPwA4/NQ2lCEIVUqrVXTRjhhUIYgw6KoBOiMLwX3hagaTxae +mzafcx2d2DUBj/c/5CeFFRhcy39W4f9Qgi8KNOhKP5MUq+2giRBVyJ0kmAqFVQU44xBVRLiRg2nNOu +t3Y+12i2wviB5HkbtKwFGFWMUMYZshXib41yX5ZVzvHnl2U9nbjtqTlZxVvDa2at88ZlzPPvl4mmef +vrDFx5/4skfaE7VIQSlo2KGOV5MqtCDWji5wJPve/oHzjz02IX19TbPPPM6L750nrX1PaK4Sa0xQ6c +zjG6sPvfpwfAysE2WtwslOVFH+zoQo7wpEC9l17nQuRHcuHGDxcXrHxsNh8Um5cRYtIogCBBCUKvVm +Zqa4vjx4zz00EOtWq32GUqWw1tXQH4YZV8uR40UukTXFGBt5wePKe2JYk1cjWlMVAoScawxYWFZHcY +RSbWCMYYkSV6lvI/ysBOUeFeVfO9M8N0ceG9VvPbe77cegyCgVmu8bOK4sPnwpoRIFfWcQqBK5TMlP +Eo6+r3WU53tVRhsAz0UQwrPpBy0f1uUjUCUQ93SGlZJdBT/uqlUEHGCqMSISgyVCFOt4sMQmSTIJKa +f5z+42+kkfjjEubHmalnMloiCYi0U8zSbeeIoZHn5As8997v/aGSXn5qaMXT6O1y6tMTzz17m7MtF2 +frwmQ/x8KNPf3Rmdr5QeZJ5oaGBwjqKBexSnC/QJHfeeTcf+sZv/eip2+5nawv+5EvneOXlK/R7gnp +9nonJOTZ3XnlqY+eVf+TcDYKgC+RID4E05MMD52gAlwtwmvZOl4sXriQrKys/2Nvr0u928d4ThiFKG +YwJqVarVKtVpqdnOXZ8gRMnTvy6EALrCnn6/Xu7P4axRckhDy9Hg9536+1j/R6IwVPaeII4IIwNYQQ +q8CgDKpSoQKEDgwkiTBChTfgy3iORCHeIuCvkn518b2lyeFl66ZTpjjroCUsTUWtOPp/UpsDEZMJgy ++6hlJIwMEShIdKa2BQP8vSDw84WpB2QA7QYIkixpAdpJrdsuuUfhBB4KcAE6Erll4N6nbBeR1Sq5FG +MjRNUNUHEAUGzQW1uFhGEtZ1252+1W3vFmWdBOFHIse/DyYoOqMcirKPf3eHNN1/4wOLyy/9QBy1U0 +GNp6Qavnr3E66/32NmG0/few3/1rf/t37jzngfPCRPgpMOKHHyAkmGxoFVhDZX7YkzeaE7zwAOPnXv +6qW/5G82JSV5/zfLl5y5y5foO3b6nUptFBzssLj/3D7d2X/uAEB1gSDYqHKZiU7x/l5fluAjJB5LrV +ze4dOnq39rYWq912x12t3cQOOIwwmY5xhimp6ep1Ko0mhOcPHWKI0eP/vL4RCyCz92y6HJgdJDqeIM +kLIW3MqANooNUow8GgSQIFTpQxXglcJgAwlgT1xJ0FKLCgEq9ThTFz+M91tt9rua7iEP7zgbfPp31r +av/pmGrLzg6VOuNL9eaU4i4RiZD8nIZSykwRhEbXULNCumHJFRz2ajzKKM2uAGSERJHZn3hYeD9/g7 +8dpvCPus6jD4TNOrng2YDl0TkUUAWB+QSRBQS1+tUpyZRccz2TufH11bWJ7NuVliiydIkJs/BFZpcu +lQv8S7jueeeSc6ff/bTQdwnqmQMRi02N7d5440lrl8FEygeevCDv3H/g0/+9ERzFq80QhgKGSANsrB +GLi0A8SIvvA6ihOn5Uzz88Ad++s47HvmNzh68/tomr7x8haXVLlo3WVios7NzmVdf/6NPt/YuJLCHG +kvLl5msliCFRiDZ3cp58+LS5OrK5o93u12ydIjEkUQxUVRIvhtjqNSqxHFMc2qKe++99/zMzNxntCl +QB7mzZd13q0qmLaJ9vAK8RHpVBKVrg2s/qtVoLggVJtQIDVKN0JFHBA4dG6JqBWE0XhkmpqaJK7UvI +03RUBPyJnzn133a+Xap55hrJzgAY1pbcLaS2sRLjekju2FtChdWEabAiokyzSx8yMtdVUISB+SjvW+ +huwODNti0kJPwGntoxufLhkgxEjiMrhmXH5qgVvs3wUQDWa2QxyGuEiNCg4wCbKBQcUhUrZJntra5s +vGJ9cVV6HPgxVeqtY7TrOFoj6tXXuONc8//Yq+3OTs9WwGRce3aNS5evMHFiyOUgofPfGjz8ce/4Xs +mp+bxSkPpI2cxxYkkA2wxiKOQTSzx+kJD0uT2Ox/iqff/199zzz13bW5uwzN//BovvXiRlfU9tNREs +WJx+cLsl5/9zC9urJ9D6UHB6csOBtM2g34bLl1c49xr1z/RaQ9qaZqSjQbUKgnVOMYoQRzHRElIFEU +0mk3uu+8+Hjjz8L8xUVgO7YtxwbjuEzd12Q7VfmPLMgfCD7D5Ls63v0UqSxBoTBCgAomOHHFFokKJD +DVhNcHpAK80UzNHdnUUv8T+ehIH91r82cnHzR6yb9cFLY02ZdEKM9UGyeTM58PGNCJpIEODCCTSlLo +issAcClU8jFHkw+632+4O9DowZjl4c0id/wBgLTw3nYSWwkfAKtBJ9ElTq+7JaoKoJahGlbhWxSQRO +YJcSiq1Okkck/WGH99d2vimvNWHgTsUyQ68Jx3s0dnZ5oWXPv9Dw3T3IzOzdRqNGp12j5devsBzz2+ +wtAS33XYX3/hNf/67Hnn8ff1qfaJkXGhSK7EEKHWAQMHbW8FZ4AOmpk/w1NPf3H//+7/1u5QMeOlsh +z959jyvnL3G8mKHuenjJJHm3Lkvf+SNi1/4oe7wGkL00QE4nwMw7Fk2VoZcPr/yTdcurX2830uxmaO +7t0tgJFp5nLNUa0lhKprEzMzNct/979m7/c47PmmdY5QVxFkp5KG6j30FMz+OOH+wLIQHXA/vWnjX/ +XZBgROVRiINhJEkSgwmlOhQEyQJ6BBhYmoTU58vLOkk3vp9ZgnvQqDnO0MpOvzC/nCna7/KL3oVRpB +lKeiA6WMLf2CDCn1ZqES7EuSL8OR5yjAbknkHWhHGAaGR7+vsrN5B3gPlwHqiMCoZE2IfMT+eOxzGE +7r9YTv4QPaIzL8QSYiqxqhaQrVeK+pCDSYJCMOQSlQhRpHu7v3UztKqREjIIB/2S3MKz/rKMl/8/Of +ufePCCz8TRpDUYhZvrPPqq1d5/rk2F87D9DQ8+eQ3/JMPfeM3f26i2SB3GbKkOykV4q0iyyDP80Ntd +I8qxRIRAUiwTrKwcBdPvf/Pfe7+B5/6J87C+Yu7nDu3xPK1nL2OZmZqgUo14MrVl37mued/+17LKsg +Web4L5HR2u3zhj5+XL714/qc67QFbGzsMBiNmmg2UsHibEoWKOA6IooBGo8bc3Bx3n77nX3T7/Z5Si +sAEN3WTnbVFiedFybIo9eUOS5/LDG9b2HzrDmz3fbIo/pFaIQOBI8X6DBMaknoDKw1htc7CiTuJk8Y +foCvgBEoeCMwqJf4s+N6263KLpEPhY1VeKKVBKWRS//1gYhIbVBAmAG0QsgBDS63QUYCMIrxRqEgSV +iTCD7+TwW6B8xS+8PF0tyJa3P57uHXsaAFXQG3+qYyClkxCZBygAo2OA3QcoLRGh5o4jEh0RGDFA6O +d7qdYb0N/hNYG8pyl61d57ewrvPHqq79WaWh0JOgPc65e3eDF56/z5oVC2Pf++x//0mNPPP0Pji4cJ +apEqNLk0LuS/+1LnIy3SO9KnNqYpHUw4tABRLHh9jvv4f0f/PA/uOPOO7/UasHZ167z+tltttYE2kw +yPTtL7tpcX37p164uPotnkzB27O3ucOHCm1y6cOVTm2ubDzgHRsfkuaNRj1HeEgaSiWYVoyXWpcwem +eV973+qNTM/908r1fgQUcnvk1jlTbo64/csbzbWsT2gA77znUKMSsU0jdAKYWyBYAkUXhU247nXoBJ +0Uiepzfz+fiGMRPh3K6fhHePz/SnIcun30ymhdLGz1Zvna3MLr/mkjgwiVBQhTFCkmkajkwqqGkOs0 +RVFpaaQYu+7/d4qpK2igD9kqeS/ygU5LHbliu5DR8fBT+g4QEQGHQiCikHFBh9IlNbEcUxiQoyF1ur +G9y++eflvd9c3QSm6ey1efuVFXn311U922runZ+Ynsc5z7doGL7x0lddfg0EfTp48Mnr0sQ98x4NnH +qZar+83J6z3+6lTAQworKIPZmf6kAit3BdFcQLmjy7wwQ99M08++Q3fYQI9unChxzOfv8jLL6+ytWG +pV2eQWrKxdeX0y6/+wSevL72C911efP5P+OIzf/y311dXvr/X77KztclgMKCeNAi0Q4gUE0AlCanWI +hYWjnLmzIM89sSjP1Ft1jtSqQPTSSkPLCmFKIx0PHg/DpJb2s++hXdbCL/73YIRSsgi+JRHBUX9V3R +6NUIF5GicCgmixmsyqZ+HALzaDzzBuzPtfMf4fPJPAb0c7g1nAoKkxsT8wm+b+uX7ZRZjjEGZUiZAC +YgMMg6KeVokiBLBQHXPDPpLH0hGG89QP47wk6W68a2v7/Z3X/E2aBupwXn5z8jU9/hMPGyVRUqFQjN +yOVaUilxKYr2g096jPWz/5MZgd22O7i9d2bjGl5977qOt9vYPHpmfQZic1s6AS1fWuXhhh70unDjV5 +Mmnv/l7n3j6g6szc3NF3WVBaUNui8G92Mc95nhXdka8Lh7i0NUt5N+K/6cEx0+c4IPf8OHVa9evfu/ +nv/Af//2Fiy2a05cR2vHex26jWm/S6fW4eOmVHxwO/GePza3/2u//zsvfc/7szk9qMcug7+n2d4gCS +Rw16HevUatG1OtVlPYEQch977mbBx564KXaRP2fjSea42iSZeA55woVcSnK2ytKROchfp8c4fMtvF/ +/AOye0SItwO5SgnI4leJQCKUJdIC3MQxDEBVUUPttZAzW7F+Tgs3gDwLcf90HnzvYCQ/ZiN1cB/r97 +NMKDWFEdXb+16szR35ctCvFridTvHPksjBK1IFChEULWiYjlMhwdvNjjJafwd4GagLBxAHO+u0CkJu +tgsfq2VICyv69nPT3clkYbQohsSOPlQ4lix3e+eJ02lhbZ+X6+V9Mz4nhSnvtC0sbN35hfnaS2kSNl +fWrLC1tc+3qDsvLYLTg/vuf+Nmnn/7GX3nve99LY6IGvrRrLv3UnbcF+MoP8aR4nxUB6kUxHxuTT8d +plixqJ0dGGIa899En2Frf/pWlleWfffHl83/tjfNLCO2ZnJnixG1NZmccmxtv8MrZF3/hmY3X/87rr ++z8zMZSTmymiaMmlaROEifYzBJHiulmjVq9wmg0oN6scccdt3P02OzfQwq8z3He4w+deAV9aoxuyIr +T2hUzVS98ybP04NpYv4n3Gx9DtNAqwypTsBtUjpBDRFZHSYEyMcNhSOYVQVAljCd+vWCsqFv6CYeyn +a93ASXBf8LMRcp93SGLxCpDZWLq2cmjx18L4yZSRXhvEDpEGEOuFM4IZKSQiUVGGWEyQunWX/Xp+hH +SNRAdlBx+hUH/oS5soXhcEoCKh5QSpdRnlFI/JQLwRuCMKCSzAl0Ag73H5ZZBv8/a2hpfevbL/Mbv/ +PavvvDaK2smjuLmzDTdQZ8r19c4+8plzr5+jdEA5o/c/uYjj7zv++99z/3UGtUy6Iqgwkmw43nViCj +KQWSF6rPzZVEqbybll4tOiXKIo+DI/DEeefR9PPDg49/fmKq8ub414I0Lq7z6yhKbGylRNMH0zDxRF +MXtdvtnOp0W2zsr7LYXcW4bE6YERhBFCadOHCWKNVk2YGp6gvc+8hAPnLnvp6qTE58Bh5ASIcUBRQl +3wBmEcrCe3fSGiw2lB+zg/fYRz+5fFbKLNjkmKDCaQlukHqCUwUtF7iTD1JJmAh1WX4uixrNj256b7 +AfehQP2d0/D5dZUvBSv9YfYlQ6BrtaZXVj45Xp9FmUqeGHQQUgUVwiSCEKFiCUyBEyKruTESY7NNn+ +I4SbQRtD9yrZQb2dj7UuJBekJAk0chz8iQ/W8U55cOVSgMUmA1II0T+mXgXf1+jWuL96gN+hTnWgwe +3QeGRqW1ld5881lzl24wd421KameOKJb/joo48/xbFjx0owcY7NC61Qm5VBpASFwdUAIR2erKz5xP4 +xvX+9nAPlcQwRWKTWIDVHjhzjQx/8Jt772JmPBqFme6vPSy9f5uyr19jc6DLRmOXY0ROcOnU78/OzR +LECOcCLHsPhDtZlNJtT1KoxlSRkemqCM2ce5EMf+sDzx+6640fQemxyeGiCVwSeFKrIHjzF5xjX9GW +e4clx9HC2g/OtH/K+hZJDjPFEJsAYhTYCFTqkVGXjRuK9wgQJjebML1eqjXK8I99md3V/Fnz7L/q2i +IPy7Vi7/6fxWNYKCWFAY2LyF2vVCQITI5TGmJAwqRBEETowyFAVKhHaQiggBuv7H8+yTgIpvrBe/E8 +6mcddxfEJKLQkigOklj/gsLnDg1GYMEBoRZ7n9Ed9NjY3WV1dZZRlHDtxnDvuup24UmG31WJlbY2rV +xdp7WYkzRoPn3n8bz7yyKOvnbztFLWJGqExCFnyFFWZQI0vSz7A00f68UlyCA10eOPQ5QjGF3WhFgp +vLbVqg8cff5InnnjstZmZmb+ZpnDt2hoX3rjO1Wsr5JknjitEUcSxo0eZmm4wGLbYba2R2wFaKwIT0 +e12mJyc4MyZMzz5xGP5kbvu+AGUgnRQvE9nb5LoU0Lt19JZNhZtyt8y+3UuxbpBYl3/454hQuZIJRB +aFcoFZtz8Vihl0CYkiGJqjQmmpqZ/ERUVPixfI1/qE5/4xDuQduoC5CoPuuPyUMXlpS5nb4XTQuA90 +oH1El9rtLZH6cMrvn+6l+wQz3YIKm0ikyN1FVwdTANbNaSVjGGlRx7lkVJyoG34jMCg9GzZeJGkXpB +7gSu9rCUjsCOEzRAOpC9kY610DEXOUFl80lzt7PWupp32R6elRLRbdLdX6Yz2eG31Gp+/dI4L3T1qd +9zO9Kk7IaySecHiyhoXr13jxpUbuB4cq8a/9ReefupHvvPDH+au+QUCpxEmJs0FmOKiCJ3jRQoix0t +FZg2hW6fd2qNPjXpzChFmBPQKx1eZk7kBSkuMC9DESKsQowxlJBWl2DbrrG6tPLu4eP2R9ra/Z9AVB +O4YWh0jrEwhKgqf9GgPltnY6uJHQ+aqUxxJJqjkOcGs476HTnPmqYeZvfv49+m6+kyqLGkg8TIAYVB +eoZ1AO4l0IJwtJPyVpS/fRIoIKWr4AchUI6REuXOMss/9XSfOfptUu8W19xLPEKfaePZw3tExQ4gT+ +nmT1c0a1fojvzF37MlPWVtD6hCUR0hbnsLyJnFQ946ne++WtPMrAlzEWx5Syv3H5MyxfzsxPUcQVwr +Le60h1BAqqBgINcqE6CBG6QStQqSUfxc/mMB3y/QtO9DUPFyUe1EQCUU5fxKy+N6LciAMLrdMTEz8w +sTExN/PnCN3FhMVttHLa+vsDQYktTozs/M0mlMArK2s8vqrr3Pu7OtkHYgjmGpO/3AtblANq8ioCio +Gq9AEaK8LZWerkFYjvEEREagqvp/hcomRIUJHjI0mfQb5yGF0AtbQ7aQwUoABk7C33eP8+Wu88OzrY +KPJk8fv3IwjydraLq+ff50bS4t0ukOcVTQnj3LqztPMHq2jQkOGQ8aa6lSFhRPHufPuuzh1x51/v9J +o/ELRryxgem8RpZVvxfAq6ngMzrGvbk2+TZ7vTuR28HeldwXGE4UUAVKZQk1NGBwKoysIDN4rJhpTN +Kdm/q2RIYEOb6YQvTuX9zt78v3nBqMR8oJm8NE03ZzTskMlFqhIgTLFqo4kVBQyUUijQcUoUQ2lTBR +CfhZ9tAQQKpwvRg/7IwZfCsp7WcwYhCpP6bHaceFHVAkDDOKZYbdba+/uPbW10+Liles8/+p51vf6J +JNTzJ08gYlDOu1dFm9c5eqlC4xaXZAw15ylYap/TaUIMRIvuH6WiVxQSaoIr/alHIQXYBXeSlzuyXM +QvR3a7T54TTWZQOoaiBghE6SICi09IRAuJEsFO+tdXn3pDZ555sv84R9+IXnu7Cs/trXa/rTI1ZN5m +jPo9un1e2QuJfOWI8ePU7AeY/AR/Z6j2xkw0ZzkPQ/czwc//BR3v+fen4wnm/8A4XDC7WuPeu9Ronj +/N/mSiLINLMFhEFQQXpeSiW2su0JuL//PgpVv8r6FwqK9QYgAUHjvcCWk3ooGo1FIrxdTb9x5dnb23 +h9RqsnhTqfYZ1DfjGzx76KQ1HwNfe3DwsIJqs1jnxz0Fj7p+tuIpA1iVHQnTApRDMaAUgXx1Osy4Wj +/GM7/X7jd1xBJ2RGsFqcGY1V3PRauvAl5IUqiiwfCkh6jtSZM6j+aq1ZweWX94y9fvMz6Xp/a7BHmb +jtFc2aenc4Gq6trXLt8lc5aIdwchwmJqiBSVdtd3v2JN8+++eNpK//U4tG1n5u/vn7u2G0niWt16hN +VVFLcJSEEikKvBlUnlD2814g0hjwqNh4LaR9GGYxGltWVTa5cucaVNy+zdGPxvs3N7Y+1d1s/uL2b1 +ZYXt9DKksRVJpsjttsdLl++gTWS6YWTBGGM1k3mF+6hvSPYFpvUjk1zxyN3c/qhB/6PaKLxo2BJh0N +UGCDL2b4U/q2LWx40zYpB02SR0guHND3IlshGV+53buXHtOrhshzhBF4U4xyEQhAgVYQS4PM6o1STp +wGN2vwnA9Mgtx6txjYo4mtiPb/rg2+ffHl4+q0TRHX2U3Fz4X8aitXjqbJIYZHGISoCtCsq81JEUwi +P9znQBj/6x7iNv4SsI0QB+C1GvxonwIlCAkK+jXWZRJUSCK50ZlRUGhNMHsn/pqhcS9u5+DtUatTmj +lCbmQcTsrXTYWV5g531bcigUokIZUx/tw/ZgMnpGLuX1Vqr2z+2ubz7YxfPXXmmeXT+P1QnGr83N3/ +03Mz8DPWJBiaJkIFGakWc5vQ7HqSjZVJUp0V/aNnZ7bG2vsva+g6t3S5raxv3ra5sfGu/O/iItfYDo +/6QdCRQgwq+a+i7AcoqlNAIB8M+7HWGfP7zz3Pv/Q9x2x13E9QSmscGzBw5zqMffD/3v/+xn5RR8qO +FOJEniCtFs6QMd7CqAAAgAElEQVT0u9CH8JRe3Nxn3G8PZeWGpgfAOrm7zCi7+I+lWyIQe0hhSxn/g +yGrUBpJBWSAyCdRKKJodrFanfkUhDhfKoB/FTiZe5dVffprIfBu/V4YAbJO1Fz43zO3+s/T0RCpIY4 +sVIKCkqSLG+d8wU4vArCPEIOP2HztexWjn8cUO6uiqCVUKS447m8qcauf+7g+yYqftEIoxeTRY8zfd +vePNo4u/p1+PMHUseP4MGJ1c5tLl6+ydGOZdJgRmJiZyWm6OwMG3S7Ga/J+ytbKGoOtPVLg/2XvzYM +sO8/zvt+3nO3uvffsCzBYBhgsFCASkLGQEjeTFBHGiu3EkURWYkk2VYq1REuKTiKpXLTlhFoiS1YiW ++WyltiyRFKiJHCTCHMndhDAYJkZzNbTMz293P2c823545zuGVByySXHBinNnbrV042pRve95z3f973 +v8/weF8X3TZ95/j6VZv9HZ6Z3dmZu9ovNbufJuJkdj7P0FZmo1eWW27q0vj5xNsg066SlpTeZ2uWtr +enBi2sbN507t3pHWbg3gNxX5AYtNFprBlsDptMpURQxm87Sn1jGgy2SDLrtBluTCSvn15AbE5Jsns7 +MXmZ68yzsqkBX7aVlOruWflhuGza8QEiPFLLaKPgrssFw1QV/BaZYX3Rqu8E2AVZx/vR/L7j4kKSP8 +EUdRSbrrX+lqQv1GdyHiCJvAykzvf0f0tFcvT2OK+XL1WUe5NdMtfy14vtPXf2CAiETos6uD2X2uh+ +YDooDIk6hOQU5BeEIqkqt3RbXCukRopo8uXLlZ6Qo/1Co+DIyQ5IhRIwjqofC1cnB1rvPP/MILytOe +WFgamDoecg1mix05+nML7K2scbZlQucOnWa8aW1ykyrNG5cko/6NEXMnrklds3OYCcTNjYGmCAoBBi +lMcFz/rTcp5N4n4j0d6AlPlIIrZhpSfpbA0IQSBEzzQ0hVFuz8WgKKLyDWCcMBiNcaWikGd57GkmCx +JPOzZConPPDdaTTzPYWyM0lJtMpTnhefvkkcaPLHXfeRdbusbm5yUtnVnny+dMPfdP1Bz4cAc5W/Jx +GGgESuS0sCY6A2g4jqoFMcieQWwXwGIpiFWdPzXu3+jNajomEqYxG23lhMlRUOwHeawoH1mnGw4Qon +T09M3PoQ9DBWomSMcFXvk4h/qNGy9eK7887421zG69+FHi0AJ3NELcPfDA3o1/yOiFEmxTlCmlTVTz +MbV2fkFdScBEEf3lJePWz+O7fIXRBtBCigZJRxVgh4HZSCq5u2lUYCGQEQWI8DKaWC2uDxRdOr/z6W +n/MwZsOcfbSKufPn+XUmdOMt7YAaDdbRD6nmOZEGpT3aGVxJmc8yMF40Amj6RSnFWNjKI3DSwVSUOB +rcK8gEpWlKEubaB2Rj0sEEbGOsaWrAE5Bolst4nKCFIJunAKBNAXSQJY1SPUMG8Nz2NLhSkEr66Cyj +OFoxHj9MmdOnWRufoHdew8jVINzF4d86jOP/fpc1ji0b8/CpUaiUehKsxlsdWiWsgZRXcl+qGmcr7r +wbbHKZHIGY87/rJYbS42oQAtZAY6pi06Fyg6GxlhBWWqKUpOXTZJ07oNRuhto4J0mSqLqfy/kFV7rn +yEx+3oqv6/Lbmf4c4AbRpZ18EmE1OmjaZK+y+F2lz5HJ2BFUTUplKgCSepmCaGCEikC+bi4zU3ERa1 +7jxKaVbdQRBWhWSqMLypVxrYaNzicKVBSQtCsbw7IWglnV4d87ON/8gfnLm1e3+jNMzGWV06fYXNzn +ZdefJawtorINDONBF/kuKIktzlHDu5ld28OP5lUX3cGhKc922a9vw44bDBM7IjcjfHeErBYlzPOc7z +b1t55nLEU5ZRQGlIliUWgGUlS5YiFYbYV02vFaEoSLO2ZQJYpApY4iplOCzbHA5IkIWs2MKHEllPG0 +yFSRczP72J+bi/exaxeHEb5ZOP1+w8d+bVWo3pNtRA7xlXqcE3na4Mz4JwlOEusJBqJMGucPPFlTp7 +83Pe68vyPtzJLIivDsVRRta2PAFnibI4NEqE7GNNiNIJO65sfW1q6/u+qaL4qvpAglaop15W5+lWzj +Z0cm6qw5Z/KibhWfP/RDyfyajtJjBQx3olV5/3f9qIkqBIV+4rytb1qCV2lpgaJM6AxiKA598rGO9c +v5B+bbe9dIZ0Fux1b7BDyivBabHfxts+AUqOShAtrOZ/74pMfeOHUue9WSRsRJWwNBpw9d5pnn3kce ++Yk2fIc33TbUdtOI9nfWGcyHTE/n9HOUqLgiQOkUYSOFIUv2Bz3afRa5C6nKKdsB1XmTMj9GOdLkqi +B1hIlBTIE8JZYSBqRohEpEulItKedSNIIOg1Nu6HIYs9MNyHuGZqtGB1r4jSj2emxuGs3Nx69ietvO +Ex/sG63xluSvGBaGoKP6XV30WwuMR0HJsXmgUbW8nt3Lz4SKXAF6EhW81E8Qmp88FgfUEgiJdFSIox +lstnnpec/xdNPfuau0yce/4iSQ+a6GY0kRoc6FDMClIHIIWOFlwl5nlGaLkrN02nf9X1pY/4FZLc67 +4loZ6tZZQp+jVbpWvH9pw3Zr34GDJXaP0ZUw9cXvAg3BWFuFcqitEfWtDDhq+G4EJVI2TtJsGO21ic +88aWXeeIrJ97gpum/2t3ba0TcrIp621ERLNZbvLeIUHVARQgMC804hy89/vS9X3r8q/96aqDZnmVSl +pw6eYKXXniO0Ssvg4b77nv9//Tud7z1HbfdcuO4mSXfLIJPk5ai02wy0+yQKMV0PGaSjzHCY5Vnfdx +naqdYTIXFl67GJAaUqpQ+Eg++xJkC6Q1ppGjEmkQHOs2UZqrptBMamaLR0MSJR2lPp9tAtRxRlpC1O +xy64Sbe8Nfu58E3fxv3v/GBrdtfd9sHSjd5+3S0tbU53HqbMR7nI+Zm97Br6RBx1GaYb1JMyzcePHj +9J+ba8iwVQOCqpJtKFKGlxDuLrPscfqvPKy+8zMN/9KuNrz7xxY9evnRqababsHd5gWYjQ2mFiBRog +w85QTpElFCWGYN+incLNLN9v9Xu3fGPEC0QGT7E1d6kHtaHYOsZ6X9o5bti2b525vsLyXIqUuw2Nkm +qFBV3fyKI+fcQJrHzplav1RSsUP2qQkiUCkhpuLxyjrMnz/Lo5y/fduY4v9ZSB/+bW9+0F+JK76bwe +BxKVYRlXEBIBd6RO3j+5dPJ408d/+3cwszcEkFKRlt9Lq2cZ/2VExAJjt127GPvfPubf+6d3/YAzST +6p3fedvRXXjx+/Eeee/GJH1h75Vx7cuEyRV7ghEc2EqSWmGLK+tYWnd4MqUyZDIYUZVHhGAIUdoqSA +i0jtIyQIhCrmHYW0UpjYqVpJDFCBJKGJo4laTOrViY8ndku01jSm1mks7CPIze/joM3HRv2FhZ/Lmr +onxnn/UHhBpTl9OcGg8mbz13aesfWxTVeeO5Z0nSR/ftvoNVa4OzKOo899uxvzzdvP7TQoSCAMwEVS +4wx6KgC72LrzIyi5OWnnuWPH/44f/LHn/g164e37dqb4aaKcipxVkMSqrx6ESomqVA4FzMtUkrbJos +Wy2Z64CdQHfAK79VOvLX31Cd1f1VfWn7Nue9qs9i1le8vtjIikFXYV71SgpB+S2CHAfc2ZwtUrUQRo +U7iqVqkVe76tODZJ0/x9KNnefaxDS6c7t+CbbTnm72Pzy0uV99QB7xzaFXh87yv1Ca2tKyMNI898dX +feunUudfPzC7SaHTZ2NjizOnTvPT8V5leXmHPgeWNd7/9Tfc99M63lTceOUirmTE7P1McveXoH1935 +Iafn59b3Gynrf1JnM4TJE5KchxDU2IiiU4TvLcYW6KVJGtkJEmMEoJOK6bTSul1mvQ6LWY6LeZmOsz +MdOl1OzTbDeI0Jm6lxM2UxmyP9uwMrbkec3t2ceOtxzj2uru4/a7XH7/u1lv+cWt+5m/5KDwsElXIS +NCd6SCC5MLKpd9bObf2PfmwyDaGEzyC2blZ4laP6WjC2oUL7WbauGl5cf7fxqpi7jgPKlIUhSE4R6R +jmOacf/Y4n/jwR3n4dz/yT0+eOPc/SA+znSZzcx3mF7p0ZxrEDY9jjNAWYomQKca1MMU8kTpAu3njD +8XNw3+EnK1VPDF10FI1NxShHg/5GsKlrr5oroqgE9eK7y9cfF7twFB97firXvDwJUJ4g7f+ei1kxUe +q5f47CDnvGaxu8exTZ3j2sbNcPOMRZZP1C5N7NzfG+fWHDn+uPdeBJAZnCVIS0AQnUFoyHOT8yWMv/ +I8vvHz6R41TdGcWGY7GvPD8cZ7/6jNcfOEZFvct8+1vf9M7/+uH/voLNx05iFQBFwxxEpM1Wswu7jb +79x38/NEjR3/xhsM3fXH3nr2mMz97KJuZSRuzPbxWjPKc4XCIVppGo0kkI6RUxHGCllNUcCgZSGNNF +kfEUYXWi2JN0qhy41szM7QXF9h16BCHbr6R/TffxI233bZ1y7G7fnPfkaM/3ty96x/IVvZ5EmFKYdG +xRmhBGmV0O3OMx2W5cn7t0fXB6Lt8XlBiSVsR3ZnraDWb9Dc2sNPp0dlOb2V2pv14hasJKF0Bg+M4g +iBYefY4n/zwR/nCw5/80ZUTr/zD3OWkKqKRxbTbCfMLDRZ2tUg6npIBIrYEpTAhw5gekj000hv+KEu +PfD9yHnyCJ6pOeK/yYzsk9kqP9c8svvB1U3zfkNvOba9RtbW0eCrrjJQRUrZ/QEbmKRVkiqvORUI6I +MeZkqKYMuyXDDZzcDGzrSbCzDHZnPL0V57+4L//5CPDBzL5z5aOXYeKr6S4Si0opoETJ07f8NjTz/6 +KKT3d3jxFYTh75jwvPPcC506cJGq1efMD933wPe/665++55vuJFBgyylp1qjGym6KoEmWdWktN9i9s +P/hY6+/9+Giv/m+l8+cfOvZyxfe/PzLxx84f/b0XZdXVis3gvWMB0OKyRiAVKxTFAYhFN1Wh05nhjR +pk6VtskabKGvR7PaY372bzuwMy/v3Prr7wL7PNDrtTyS95sMMgAjKvCAIi0gEKha42ubjPCwu7eVb7 +n0jq6uDT5fuTz74/MmXfmwwuMjLLz1Bb/Eu9u9aYKY3z4WVSzz62FO/MtPJPnPocO9FpMCG6tyej8e +ce/5lPv3hj/L5P3z47108dfqDDaGxYonEB9xUMt6y9LdGDEd9MqMgNRgc1gS8VcjQIUl25ane9QPIO +fAdvKjyZUO4oneoqIRVAKl6tZ7mz9K6XSu+v/DjStRdNVCnCkmRaFDJizK034/J/x/vYvBxlbKDwTl +DXkxYX+tz/txqDTXTjLYmQMxwY8inPv6pX/QN7IMN9SvzB5YQjQxEpZU8dfI0n/j4p36nYI5ms03Wb +HBxdYPV1UusrKyAdbzh3ru/8sYH7//xG66/niSW+KCI45SAoMAQqRjrIUoqPguj6ndJZma4qXPs4Rv +S2x++c+tuRqNBc7y+8U3Tzf6xyVb/xvFm/9B0NN5jjFmQ5enu1tYgCxY1N7vk5ueWpllzpt9sdNbSV +u981uye6iwsvdBdXnoGpR8ji8ckUJZVYam0eudjmeA0WAwWg0Lhg0AnCTFw7NY7GQxKVi9v/vjFzbV +v3ZwO7u4PLnH+/AVSpTiw3GNtbYXjx1/g+kPLv9Pp3njrzHxGaT0mzzn5wnE+9ZGP8bnf+4O/u3Hy9 +C/qSQEURCyjvEf6QLCKySRnc3OdxkJMM6vSi0zhCQ6ypEWazL4f2XsRm4KrzdL1TaJC2m/3VARfX6a +hv4zFJ0bVNkLIeqOR1JniIEMKpL8aVHK3S7LvkaKLzc8TucvErsRcXOHlF5usXZhhOikwE0/iI5Zb8 +1Bq5DNDzpon//nZUUfPPfC6f6aP7IL5FpMLF/jov/k3v/DyK6dvKW+9hyiTXMo3OXHhZV448RQmv8x +dd99sHnrr/e9554P3MtOJoazU/iDxEjQRpQOlxgQdY4QjtASxjiAofFlFac3Oz9Ob6405eOARoXjEe +EthSnywBCEo8xGXXvwEXbPKof134GdvZ121CZGj6R0ZTbxImUYOKUs0AeUTdARWGMp4vLMB2+4Iylq +LEomKFk2ISBPLHcf2c/ny/WxtbL7nsSefP7l2fjN6KvwuStxOt3eMqBd46ZUT/Pbv9W9RvOsX3nDbs +e/X0zGnnnycL37sY3z1Tz7196YnT/xi25cktcjMxCfZ1ztIK8yRXkxxl2bIxwm5yZnBIwcSVRzCJm/ +ANe//51ty/69qoCk8Qk3xIdk566fR1czVqH7+6UWuDnO6Vnz/f/Q7r3yUyLoBI+p5uJARQqXfi0tvl +7LxBmwDSQM73mI0sozWJ/jcEYqA8pJIJyQ6whlBpCRnT53kjz9R/uI4jNoPdL/1H/vJkM9+5o+//dH +Pfun9QUnSvSMKr1lf2+DFp5/m0tlX6M51ef29d3/Xt77tW8/F7aSyOGl21BZSSKLtzreOqlVGCoLzO +BcIrto/JVFc/3oxzlUgolgpoiitxyyeqUrIG7O0TYlo9FBZl4Zsg7JkOFQZoUQMosJNyKB3On4BUGT +sRFTvkFJ9/WoGnDEQKZJGytLuDnfeeTtrG8NzIoq+6/Nf+Mpv9C+scKbVJA2eTMesnjvN+ePHyYx9f ++hvfSIui49+/pMf50uf+tSPDi6ufDDTEcoEQjBodJ0EBT4vmQ4dww3NsO+ZjGA4gaZuEiVddNr9otH +x95Y7IyjJTpz1X4LHN+jKF+3YfMTVbs0aQ159KUHSfC/Sfl5GvRlnpvTHigsXc0aXxqhSk3gIWtOKu +rSSjNJ5GklK2omY9vs8+9gTH7TCLAxE8cEvPv3Ub5z76suoJKHVeJlps8XJs6c5/eyzdLtt3vaWB3/ +tzW97428evGkJHWp5FGabXQciQYTqvuy8IkhR+d9UHaCJwgePs5YQqlQfESofm0ShZKXOMaUh012ya +JaUAnQXaBELTUBXYMQ6CksLWXnnRI1FrM9ikUuuOA7E10roQEVxzaUQKA37D+zlgQfvpQzmN8+tnHn +Ls8+Nvnv99Gm+cu4MmY5x+ZTpeJPpygrTc+d/Iwv+4MvPPPljq2dO/VALiVQagiAmodfuUGpDR7dIZ +ULw4EeeyaZnMs7IywbNZAGd7tkkW3zvdljnzqolrhXfa92kfdXsZpvTXNlQxI4RNsjsuCB8J6r4vdK +N2dySnD43ZXpxSlREZE6hgqalYxJAK0UrTVAV0ZXBpTVOPPPcDxWKH2rbmEPtBS5cvszpR75M3My4s +HGZFMf933bnyb/x7ne879gdN1OGgFIei6nmTsLXQ34JIULUANyrcyIAgvD0tza4cOEi7XabLK2CHoM +QqCih2UxRCiIZ4S3gEqRPwMYVp7L+1V8FDwrU7oCvmZK6qzg1r0qJuvLF4KocBqEVOpbs27/Esdtu4 +Olnrnvf5NLW/aurq4eLcoLF0yBmVqTYwYBnvvTlpsyna9pZZuMusbco70hURitNyOKUTtaiFzVpxU1 +E6hFFYHw5MB61COyBdA+kB74TZo9LYpQHvQPUlfxleXyDrnxy5/r62rs2VIGOMo7wZCjk7yPt9wUx/ +aXxtM36uqLlW4g0Im8HjNQkokumWuiGot1uU9qcsSkxhSMpPbGOSOM2Ytf17Ern+czzLzHsXyai4Na +bb+ftf+1b3nPn0RvDbLcy4loqSJDHVnFhQtacegNOoCK90zlyziK8wzvHhdWzfOGLX0CrmE6nQ7vdJ +Y4atDodFheWmZmZQydxNXP0dcu8XsLUTvHVPQexXX+vWjcq09TXXsDh1WqsKtG6ztRTgiTWCN3ghiM +HuP++u8Pqky+9Z+PMqScTAomMEd4x32jTUAqz2SdyjkgrkiDQVpDphJlmk1QrvHXMp7M0UHRlglaCQ +T6h7GtCuYyKb0Rle74Pln8fOgQv0dsKmlf9kNeK77WctO98CFff6eutlUfVsyCJlPyy0uWiihb/d8Q +CXZWTxJY886BipE9IZEYjaRDHMT4ouiJha9yHYcm0HJN2uhxsL7A7mydTXY6fOsFYGL719ff84Dvuv +fepvQtNxgZkHHA4rgAL6qP+dgC5EoRtbJ64kk+nooDUHmMnDEcbKO1pdxo0WpJWOyFOBEp7Yg2TwoE +oa/ZlCcHipa6htG5nZ1A56AxBOISMaqW/qVwZf87rWsWu1ZOx4Ei14sCeZe6755tZf+LEU2unT/zg5 +tbW/9lSEutLVDFBCIW0JR3dQJgSgSMloqVTmjKhnTRIOhFLrR6xDbRUhYDXskXa2suu2WP0Zm79X6H +3y5YGmgbCS6KrwMqvis29VnyvzZwvAG4HzhxePUmtJUc2VJKyBEGSLPxkp7n79m5733ui/BTTcYnMK +6ye8IJYC9JEYcsxG/1N5udnaSmNDBJJRDMkxCEmNyWvO3iYxUaDsTR/eMvu3R9ajBOkhcQanA/oVNU +6iiqa2AeB8PXXZKU/tNZWmQNa4pxFKsmufcvcfuctXLp0iV5vlsXFRXrdWZKkiVACE6Z4U+JlIOgcX +F75F+WEIDv1lKtEygiEJghHwBBQtc3H4TEEPb6y5d3Zpm7fKGqynAJjApSOEDyCgHKOXpZx683Xs2/ +3wofsePTmRIW3K2IyKQhFTlckNGoXSUZEJ0lpRzGZjOkmDWa7PTpJRKI9LSkJ2jM7O8Oe6+5iz4G7f +0cke34yJ8LVISq6ErOC8wQpEDWc+FX3i2/QM+A3ZPEFcTUtwFWev+Drs15FHAtU71nFAtEI1RLtZO5 +f9hqL72kkW1glsDqQZS2CV7SyKk+837fMdJtEKuBLQyNtEmuBH+fkY0PwgtKVHF5cxGbqY/RHnH3qW +Q6Lo8TLXdARFGFHyOsFuCBqvkmVXamErnDqtdbCuoBQ0OvOcOOtRzlUXo+UVRc2jpNKEhckcZwQ6Yh +BvglRgVAlaAPaEESoBOfCsY14qP6I6qMItY87YITZwdTInSK8khZkCk+UVt1VLXSF5Chyhpc3WD1zl +ueee5rxpI/S7mPCh7drBJQez4RW3CYLklglZAjaMmY2bdJptGjoGDEpkcGTKEVa13u32WXv7uugd/h +fYmJhIxHc9tAgVO8xwRIQVQMpfOMX3jds8W3T4bab5UpsJ5xUhx3rDEFERLIWljkBpQvjtdF9o7URc +piTyJgkk0Rao6Um+JxBf4qSEik8ZZHTzFKEs0QiRiqFdxJPIDjLeLCJ9sn/Nb44/bZnPjv+wOba2lc +PH7uR3vICemm+0iZGgjpMh6CrwBdb7wyTONqZtUVxmxAMFk+vt4y1ZRUGKarsh8pQrBBIXAjotCJDu ++BrIphgW1Zs8CQIgqiARdXaK/FB44WtBwox4NAEfI2d10rWoSugoqiiZVtPaQxmPOLC2Vf4yhc/xxO +PPcpnPvGpW6ej6U+5snio+u4RGsGs7NKQkqj0zGUtmlLRkBEdFdMUikxKmlkDbQsaqSSRgSiOcJMJ0 +7MXyUb+PmLx+9ujuh3mSrAgPEJUcncp1Dd84X3jrnxXSV3kqyJN62y6SGO2GzEehHG49a3rB6tr7wt +bY9IoxkkHSLSWFRHC1Yk6UkKIdy54WW8XvQuVodU5nHdgJGZsKHMesoP+Q3Yy/ZnR2uY/StrtrSPHb +mHx4AHY16pWwClMhIeGpAafVabPegWvBOLxVSL8KgY6IPChXtmvijcugsUEgduGPHmJU3WAJhkhVNH +RQUe1jSZCBoEXMRJwxDsCoUhYnC/xtqJIl8ZjvUZJjbWei+fP8/gXv8BnP/0Jnnr0i72L58/9hED9S +JHnSOdRIiVSglQqUimJgYaSNISgFcV0opi5dptGHKGEJMYTR5JECaR0SFXtWszWiGxt8300s/9bxbz +s1JVgk+09chAe93Xjxvur3HB5FRPr6r9fsZN4AgkCjBXDldV3bL5yRoitMVmkCVrVYKUauSPrTHexH +aioELV41ztwweOExdeQCWs9zkFuDZMyZ7i++SPr5y59T9DRP1k7c+lDh4/eOLnujqM0980jZmKaXYm +ThpySlGZdSPUY8KqObZAgRXTVKEDtQLy2bzzexRBiJA0QKXiNldRhKhLh69m+Ay8rUbivx3/oajIa3 +DbIWVdzSVmxPtMQGE1Lnnn2eZ588mmee/opnnv8scbLzz71D6bjwf+cSTrBKwSeGE0qNZmKaHhFS0U +0hGK+3aCrU5pS0U5juo2YRpSAt4gAWaxJYk3AoyKJloJicwPOrwj27H5H4vj5oHZSxF41D/Ffh5kLf +7W2nfV2Tb5Kx+d3znq2fpOEr+VdRZ5MVi8dzVcvzjXKnFhHV2BMoQqZ9FTbGikCvj4/BukrQhcgpEN +XzVPiSID1eGvxJsdOppSTknJcdpyQP315de2HL54/9wunz7z4S/NHli4s3bjM0k2LpPMpUhYgFisWp +VTgVXUnD7U/zV81+5NXwk/U1f0kkSCICV6D11VE2HbM2tUJRRK8kCh5BWQSqDSTwdSNqpBDKMGVbKx +f5vS5C3zuK4/z5S8/xZcfe3zX5qXL3xem0+/35bCXAJGsUjcTUlpRSlvFZF7SEJqGUnRUxHK3R0trY +g+JEMQyEElLEB4pBFF9RPBSEJREKUE56JOfOz2X3nLkqGx3kxhyBzUfpj4s/+VpdH5jr3zbBXhltZM +7e7lqmxYqu633MBzvyS9ffC/9LbrOEym/U3zOORSeIEQNSAoVk0RUhelCteohAjKqCq8IlaNdElAhE +EyVCe8nE4yHcZH3htOND5xefe4D/jHzL3oHm7929J4b/v3tf+0W9hxeBj0EkVRPFVORliNkqLDvOJB +U2IsrAKkq09o7V3M2RW1UrVYCvTPkNGBrXikGIad1vrUGaYlCDqEHlOBGUPTxeZ+Lqys88vkv8IlHP +sfnvvzMfZc2p989GJj3SXQ1La1faWsDs8S0dZNO0iAJksh5WlIzGzeYSVI6cUwnTolw6BCq11tWabp +KKZSXlQFWK7yO8ALMaMBk5SzppfPvZfVX5S0AACAASURBVD79J5rohKcSpm+Ha1a3QXut+L4uDn3bs +7N6K1J196qEHomsLsjphMml1b8/vnhZJnlBSnUnrjieAYUlyFDL1KphuNQRPkisr7EE3mNDdecOQlC +OC6zJcQRwDucsRTGltFB6S+Es07UNpusD8qj/vt4wel/aPf/k0u6t3+o0Dv52b37hhFApRA3QTRAdK +hZJC0hROgF0JZUL/qo9p0Xi0DTRuDpQ0lVFJRICFilzoGLcICZIOa32mEFCKMBPYHqeUAwxky3K8Tr +DrTXOnDt93cvPf+5vPPf0U39r/TJ3GF9BsIO1FMESI4lJaTUa9CaBjmrQlQ0iD7H29OKUhaxFL0nRP +pAoyOKYWAh0tN0cE2gNDdmgjAQiq3I1pIqQZU6xcQnOn5YcmP37JO0flFETJwTCKZTabqdpvr4AgH8 +Vi09ckU1eLV/3XOVUDuBG40OXzq0cmmxcVqmHjhB44eviq3LhJKCkrs93onZMCEQQeCGxwhCCw3tbU +a2LHFeWWOkw1lGaCYU1dTRcQATLJN+iVH26PTiwO2PPLHckdvWO8aXJB2Xc/IJSyce0bj0sVPdRrWc +QqodQMwjZAtWugjG3CcxCbOeVIbCEoIEcRQF+CmZYEfdUDnZcubxxYIe4coswzTHTkrwckTMkv3SKf +NzHTvt3+aL/1vGo/4619fV7YnmB66+DzSms9WFaVq9xJGNSH6NkhHGKGRLaMqMlEiIZaOqI+VaTuax +BpgQ6OGIpiIVAKo/Scmf11rEgFilWemSaISKNlBBLiZsMyVdOq3Sw/xANechHyakg9I5hlr80ZfcN3 +3DhyqD4yj70VYEYhEAxmswMNta/vRhPmBGCTCsmZVHTAB34ahsXCQg+YEPAW0+okxyFEFWR1zh0hyO +SgpJtZF9OnueUxiB0hNAKpav7s04li4sN9u+aYdd8g3bmScSU8Xj1HimSe1Ctn5aic1HquUe0mvm8i +kZfEar3hNbjSSAl7HBnFLrWVzlvMDatVl5bQD6EsMFA5IgoJ7Mjys0xzhsmfoNxvkq+tcVoa9jYGq/ +fOXabd6v+iXvLyfD+RNqlRuSZjIas90cEH9i9nHBwVGDPwKSoFsxEJ8QhQRMTxwkdH9PUGamISJWgE +yf0Gm2acYz2hkxFaFnZo4K3SKXQuiKNy0jhS4/1vsL1I7CuMsD6PGe0uUY6Hny7K9o/RSucEuJKNPd +2k+pa8b2WD2MhhlxAiSRBkriKk6sFFDEYB9p6wvrgR5PVTblsPc0ENtYuEssmWmucUlgnyEuPk55UR +TSFrhiYoUCEymbqlKWILQOfM7QFZXtEbidELsKNHfHQ0kTTV5Zhq+RyvIndPWXXkZT2zU26Bxxzu9Z +ZSjZoTQ39eBcwwoUBQqwsRVH0HVEUfUd1BvXoqHHcWY5L3XhJiuQV79S5INKLSiWXcaHvB+fHifXl0 +AY/GH1J+qDivAzNydR0TennN/qjJVO6vcPh6GC/3z9SFMVNwYubiqJgmo/Joo3qeAzEcYVfdLaN8Io +ZmbBPXCSJA3MKhjlIMySLNFmakkQtjgymRJHEZBLbUESdmBCD9o45H9EKAu0VIY4pYgiRIsQRSipcg +LxxHh81KLUHnyBKyYzz9LKI0eo67sQpqeaXflSF6G8aD6qeiygzpKEMQcxcK77XtNvCq+Bwr/pvzlX +HQZfndxeDwUEzyVGlwTpLrOrcu51/X1mhvajOdYSAweFDRafWWqJCwBcG70oiAsPcMp1YnI8QcUzUi +7DBYooBuR/S7Dhm9qUcuq7H4f0ddi/HtNsgoup7OlvNGEIAX+stfbB477HGMw7jm6zhJoGGEFOWjuC +r2V1ZWkajAQ5BPrVMpiXWVVrWae4Zj3JWL22wtTmkMJY0TQHJeDzGW0eSJIzqOWMcQ9Z0RFFlYxJUO +InDN+xjbsHS7m5x4sSEyxvgzSaNVoP2TBc/SBCNhFYzQzdisigmEwKpJGQJ1lXAXKkFiZIgBUorZL1 +6i5rPKWsBgQ+WMjiEFZTGs7W2Rm9r66BaMHdLGX0l1PmWqKhq54ZrK9/XQfFJoquHrpIqn0FV/UMzG +e8era/f7qdTlDV4Z4iTiNhHBARlcHhV6S1FqMYT1nmCtjjrcd7jrcfZkmI6xJqCoATFBMpc4ZViag0 +jM2HoBozEJqprmNsVceONPY7c2GJpOWJ5JiNVAes8LkqQchvs6ncQGN56rDUYY3AuYMqqILyT5FNDW +XrKwjKZTOn3DVJqxtOCrf6I0ggCMaNxyfrmiNGwaoQ6BwRTZaFTfe5cTltXwTFxQxFEio4CzhXo2NG +KI8ZmSNJusetgB6dBvTJhPIRCXGZrWjBs7SdppzSaTVpRRCoVWgaiSCFaGYUtEUJUNi0CWqmK4amp9 +JkuqmRrQlb6XAU2VDkapZNML14kvXz59uae6W7VjCq7owAhNdvJD9eK77V6SMnVbZbt4gsCrNzWK3r +Ga2vvH11YTcR0irKWYC1KS2IUxjmUr9DikoAXlb3HBl9hA4PHuJK8NBRFgTAObT2+CBRT8CLFxgljY +DM4xqEgNAzz+yUHDkfcfH3MgWXIspxWFCFFggkxZdxGUNQz7QpDDwEfSgiO4F1lgK8s+bh6oBKswZc +Wm+dMxwVSakzpqsDM0lGWnn5/ytZmrYuWCuccZbkdoSBxzpPngGojhKclIqJEIWyOcY4YRxSmBG1wj +NDtlKX9TYglK+dG9DcLxqOCc/EScUMz18wq8bSUxInGKY8RDhFJSjzaByIX0Hhk3Sl2ArRUFXYfWcn +5tMNLsKq6IRX9LdzaesJo8H6yzkeErAYMob5ko2vF91oWXz1Irgkp29sQLyungwSKwdZbBmfP3TK5e +JFWnhN7hzMlLoC3Ed5XWQhBhtoB4XGumptZ65BCYrAVOdp5lKhyH2w+wQuNShOKNKYfpgy0gqzJzFL +MwZuaXHdQcGBPi4UOCGmJtcNLQSk0RZRAUSJE7XBAgHdVBzPESF8NlqsbvAYX8IXDFxG28LhSoVSEt +R7vQcoq3dWUpsL2SXBOsN535CWkicB5wXBY/ftmU7I5lOhI4aQgRCCUxQCZAl1OSJoZ1njiSNOamSF +qesqwihF9ihzU3mWypT0ksgFbOcIJsjjCYZmUOTpRKAJBVnoUrxxSGVCKEBzGVTcUhScoj1cOpz1BB +YT2MBliL12Ctcu30J17i4iyj1tZye5CrTu6Vnyv1aRBVFtOEXgVIc7tGEhtOllfv3WyeqEnhgNSZ0m +EYFpN5gjegncIb1GiTo5zFu9KvAfrHUIoSu8oXMnIGArrGRclk7xk0jQcOXojSzfeyKqZcrp/ga18l +UZzzNLhBnv2CbodTxoVKFmidEKpIpxUjDE0VMWl9EIQgq9XvmpvJYQmeA9BE7zEm4ApDDb3uFwRygQ +tHCY4TOkoC8d0ahlPLc4qojhi0i8wFoyB0gacDeR5LcQTgThUWQrSQBgZgi4Rqlp5/DgQ+5LgFRkSF +ac0eg2uu3mJG25t0m7NcfD6N7EUZYiVTTaffpH+2haRV7SkJpEVLkNIUUXZK4+PFD4WICwieGyo9sA +imGq1jwKFMkhliBBEpac4fw7OnO6xuHgrWfQISufVHkFdm/O9ps1OKruJuMpAi9zmkVjsdGDGF1beV +Vy6mMXjEYmzRK6swA6hEuiGYBCyyj8IziBsXkMgQSrJJC8YWcM4OPrOMDIGkaRksz0OHJnhW97xxsk +db/q278yj+HOvbF566OS5F7/v8qWXblvulizMlmi9hVADhJrgJXilKo+csChtkdIjQhX15Zyt/RkOL +yobUjXeU/hgcU5Q2kDwleazdKN6wCmZ5lNGY0NegHGK0kBpBSqJUXjGI0Npqu/lPAzHjpmWw0mYWMN +0nCMiT5JVxyk3EcwkPdKsTaO9RNZeZKa7l11L13Po0M3sWt77dJku/ZK24cNbJ05/i86ifzV9/nTDr +o+QhaMrU7A5XkjKSOAij0tBaon0DmUcQcfEVV5R1eiSDhdZgvJELhA5z3T1PMPTJ7L2dYfexVzn54h +afM299lrxvRaPbSm1ugqZcKUX4zGDzXdN1y48aC9fJJ0OEYXHljnOF7gAxutKoBscwllwJaLIq3OVB +BGnjMsJW4WhUBGjVDDUETNLiywfPOhe99++8SuHj97yAXbPfVIZx/7lI7+864YDv9zfuPXb26p433T +txLspL2DDBugRjhFOGnTi8cEQ3CZeiKq7KSpIbPCh0piGgPMB7yUEh/GO0o4xzuKEx0vHNDfEUYpQC +usm5CVYLymtYDg1GK/Y2CrIS4h0jBewNSgJARpZwsiMUV4QyhInAkkKMslIRAOIcWGG5d1HufnoHRz +YfxOLi/uZm939ER01/4WzfHRU096iRvzvombW35yb/anp0y/dXZ5dV8F6lFdIGXBK4aJAiCTIil0jh +SdKmkTeowk4GbDaU+pQB9EGdDBM+jl27SIM1h+kXH6XSOIPOxlfK77/7MXl/Z/yal39udv+wbczh23 +FENIK8umgM127+NbJ+TMlW+txIxhi4Sl8jjMFhfGUItDMGrjSMO5vIQXV3Cp4ptOS8WTM0AXGArZ8o +C8FjX3L4egD94l7H3zwl9qvO/BvUfoRpEM1YiBCRglLy9lHpTUfbSZzh0Sx+d+Z6crfzPOVW0t3Cee +28GWO0A4nN6rsOi2Q0gIFNpSE4BBS4pxBSMl0lNMfjzAYVKYwefWzTUswLlCUgdJLSge5CYwLz7QUD +IYGJyRBCoa5pcirZoeOIoSOOb82ZHYWOp123cJXJI1FDh26gT37DnDkhps5fPgGDhy87qtJ1v5/Bfr +XpUpPVYm3ZdXtl4K402bh6HWfnJ+fLYu9e75j89Hn3r/51RdDpr3oNloEkTOcrIN3NLpNhHcMR2NCL +NFxghSC3E4oMZBUZ2CbF6iyYCZJmVw8y8zKqZIbD75Vm/jTOokHAXb0rl8bnPq1CcbXiu8vMkm46sX +7s15I97V7fr3dALWosmiXq6u3i/WNWE2GaGdrf41B14JqG0kmZogtSlQsEc4zHo6Y2BLZyOgPpqxbw +0peUrRbHLrrbr7lrW+/fMvd3/yb6cLCj+WZnlb709rxgK0HHhFCxUSd5ins4k/r9u6fju3lb7blxf/ +KuovvdHbjVhcmmNIRXKi9gdX80IWC0hUE6yjtlOA8uXFMnaAMIIJj6g3TYEE1MUimzpIbzdQqcgOlU +1VSQaRwhaCwlkkRKG31OqooRWVtFnfB0tIudu/bz8L8IosLuzl4+DqOXH8TS7t2fzVOG7/f6XR/N0r +TLztjKL0jkqC0IErjClAYAiZU57l4ef4RncRf8Yn2arH9t7eef3khH/TRBXQ7c2hpCEWOd45Ob4ZBE +XDBUtbjBaVcpTgyHm8sOIsUloQcu7Ea67WV23XWaqdJGJTXAEr/5YrvP7Tx9Nt8zu0ZkKja8W5z64H +R2bP3hI3LJOUE6as32ocqzVZLjUsCRZlTmAmp0EgpmDpDfzrFhkCZJAwJpHtmueWee7jrLW99/PDtd +/zrZHb2Q15IjEpqnb1DBoMMtqZXVF4KG4A4RsRzaGa+rMPClzG7fhy7eRNu/Ja83P+msizvN/l0xro +cR4FngrADSj/ChkphU4YRRmQ4keOFxzCmRGNCRlFaBhPHuFAUJmFqAqXXBBVTmDGGCJU16LZikrhJs +91hbnaeTqfD/v372bVrD9ddd4R9ew9uzs8tP9Jo9T4dR8nHkRwX+so8VWpFJKqcQE+ODx5NE+XrAbm +WeB3Bwuw0a2U/oPctvJLPZH9n8sKJ15VnV2g4T+ShsAU2SFSqifEEW2IpEJFHa4mzFudKpK0FByEnQ +tNfOcns6b33iKXdD0Rp5zeCSq4V32s7Y6+REWGHJ1HZf6bTrt3YfK9ZuRBUf1MkZoqUUDrD1JYEL5B +SMTUeGwwGgzUlUZRgIs1QwMZ4wpZWqKVFbn/g/vL+h959eu7WY9/thTw59o4ky7gSOqyQ+OoZLEJIA +oqpZ8cAK4UkYRYRZaDnjhPM8TSLfj4tS0w2udPZ/PXel3dZM76jyIfHymIYb/XX8G6KFwOCGGBtXmk +kozFejTBmgKEgzkpmdKA1oymdJIgUqRtMCk+StunNLDC/uMzi4i4WFhdZXFwue73eM1naezKJs0ezr +PklrdUT28YQ52uHUllvFlQgikVt0rVVkIpwkBvQGi0jcIGJspRC4rIGan/yK91UfjLpZP9uqMSB0em +V2E4CUZIi0Iy9JYlDZd4KHhUJNI6yLBHWIp3Ay4DHosgZXTpLdPZE6By9/b005j6m0H2uQXP/M44S/ +hz1rKzV1J4qLRZVZeeRT47ZjY0lsdkXyXhMUuecG0oKnyO8QlrJ0E8AsKLK5ekXlo1pzrq3jLOEeHk +Xtz744Pib3vqWj8xdf+Qn0dELQick242eq54aXSMAq+6PoJKwuat6QdZDFDIIWW0RkhBBpHgigicQt +bvV5YRQ3LAHe0Pw+eGiGO83xWRPwC3h3VxR5jOTyag13VrN+qNhVBovG62ez7KuCSqdKpWNdNrcTNL +2ulDxxTjJzsdp64zW+qRQ6kWl1Itaa7RIdzbuvg4bCaFizWyT+XwA5331XoiaXk1U0cLVtsui9lK6q +mliqsnrOF5cfKYR1Lua6H84TpJ3mwurzbKYYF1OYXJ0UeCFwUmLEJ5gHaK0RF4QaQW+pJQGrKeclBQ +XVwRba0v0lo8pGX/W6/ha8b1WRRiEZ8chtsOr9NjJ9Nbi0tqxeDIls5YYg5DVaEHEAll6hAsYW2K9x +3tBieLyeMK5rQF0Z5m74fpwz7veLQ7dfdf/0rvxpj9A6pdyG0h0VWy28MSJrIfE9bKLfBV4Vl1lbJJ +chZp0QJB4VceX7+ji6k+iFAEvgnlReE+aGFJntznv4BxlWSCWVlhfX6c0gdm5RVqzC4AiyASRNCgmO +UHUPjmtqpHFdhNLSiZTi1KKKBJXDOLbXBl5lY5BVr9QCBCCQso6pTdy9TIZQEbEWte58WAJKDTp7Ow +L7dtv+d+6s70vb7z0ws9eevnFMNkohUPTnBY4THV6dwZlHdo6tIjRIqKQghJHMFOkMZSXV+Hs2WMsH +rqVrPPZa9vO/8Jnv6sL0WOri03Usz0BFKY92uz/8PrZ8zSKksj8f+2deYxd1X3HP2e5975t/Gb1jMf +GO/bYYBswBgMBgp0GXBkqIG2DQqqoahU1SEGqUrXqH5XaP6q2qVSlCKqqTdp/0gZFbYIapS1UJUogU +kRD2Yyx8Ybt8Xj29S13O6d/nPvevJkxhQQCM9Yc6cqekWd83znnt/9+32+MTGJSz84PwgImTklkndh +YapGhZgSJ79G1dRO9u/ey5cAtr+07dPffic7OJ/F9Ujw8PV9TzCkJhNlLqayZVC+IR62JkVI4DvcmY +G72zyxYlSzoUBTY+c9nRJYJVWAD0C1zUp5rhsZKgqogIcTPd0LQ4cQlAWxAUMjPW7amwnLT4xII8u5 +9LWBMTGpcptXzPCwQRTFaa5T0nRIxztLYJKMY81OHxy1sw4ijwHFfpILUZvRnnWve9kr6a+1tKgkL8 +rft6bP76hOT+PUJIhJiU8fGMaQpOTQa6cotys2HRVGITRLmRi8z+tYxejbv+grl7m+igtlV4fsIhW5 +BBrTBrdMAP7IQ1asPzExOBBMjo+TDkDSsY6IakTDURUoUG2RdYKshdS/CCkW1HjOXWDo2bmH7gdsZu +OuefyvdcMM36Oz6Ll6+OStO6p55sORaNhnugfUXwq1LiZQqQ45OsTbJujL8ZqiSMtNA03Q8Dg0uBwR +WuQkFgUQK6XA3WzCirAVlNWEkqdddQd3HA6EyRGpJmmRVmAzHxS4a/4jTEGtTlJIZv7uLow11LBLfl +xm7qyWNXWyttNtuN1GegM4m7RHExuLHGUW3BWkERkIoDcLXBFvWP7mxlBssFwu/OXLi9P2FmWGkgSS +qYxLXbKCFRBhBkiSInHQOfBohjaEyOUH4zjk6J8YD1V95gKDtm6vC9zHFfIIqxiT4op0kAc8z0s4Mb +UtffX7D9qkTeLODzMkKM4FApAG52EfUq4zXp5iws4xX11CVkqjcSXnnLq755Kemtn7i0E9yG7Z8oWb +9GV/7CJM5gxJQCVbFJKSkJAS0z88zyXfbVk1DP4iFL49P5/v7/FkW12Hm2qb0TSd5/MIMXbWTlAIP0 +k5Cr43UM+i0ii8KrglLgSFGk1lo6XgkAtkSM1lwOJ4tDerWzusT1cgutwiwyTewrZu/xHhLUaQ94/j +yrChgutq+J29a+8O2nTf+0+Dz6taRc+fak0vQqTyCoIZOK/jxKH5SpTZdJwk8ZizUdY6a9fCGh1Gv/ +M8GOjq2xR1dErRJjCEQHtpCGjokNGwK2pJgSRzKJxqBb7XzDBIgvzzu+YqkfHFWwfUnWgG1arU0Nnj +5sdr0LPVqhSiqY5IQEYdYE1ELq0xVK1TSBOvnifwcaZCjf9sODh05OnT7PYef6OhZ+6hBTPg5fyFCj +23dKpFhiHzMhyZla0dCE0RJNHBHPwTP44M81s670Y0/lVJJEAQTxWLx0YFbDj5xzcDAUKFvHUmxjbo +fEHoBsQyIYoGnAmQsCKx0j4QorDJ86RwMX3jM1GslZWOkSR2AgQDlzHdDW2S6US694GLV8n2gFeAhh +EeMa96tTc598fLp8+3x+BRerYaKaigiZAqVeoQ1PmngMx3GDE1OEXetY+CmG5NbPv3p6rqDt32Btf0 +/RQfjAq/ZKqpFa8CkmxZMLoMGJyll85Jn2ZCs/CGQQr4v4fpFhw3N92tZvu+jlBpTW7Z9bYPnvVDqK +H979u2ThcqpN3U4WmeN9WkL1hDOzhDVq2jPR4kITynCNGb48hl6x8+167D+RR0EX5VCZDGBahj2pqK +UGV43GTTW/++prArfksvxbu6nNpBKSSwEnqG3Mjq2Y+r0ed+bmCap10jSCGvqCCMRVlJJYMJqZoMct +tDHtbffw8HDh/+j97bb/oZi8dkkjLG6gEETpZacEu5MRUvWQmoH374MhG9JHCzEPFvTMjm/xVaw0Qo +mpSQWwXhu/aZn17d3PDLb3f07Fz19dFoopseGSecU2sbYNCGnPMKw5mYfpWVq5B3Mhbd8Oz2xg2KhV +0o1bI0AqZro1q4yIskqUFhMJn6mOQe6Knzv8xCvKICRhJxwEVi1LiuDg/dHg4MEk9OYKKQe1wmjKsY +oIlFiNIwYlYKe3ddx860HuO7wI38ddHb9I6X2/8XTGN8B8hlALaagaiQbLRngj1w2wpeZwWbiyeKGg +OVH+f+/h3JoIoIb0yx3xCrASMi1dX2/uNUf2uDlzhS7er48/uorXDp2jK5iBzmr3VlUa5i4jhIxszM +Vzrz+El0HL9zvl9f8EcUSQlhSFFa62qpqfHgrUYKFkxCrlu9D0PjksjpaQmVy+PHqhbO9ufExctU5S +GNmowiLZC5MmQgrRJ39XHvzAa47/KlTG/fs+T7X7H7cUfBIUqFIgSjLSTZZbiVLEQvs8ooZhGhkZJZ +Xx4fJYlApZdNFbgihEC5HaqxPJA1+oeOV0rbc46q4hkh6v1yzcvvEmTN4oaEeVYmNwCQGKRL8esLYq +bcRZ071dmza8Dj5/B841kxL3CJbooXPT0iZEQeAEGa+7LMqfD9v0OOBNQjCHZVLZ/fXzr1JYXoEXZk +iVhEzRpJIn1Brgu51XHvbXey5/+gbwXW7/xIveLoeC3KlwKYCIqCWuKJzE6buXYJzK+Y7XJZNzLc44 +fIRXK73ihmVUk0BXPwzUkpUAkJlfbBgY51H9m74/e4b9culrt6vXPjJj6+ffPMNpi6eI+fn8UyIjiN +yQhGNRpw79jrbdu/aT3f3Dqw+CZDYFIxECYHXCvJpnABaTKZLzUIArVXh+xldTwtxGAnSuZ760Ok90 +cUTFGaHiecmmckZ5vw8w3Mp5a713HToaGX3ffedYWDnQ5QK5xFEAUFz6l0CBa3nU78mRUm1VPjE/AT +Tsst2tuyPWAamWQhHKf2uMXt2hm6YClKh8b1SvdS/+Z/b2jtfzLWX//WY1lsvRNViPCVR4zGqWiOXK +irTKZffeoupSxf2tG/a2EObfBuVs1JohMqSKylLqK6Xy9ktOMeV4mouiCEM5PzAzgy+87lLb7zUy9Q +lVDzNXHWKyPcZsz7d19/KgQd/I9195OGvs3Pv5ymWT1nhRQjXFS9tk7C5WZVTGHzZ4ANwnHDuaSXj/ +OgSFo3Pv3gPkiSZF0AhIFMey43BZ/Fo2Pw7O/g/bSGXPa6fW0dJvu2U6lv/+X33/8rXdx05mkbrrmG +yWGaqUGYoEkwJOHP6NC+//HIvlcrn0J6N0ihrS1hZa0W6nWkMyk/3MjV+pHb5ohUz4yKVMWkhYDQRd +F9/k73urqN25x33fpn+Dc8QyMFQOrg8kaR4mWFTC7SjWagfRUOFZow6SOyyKDRcBUulWYlEo6xAGde +iZiSkeBTKPa+qtra/2HHnPSeKa8pPHP/Bf4sTP/qBmJyN0RGcPHuR7teP213nLx5Zt37z3kAHr0WZE +xBHDt7zSmGDWBW+D8EaarSZntk/cup0KRyfFCKOGDEp+S3buHbnXrYfeuCF7t23Pk3/5qfwJLMYlHB +IZ0lcw5OLTqS1f2vJKdmMvNK0JMs+Xh0rRFbBWqGjNREpSkiUSDPUJgfJr1KXrTRKE1s1mF/b/9TWg +0Xht5V/XZTa73zthR9x/q0TyHrIifPnxevHT5a6du/b73cV3tQ40g0dLHI5pSs3yOa3VhMuH8xX9kk +qg6N3D588212drCBybei+NWy865fYfNd9/86Om/8UEbyQ2pSahVTLZiIl7+Xnhcs2BI+MlTIbArpCV +lM2I4flcXgrmRK50UKkGi5oY8+zM5GAEAFWJMi2zievueHAq6We/j9Myj1HzsbfQQ5e5NTQCC+/ebx +74M7xu9eXu//BWOnQBNRSwTPNLKhcViZwRbaXhcns/qnR4UdmHKb3TAAAAyxJREFUhsZJ04Dyjr1sP +/qZoc1HP/MMu29+GL/0IkqDD1obRwNm4/lTb8Zyi6ydzWjCMuoxmz1iwbMqeB/80mVN5I0bqLJG2gy +PlTh1uKbCB+ljc20vdm4deHjPoXuf+cSvPTpU3riJmvQ5fXGIS8Njj2D1fl8pTBS30PwaUtyzINGyj +OKGlWj5vJnK2IOnjx+L49nQ37nrAAOH75xuv/XmP6Nv078YE9RkaEGnSBUCKRqBFj5e1o1ksxMQjYK +elQuEsLUwK2m1kpmlVB+/8K1kAQxaNtBmjeMOl8LtcRzV8WQuG6FQGIQVWtbW79zz2L19Gx/uL5f+J +P+fz5YHR8Z56aevxNt37n2wu7fnNd/TsfNaXBiRZiGDwKDRLbB3q8L3867y+MTlXdMTo8WBbbvi/Qf +vGOLAvt+qrl37w3EIcxLag4x11laIRAWPAI8Ot/ExpH6jWC8yF2devkyLrInFgmeWh7OwRPBWGG+Wi +F0jppWWRJBNHxikcD21XjFwUpk6AkatJEkC1orBclf73x564IHjhb7+v3/uv55fNz45VRy+fHlXd09 +PmSgZc0hPNhvYAruYN27V8n2gtXV8fOShnq5O9t+492kG9n2LQv65KWAaWAMUDPhEaG0oIFyOMgkhy +YOaz2HKRVHc4lqQbf3LMisUrWjrl9XhhBCkwnWnNLiFDVCParR5BeeRJE47aungOASE1gueu+OTh76 +0dt3Gzx47dvzRUnHNQ8Cf2yQZE7mg+XtslqVWi5XocjlDu7K0pgS+dfbs2V8tFotPlUqlr+ZyuXNO+ +duFtaSrZF3pfCpiGjN2imToJJ39m6BjG1XZRwrkAI8YUKSZWlEZQDAIrNArHnyvpXtmM/B7wJeAbwO +fBcxKuQMrzfLdBoz29fX9led5v6u1XnBJW7vnr/YlrXEoNo22LRYOYlxZ1S6rkOfDcLvPAY/hGmWC7 +H68uFI+x0oSPg2MAN/L5/M/vtqSED/T5cMu9J4Wf7HMGsB/4TEv/DFwe3Y/NPN57VXh+5BWApwFLlh +r661tV1eju/ne8YJrkWtES0tmRe2VOviv2j2aBp5nHihiRaz/A4oCnsAsje/+AAAAAElFTkSuQmCC" + } + +# $encoded(basn0g08), $encoded(basn2c08), $encoded(basn3p08), $encoded(basn6a08) +test imgPNG-1.1 {reading basic images; grayscale} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $encoded(basn0g08) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {32 32} +test imgPNG-1.2 {reading basic images; color} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $encoded(basn2c08) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {32 32} +test imgPNG-1.3 {reading basic images; color with palette} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $encoded(basn3p08) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {32 32} +test imgPNG-1.4 {reading basic images; alpha} -setup { + catch {rename foo ""} +} -body { + image create photo foo -data $encoded(basn6a08) + list [image width foo] [image height foo] +} -cleanup { + rename foo "" +} -result {32 32} + +test imgPNG-2.1 {reading a bad image} -body { + image create photo -data $encoded(BadX) +} -returnCodes error -result {unfinalized data stream in PNG data} +test imgPNG-2.2 {reading a good image with multiple IDATs} -setup { + set i [image create photo] +} -body { + $i put $encoded(MultiIDAT) + return [image width $i]x[image height $i] +} -cleanup { + image delete $i +} -result 223x212 + +} +namespace delete png +imageFinish +cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/imgPPM.test b/tests/imgPPM.test index a9e9dc0..456427f 100644 --- a/tests/imgPPM.test +++ b/tests/imgPPM.test @@ -6,11 +6,12 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -eval image delete [image names] +imageInit # Note that we do not use [tcltest::makeFile] because it is # only suitable for text files @@ -21,145 +22,150 @@ proc put {file data} { close $f } -test imgPPM-1.1 {FileReadPPM procedure} { +test imgPPM-1.1 {FileReadPPM procedure} -body { put test.ppm "P6\n0 256\n255\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} -test imgPPM-1.2 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0} +test imgPPM-1.2 {FileReadPPM procedure} -body { put test.ppm "P6\n-2 256\n255\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} -test imgPPM-1.3 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0} +test imgPPM-1.3 {FileReadPPM procedure} -body { put test.ppm "P6\n10 0\n255\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} -test imgPPM-1.4 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0} +test imgPPM-1.4 {FileReadPPM procedure} -body { put test.ppm "P6\n10 -2\n255\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has dimension(s) <= 0}} -test imgPPM-1.5 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {PPM image file "test.ppm" has dimension(s) <= 0} +test imgPPM-1.5 {FileReadPPM procedure} -body { put test.ppm "P6\n10 20\n256\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has bad maximum intensity value 256}} -test imgPPM-1.6 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 256} +test imgPPM-1.6 {FileReadPPM procedure} -body { put test.ppm "P6\n10 20\n0\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has bad maximum intensity value 0}} -test imgPPM-1.7 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {PPM image file "test.ppm" has bad maximum intensity value 0} +test imgPPM-1.7 {FileReadPPM procedure} -body { put test.ppm "P6\n10 10\n255\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {error reading PPM image file "test.ppm": not enough data}} -test imgPPM-1.8 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data} +test imgPPM-1.8 {FileReadPPM procedure} -body { put test.ppm "P6\n5 4\n255\n01234567890123456789012345678901234567890123456789012345678" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {error reading PPM image file "test.ppm": not enough data}} -test imgPPM-1.9 {FileReadPPM procedure} { + image create photo p1 -file test.ppm +} -returnCodes error -result {error reading PPM image file "test.ppm": not enough data} +test imgPPM-1.9 {FileReadPPM procedure} -body { put test.ppm "P6\n5 4\n150\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg \ - [image width p1] [image height p1] -} {0 p1 5 4} + list [image create photo p1 -file test.ppm] \ + [image width p1] [image height p1] +} -returnCodes ok -result {p1 5 4} -catch {image delete p1} -put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" -image create photo p1 -file test.ppm -test imgPPM-2.1 {FileWritePPM procedure} { + +test imgPPM-2.1 {FileWritePPM procedure} -setup { + catch {image delete p1} +} -body { + put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + image create photo p1 -file test.ppm list [catch {p1 write not_a_dir/bar/baz/gorp} msg] [string tolower $msg] \ - [string tolower $errorCode] -} {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}} -test imgPPM-2.2 {FileWritePPM procedure} { + [string tolower $errorCode] +} -cleanup { + image delete p1 +} -result {1 {couldn't open "not_a_dir/bar/baz/gorp": no such file or directory} {posix enoent {no such file or directory}}} + +test imgPPM-2.2 {FileWritePPM procedure} -setup { + catch {image delete p1} catch {unset data} +} -body { + put test.ppm "P6\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" + image create photo p1 -file test.ppm p1 write -format ppm test.ppm set fd [open test.ppm] set data [read $fd] close $fd set data -} {P6 +} -cleanup { + image delete p1 +} -result {P6 5 4 255 012345678901234567890123456789012345678901234567890123456789} -test imgPPM-3.1 {ReadPPMFileHeader procedure} { - catch {image delete p1} + +test imgPPM-3.1 {ReadPPMFileHeader procedure} -body { put test.ppm "# \n#\n#\nP6\n#\n##\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {0 p1} -test imgPPM-3.2 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -cleanup { + image delete p1 +} -returnCodes ok -result p1 +test imgPPM-3.2 {ReadPPMFileHeader procedure} -body { put test.ppm "P6\n5\n 4 255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {0 p1} -test imgPPM-3.3 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -cleanup { + image delete p1 +} -returnCodes ok -result p1 +test imgPPM-3.3 {ReadPPMFileHeader procedure} -body { put test.ppm "P6\n# asdfasdf\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {0 p1} -test imgPPM-3.4 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -cleanup { + image delete p1 +} -returnCodes ok -result p1 +test imgPPM-3.4 {ReadPPMFileHeader procedure} -body { put test.ppm "P6 \n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {0 p1} -test imgPPM-3.5 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -cleanup { + image delete p1 +} -returnCodes ok -result p1 +test imgPPM-3.5 {ReadPPMFileHeader procedure} -body { put test.ppm "P5\n5 4\n255\n01234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {0 p1} -test imgPPM-3.6 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -cleanup { + image delete p1 +} -returnCodes ok -result p1 +test imgPPM-3.6 {ReadPPMFileHeader procedure} -body { put test.ppm "P3\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.7 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.7 {ReadPPMFileHeader procedure} -body { put test.ppm "P6x\n5 4\n255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.8 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.8 {ReadPPMFileHeader procedure} -body { put test.ppm "P6\nxy5 4\n255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.9 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.9 {ReadPPMFileHeader procedure} -body { put test.ppm "P6\n5\n255\n!012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.10 {ReadPPMFileHeader procedure} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.10 {ReadPPMFileHeader procedure} -body { put test.ppm "P6\n5 4\nzz255\n012345678901234567890123456789012345678901234567890123456789" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.11 {ReadPPMFileHeader procedure, empty file} -body { put test.ppm " " - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.12 {ReadPPMFileHeader procedure, file ends too soon} -body { put test.ppm "P6\n566" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} -test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} { - catch {image delete p1} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} +test imgPPM-3.13 {ReadPPMFileHeader procedure, file ends too soon} -body { put test.ppm "P6\n566\n#asdf" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {couldn't recognize data in image file "test.ppm"}} + image create photo p1 -file test.ppm +} -returnCodes error -result {couldn't recognize data in image file "test.ppm"} -test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} \ - -setup { - image create photo I -width 1103 -height 997 - } \ - -cleanup { - image delete I - } \ - -body { - I put "P5\n1103 997\n255\n" - } \ - -returnCodes error \ - -result {truncated PPM data} -eval image delete [image names] +test imgPPM-4.1 {StringReadPPM procedure, data too short [Bug 1822391]} -body { + image create photo I -width 1103 -height 997 + I put "P5\n1103 997\n255\n" +} -cleanup { + image delete I +} -returnCodes error -result {truncated PPM data} + +imageFinish # cleanup catch {file delete test.ppm} cleanupTests return + diff --git a/tests/imgPhoto.test b/tests/imgPhoto.test index d4118b0..e85f512 100644 --- a/tests/imgPhoto.test +++ b/tests/imgPhoto.test @@ -1,486 +1,867 @@ -# This file is a Tcl script to test out the "photo" image type and the -# other procedures in the file tkImgPhoto.c. It is organized in the -# standard fashion for Tcl tests. +# This file is a Tcl script to test out the "photo" image type and the other +# procedures in the file tkImgPhoto.c. It is organized in the standard fashion +# for Tcl tests. # # Copyright (c) 1994 The Australian National University # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2002-2008 Donal K. Fellows # All rights reserved. # # Author: Paul Mackerras (paulus@cs.anu.edu.au) -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -eval image delete [image names] - -canvas .c -pack .c -update +# Used for 4.65 - 4.73 tests +# Now for some heftier testing, checking that setting and resetting of pixels' +# transparency status doesn't "leak" with any one-off errors. +proc foreachPixel {img xVar yVar script} { + upvar 1 $xVar x $yVar y + set width [image width $img] + set height [image height $img] + for {set x 0} {$x<$width} {incr x} { + for {set y 0} {$y<$height} {incr y} { + uplevel 1 $script + } + } +} +proc checkImgTrans {img} { + set result {} + foreachPixel $img x y { + if {[$img transparency get $x $y]} { + lappend result $x,$y + } + } + return $result +} +proc checkImgTransLoop {img script1 script2} { + set result {} + foreachPixel $img x y { + eval $script1 + lappend result {*}[checkImgTrans $img] + append result : + eval $script2 + lappend result {*}[checkImgTrans $img] + append result . + } + return $result +} +imageInit set README [makeFile { -README -- Tk test suite design document. + README -- Tk test suite design document. } README-imgPhoto] # find the teapot.ppm file for use in these tests set teapotPhotoFile [file join [file dirname [info script]] teapot.ppm] testConstraint hasTeapotPhoto [file exists $teapotPhotoFile] -test imgPhoto-1.1 {options for photo images} { - image create photo p1 -width 79 -height 83 - list [lindex [p1 configure -width] 4] [lindex [p1 configure -height] 4] \ - [image width p1] [image height p1] -} {79 83 79 83} -test imgPhoto-1.2 {options for photo images} { - list [catch {image create photo p1 -file no.such.file} err] \ +# ---------------------------------------------------------------------- + +test imgPhoto-1.1 {options for photo images} -body { + image create photo photo1 -width 79 -height 83 + list [photo1 cget -width] [photo1 cget -height] \ + [image width photo1] [image height photo1] +} -cleanup { + image delete photo1 +} -result {79 83 79 83} +test imgPhoto-1.2 {options for photo images} -body { + list [catch {image create photo photo1 -file no.such.file} err] \ [string tolower $err] -} {1 {couldn't open "no.such.file": no such file or directory}} -test imgPhoto-1.3 {options for photo images} hasTeapotPhoto { - list [catch {image create photo p1 -file $teapotPhotoFile \ - -format no.such.format} err] $err -} {1 {image file format "no.such.format" is not supported}} -test imgPhoto-1.4 {options for photo images} hasTeapotPhoto { - image create photo p1 -file $teapotPhotoFile - list [image width p1] [image height p1] -} {256 256} -test imgPhoto-1.5 {options for photo images} hasTeapotPhoto { - image create photo p1 -file $teapotPhotoFile \ - -format ppm -width 79 -height 83 - list [image width p1] [image height p1] \ - [lindex [p1 configure -file] 4] [lindex [p1 configure -format] 4] -} [list 79 83 $teapotPhotoFile ppm] -test imgPhoto-1.6 {options for photo images} { - image create photo p1 -palette 2/2/2 -gamma 2.2 - list [format %.1f [lindex [p1 configure -gamma] 4]] \ - [lindex [p1 configure -palette] 4] -} {2.2 2/2/2} -test imgPhoto-1.7 {options for photo images} { - list [catch {image create photo p1 -file $README} err] $err -} [subst {1 {couldn't recognize data in image file "$README"}}] -test imgPhoto-1.8 {options for photo images} { - list [catch {image create photo -blah blah} err] $err -} {1 {unknown option "-blah"}} -test imgPhoto-1.9 {options for photo images - error case} { - list [catch {image create photo -format} err] $err -} {1 {value for "-format" missing}} -test imgPhoto-1.10 {options for photo images - error case} { - list [catch {image create photo -data} err] $err -} {1 {value for "-data" missing}} -test imgPhoto-1.11 {options for photo images - error case} { - list [catch {image create photo p1 -format} err] $err -} {1 {value for "-format" missing}} +} -result {1 {couldn't open "no.such.file": no such file or directory}} +test imgPhoto-1.3 {options for photo images} -constraints hasTeapotPhoto -body { + image create photo photo1 -file $teapotPhotoFile -format no.such.format +} -returnCodes error -result {image file format "no.such.format" is not supported} +test imgPhoto-1.4 {options for photo images} -constraints hasTeapotPhoto -body { + image create photo photo1 -file $teapotPhotoFile + list [image width photo1] [image height photo1] +} -cleanup { + image delete photo1 +} -result {256 256} +test imgPhoto-1.5 {options for photo images} -constraints hasTeapotPhoto -body { + image create photo photo1 -file $teapotPhotoFile \ + -format ppm -width 79 -height 83 + list [image width photo1] [image height photo1] [photo1 cget -file] [photo1 cget -format] +} -cleanup { + image delete photo1 +} -result [list 79 83 $teapotPhotoFile ppm] +test imgPhoto-1.6 {options for photo images} -body { + image create photo photo1 -palette 2/2/2 -gamma 2.2 + list [format %.1f [photo1 cget -gamma]] [photo1 cget -palette] +} -cleanup { + image delete photo1 +} -result {2.2 2/2/2} +test imgPhoto-1.7 {options for photo images} -returnCodes error -body { + image create photo photo1 -file $README +} -result [subst {couldn't recognize data in image file "$README"}] +test imgPhoto-1.8 {options for photo images} -body { + image create photo -blah blah +} -returnCodes error -result {unknown option "-blah"} +test imgPhoto-1.9 {options for photo images - error case} -body { + image create photo -format +} -returnCodes error -result {value for "-format" missing} +test imgPhoto-1.10 {options for photo images - error case} -body { + image create photo -data +} -returnCodes error -result {value for "-data" missing} +test imgPhoto-1.11 {options for photo images - error case} -body { + image create photo photo1 -format +} -returnCodes error -result {value for "-format" missing} -test imgPhoto-2.1 {ImgPhotoCreate procedure} { - eval image delete [image names] +test imgPhoto-2.1 {ImgPhotoCreate procedure} -setup { + imageCleanup +} -body { catch {image create photo -blah blah} - image names -} {} -test imgPhoto-2.2 {ImgPhotoCreate procedure} { - eval image delete [image names] + imageNames +} -result {} +test imgPhoto-2.2 {ImgPhotoCreate procedure} -setup { + imageCleanup +} -body { image create photo image1 - list [info commands image1] [image names] \ - [image width image1] [image height image1] -} {image1 image1 0 0} + list [info commands image1] [imageNames] \ + [image width image1] [image height image1] +} -cleanup { + image delete image1 +} -result {image1 image1 0 0} # test imgPhoto-2.3 {ImgPhotoCreate procedure: creation failure} { -# image create photo p1 -# image create photo p2 -width 10 -height 10 -# catch {image create photo p2 -file bogus.img} msg -# p1 copy p2 +# image create photo photo1 +# image create photo photo2 -width 10 -height 10 +# catch {image create photo photo2 -file bogus.img} msg +# photo1 copy photo2 # set msg # } {couldn't open "bogus.img": no such file or directory} -test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto { - image create photo p1 -file $teapotPhotoFile - p1 configure -file $teapotPhotoFile -} {} -test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto { - image create photo p1 -file $teapotPhotoFile - list [catch {p1 configure -file bogus} err] [string tolower $err] \ - [image width p1] [image height p1] -} {1 {couldn't open "bogus": no such file or directory} 256 256} -test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} hasTeapotPhoto { - image create photo p1 - .c create image 10 10 -image p1 -tags p1.1 -anchor nw - .c create image 300 10 -image p1 -tags p1.2 -anchor nw +test imgPhoto-3.1 {ImgPhotoConfigureMaster procedure} -constraints { + hasTeapotPhoto +} -body { + image create photo photo1 -file $teapotPhotoFile + photo1 configure -file $teapotPhotoFile +} -cleanup { + image delete photo1 +} -result {} +test imgPhoto-3.2 {ImgPhotoConfigureMaster procedure} -constraints { + hasTeapotPhoto +} -body { + image create photo photo1 -file $teapotPhotoFile + list [catch {photo1 configure -file bogus} err] [string tolower $err] \ + [image width photo1] [image height photo1] +} -cleanup { + image delete photo1 +} -result {1 {couldn't open "bogus": no such file or directory} 256 256} +test imgPhoto-3.3 {ImgPhotoConfigureMaster procedure} -constraints { + hasTeapotPhoto +} -setup { + destroy .c + pack [canvas .c] update - p1 configure -file $teapotPhotoFile +} -body { + image create photo photo1 + .c create image 10 10 -image photo1 -tags photo1.1 -anchor nw + .c create image 300 10 -image photo1 -tags photo1.2 -anchor nw update - list [image width p1] [image height p1] [.c bbox p1.1] [.c bbox p1.2] -} {256 256 {10 10 266 266} {300 10 556 266}} - -eval image delete [image names] -image create photo p1 -.c create image 10 10 -image p1 -update + photo1 configure -file $teapotPhotoFile + update + list [image width photo1] [image height photo1] [.c bbox photo1.1] [.c bbox photo1.2] +} -cleanup { + destroy .c + image delete photo1 +} -result {256 256 {10 10 266 266} {300 10 556 266}} -test imgPhoto-4.1 {ImgPhotoCmd procedure} { - list [catch {p1} err] $err -} {1 {wrong # args: should be "p1 option ?arg arg ...?"}} -test imgPhoto-4.2 {ImgPhotoCmd procedure} { - list [catch {p1 blah} err] $err -} {1 {bad option "blah": must be blank, cget, configure, copy, data, get, put, read, redither, transparency, or write}} -test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} { - p1 blank - list [catch {p1 blank x} err] $err -} {1 {wrong # args: should be "p1 blank"}} -test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} { - list [catch {p1 cget} msg] $msg -} {1 {wrong # args: should be "p1 cget option"}} -test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} { - image create photo p2 -width 25 -height 30 - list [p2 cget -width] [p2 cget -height] -} {25 30} -test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} { - llength [p1 configure] -} {7} -test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} { - p1 conf -palette 3/4/2 - p1 configure -palette -} {-palette {} {} {} 3/4/2} -test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} { - list [catch {p1 configure -blah} msg] $msg -} {1 {unknown option "-blah"}} -test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} { - list [catch {p1 configure -palette {} -gamma} msg] $msg -} {1 {value for "-gamma" missing}} -test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} hasTeapotPhoto { - image create photo p2 -file $teapotPhotoFile - p1 configure -width 0 -height 0 -palette {} -gamma 1 - p1 copy p2 - list [image width p1] [image height p1] [p1 get 100 100] -} {256 256 {169 117 90}} -test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} { - list [catch {p1 copy} msg] $msg -} {1 {wrong # args: should be "p1 copy source-image ?-compositingrule rule? ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"}} -test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} { - list [catch {p1 copy blah} msg] $msg -} {1 {image "blah" doesn't exist or is not a photo image}} -test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} { - list [catch {p1 copy p2 -blah} msg] $msg -} {1 {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom}} -test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} { - list [catch {p1 copy p2 -from -to} msg] $msg -} {1 {the "-from" option requires one to four integer values}} -test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 - p1 copy p2 -from 0 70 60 120 -shrink - list [image width p1] [image height p1] [p1 get 20 10] -} {60 50 {215 154 120}} -test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 -from 60 120 0 70 -to 20 50 - list [image width p1] [image height p1] [p1 get 40 80] -} {80 100 {19 92 192}} -test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 -from 0 120 60 70 -to 0 0 100 100 - list [image width p1] [image height p1] [p1 get 80 60] -} {100 100 {215 154 120}} -test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 -from 60 70 0 120 -zoom 2 - list [image width p1] [image height p1] [p1 get 100 50] -} {120 100 {169 99 47}} -test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 -from 0 70 60 120 - list [image width p1] [image height p1] [p1 get 100 50] -} {120 100 {169 99 47}} -test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 -from 20 20 200 180 -subsample 2 -shrink - list [image width p1] [image height p1] [p1 get 50 30] -} {90 80 {207 146 112}} -test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} { - p1 copy p2 - set result [list [image width p1] [image height p1]] - p1 conf -width 49 -height 51 - lappend result [image width p1] [image height p1] - p1 copy p2 - lappend result [image width p1] [image height p1] - p1 copy p2 -from 0 0 10 10 -shrink - lappend result [image width p1] [image height p1] - p1 conf -width 0 - p1 copy p2 -from 0 0 10 10 -shrink - lappend result [image width p1] [image height p1] - p1 conf -height 0 - p1 copy p2 -from 0 0 10 10 -shrink - lappend result [image width p1] [image height p1] -} {256 256 49 51 49 51 49 51 10 51 10 10} -test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} hasTeapotPhoto { - p1 read $teapotPhotoFile - list [p1 get 100 100] [p1 get 150 100] [p1 get 100 150] -} {{169 117 90} {172 115 84} {35 35 35}} -test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} { - list [catch {p1 get 256 0} err] $err -} {1 {p1 get: coordinates out of range}} -test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} { - list [catch {p1 get 0 -1} err] $err -} {1 {p1 get: coordinates out of range}} -test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} { - list [catch {p1 get} err] $err -} {1 {wrong # args: should be "p1 get x y"}} -test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} { - list [catch {p1 put} err] $err -} {1 {wrong # args: should be "p1 put data ?options?"}} -test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} { - list [catch {p1 put {{white} {white white}}} err] $err -} {1 {all elements of color list must have the same number of elements}} -test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} { - list [catch {p1 put {{blahgle}}} err] $err -} {1 {can't parse color "blahgle"}} -test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} { - p1 put -to 10 10 20 20 {{white}} - p1 get 19 19 -} {255 255 255} -test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} { - list [catch {p1 read} err] $err -} {1 {wrong # args: should be "p1 read fileName ?options?"}} -test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { - list [catch {p1 read $teapotPhotoFile -zoom 2} err] $err -} {1 {unrecognized option "-zoom": must be -format, -from, -shrink, or -to}} -test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} { - list [catch {p1 read bogus} err] [string tolower $err] -} {1 {couldn't open "bogus": no such file or directory}} -test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { - list [catch {p1 read $teapotPhotoFile -format bogus} err] $err -} {1 {image file format "bogus" is not supported}} -test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} { - list [catch {p1 read $README} err] $err -} [subst {1 {couldn't recognize data in image file "$README"}}] -test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { - p1 read $teapotPhotoFile - list [image width p1] [image height p1] [p1 get 120 120] -} {256 256 {161 109 82}} -test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} hasTeapotPhoto { - p1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink - list [image width p1] [image height p1] [p1 get 29 19] -} {70 60 {244 180 144}} -test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} { - p1 redither - list [catch {p1 redither x} err] $err -} {1 {wrong # args: should be "p1 redither"}} -test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} { - list [catch {p1 write} err] $err -} {1 {wrong # args: should be "p1 write fileName ?options?"}} -test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} { - list [catch {p1 write teapot.tmp -format bogus} err] $err -} {1 {image file format "bogus" is unknown}} -eval image delete [image names] -image create photo p1 -test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} { - list [catch {p1 transparency} err] $err -} {1 {wrong # args: should be "p1 transparency option ?arg arg ...?"}} -test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get} err] $err -} {1 {wrong # args: should be "p1 transparency get x y"}} -test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get 0} err] $err -} {1 {wrong # args: should be "p1 transparency get x y"}} -test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get 0 0 0} err] $err -} {1 {wrong # args: should be "p1 transparency get x y"}} -test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get bogus 0} err] $err -} {1 {expected integer but got "bogus"}} -test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get 0 bogus} err] $err -} {1 {expected integer but got "bogus"}} -test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} { - p1 put white - p1 transparency get 0 0 -} 0 -test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get 1 0} err] $err -} {1 {p1 transparency get: coordinates out of range}} -test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get -1 0} err] $err -} {1 {p1 transparency get: coordinates out of range}} -test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get 0 1} err] $err -} {1 {p1 transparency get: coordinates out of range}} -test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} { - list [catch {p1 transparency get 0 -1} err] $err -} {1 {p1 transparency get: coordinates out of range}} -test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} { - p1 blank - p1 transparency get 0 0 -} 1 -test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set} err] $err -} {1 {wrong # args: should be "p1 transparency set x y boolean"}} -test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0} err] $err -} {1 {wrong # args: should be "p1 transparency set x y boolean"}} -test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0 0} err] $err -} {1 {wrong # args: should be "p1 transparency set x y boolean"}} -test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0 0 0 0} err] $err -} {1 {wrong # args: should be "p1 transparency set x y boolean"}} -test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set bogus 0 0} err] $err -} {1 {expected integer but got "bogus"}} -test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0 bogus 0} err] $err -} {1 {expected integer but got "bogus"}} -test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0 0 bogus} err] $err -} {1 {expected boolean value but got "bogus"}} -test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 1 0 0} err] $err -} {1 {p1 transparency set: coordinates out of range}} -test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set -1 0 0} err] $err -} {1 {p1 transparency set: coordinates out of range}} -test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0 1 0} err] $err -} {1 {p1 transparency set: coordinates out of range}} -test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} { - list [catch {p1 transparency set 0 -1 0} err] $err -} {1 {p1 transparency set: coordinates out of range}} -test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} { - p1 transparency set 0 0 false - p1 transparency get 0 0 -} 0 -test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} { - p1 transparency set 0 0 true - p1 transparency get 0 0 -} 1 -# Now for some heftier testing, checking that setting and resetting of -# pixels' transparency status doesn't "leak" with any one-off errors. -proc checkImgTrans {img width height} { - set result {} - for {set x 0} {$x<$width} {incr x} { - for {set y 0} {$y<$height} {incr y} { - if {[$img transparency get $x $y]} { - lappend result $x $y - } - } - } - return $result -} -test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} { - p1 put white -to 0 0 3 3 - checkImgTrans p1 3 3 -} {} -test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} { - p1 blank - checkImgTrans p1 3 3 -} {0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2} -proc checkImgTransLoopSetReset {img width height} { - set result {} - for {set x 0} {$x<$width} {incr x} { - for {set y 0} {$y<$height} {incr y} { - $img put white -to 0 0 3 3 - $img transparency set $x $y 1 - set result [concat $result [checkImgTrans $img $width $height]] - lappend result , - $img transparency set $x $y 0 - set result [concat $result [checkImgTrans $img $width $height]] - lappend result . - } +test imgPhoto-4.1 {ImgPhotoCmd procedure} -setup { + image create photo photo1 +} -body { + photo1 +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 option ?arg ...?"} +test imgPhoto-4.2 {ImgPhotoCmd procedure} -setup { + image create photo photo1 +} -body { + photo1 blah +} -returnCodes error -cleanup { + image delete photo1 +} -match glob -result {bad option "blah": must be *} +test imgPhoto-4.3 {ImgPhotoCmd procedure: blank option} -setup { + image create photo photo1 +} -body { + photo1 blank + photo1 blank x +} -cleanup { + image delete photo1 +} -returnCodes error -result {wrong # args: should be "photo1 blank"} +test imgPhoto-4.4 {ImgPhotoCmd procedure: cget option} -setup { + image create photo photo1 +} -body { + photo1 cget +} -cleanup { + image delete photo1 +} -returnCodes error -result {wrong # args: should be "photo1 cget option"} +test imgPhoto-4.5 {ImgPhotoCmd procedure: cget option} -setup { + image create photo photo2 -width 25 -height 30 +} -body { + list [photo2 cget -width] [photo2 cget -height] +} -cleanup { + image delete photo2 +} -result {25 30} +test imgPhoto-4.6 {ImgPhotoCmd procedure: configure option} -setup { + image create photo photo1 +} -body { + llength [photo1 configure] +} -cleanup { + image delete photo1 +} -result 7 +test imgPhoto-4.7 {ImgPhotoCmd procedure: configure option} -setup { + image create photo photo1 +} -body { + photo1 conf -palette 3/4/2 + photo1 configure -palette +} -cleanup { + image delete photo1 +} -result {-palette {} {} {} 3/4/2} +test imgPhoto-4.8 {ImgPhotoCmd procedure: configure option} -setup { + image create photo photo1 +} -body { + photo1 configure -blah +} -cleanup { + image delete photo1 +} -returnCodes error -result {unknown option "-blah"} +test imgPhoto-4.9 {ImgPhotoCmd procedure: configure option} -setup { + image create photo photo1 +} -body { + photo1 configure -palette {} -gamma +} -cleanup { + image delete photo1 +} -returnCodes error -result {value for "-gamma" missing} +test imgPhoto-4.10 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -width 25 -height 30 +} -body { + image create photo photo2 -file $teapotPhotoFile + photo1 configure -width 0 -height 0 -palette {} -gamma 1 + photo1 copy photo2 + list [image width photo1] [image height photo1] [photo1 get 100 100] +} -cleanup { + image delete photo1 photo2 +} -result {256 256 {169 117 90}} +test imgPhoto-4.11 {ImgPhotoCmd procedure: copy option} -setup { + image create photo photo1 +} -body { + photo1 copy +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 copy source-image ?-compositingrule rule? ?-from x1 y1 x2 y2? ?-to x1 y1 x2 y2? ?-zoom x y? ?-subsample x y?"} +test imgPhoto-4.12 {ImgPhotoCmd procedure: copy option} -setup { + image create photo photo1 +} -body { + photo1 copy blah +} -returnCodes error -cleanup { + image delete photo1 +} -result {image "blah" doesn't exist or is not a photo image} +test imgPhoto-4.13 {ImgPhotoCmd procedure: copy option} -setup { + image create photo photo1 + image create photo photo2 +} -body { + photo1 copy photo2 -blah +} -returnCodes error -cleanup { + image delete photo1 photo2 +} -result {unrecognized option "-blah": must be -compositingrule, -from, -shrink, -subsample, -to, or -zoom} +test imgPhoto-4.14 {ImgPhotoCmd procedure: copy option} -setup { + image create photo photo1 + image create photo photo2 +} -body { + photo1 copy photo2 -from -to +} -returnCodes error -cleanup { + image delete photo1 photo2 +} -result {the "-from" option requires one to four integer values} +test imgPhoto-4.15 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 + photo1 copy photo2 -from 0 70 60 120 -shrink + list [image width photo1] [image height photo1] [photo1 get 20 10] +} -cleanup { + image delete photo1 photo2 +} -result {60 50 {215 154 120}} +test imgPhoto-4.16 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 -from 60 120 0 70 -to 20 50 + list [image width photo1] [image height photo1] [photo1 get 40 80] +} -cleanup { + image delete photo1 photo2 +} -result {80 100 {19 92 192}} +test imgPhoto-4.17 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 -from 0 120 60 70 -to 0 0 100 100 + list [image width photo1] [image height photo1] [photo1 get 80 60] +} -cleanup { + image delete photo1 photo2 +} -result {100 100 {215 154 120}} +test imgPhoto-4.18 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 -from 60 70 0 120 -zoom 2 + list [image width photo1] [image height photo1] [photo1 get 100 50] +} -cleanup { + image delete photo1 photo2 +} -result {120 100 {169 99 47}} +test imgPhoto-4.19 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 -from 0 70 60 120 -zoom 2 + list [image width photo1] [image height photo1] [photo1 get 100 50] +} -cleanup { + image delete photo1 photo2 +} -result {120 100 {169 99 47}} +test imgPhoto-4.20 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 -from 20 20 200 180 -subsample 2 -shrink + list [image width photo1] [image height photo1] [photo1 get 50 30] +} -cleanup { + image delete photo1 photo2 +} -result {90 80 {207 146 112}} +test imgPhoto-4.21 {ImgPhotoCmd procedure: copy option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 + image create photo photo2 -file $teapotPhotoFile +} -body { + photo1 copy photo2 + set result [list [image width photo1] [image height photo1]] + photo1 conf -width 49 -height 51 + lappend result [image width photo1] [image height photo1] + photo1 copy photo2 + lappend result [image width photo1] [image height photo1] + photo1 copy photo2 -from 0 0 10 10 -shrink + lappend result [image width photo1] [image height photo1] + photo1 conf -width 0 + photo1 copy photo2 -from 0 0 10 10 -shrink + lappend result [image width photo1] [image height photo1] + photo1 conf -height 0 + photo1 copy photo2 -from 0 0 10 10 -shrink + lappend result [image width photo1] [image height photo1] +} -cleanup { + image delete photo1 photo2 +} -result {256 256 49 51 49 51 49 51 10 51 10 10} +test imgPhoto-4.22 {ImgPhotoCmd procedure: get option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 +} -body { + photo1 read $teapotPhotoFile + list [photo1 get 100 100] [photo1 get 150 100] [photo1 get 100 150] +} -cleanup { + image delete photo1 +} -result {{169 117 90} {172 115 84} {35 35 35}} +test imgPhoto-4.23 {ImgPhotoCmd procedure: get option} -setup { + image create photo photo1 +} -body { + photo1 get 256 0 +} -cleanup { + image delete photo1 +} -returnCodes error -result {photo1 get: coordinates out of range} +test imgPhoto-4.24 {ImgPhotoCmd procedure: get option} -setup { + image create photo photo1 +} -body { + photo1 get 0 -1 +} -cleanup { + image delete photo1 +} -returnCodes error -result {photo1 get: coordinates out of range} +test imgPhoto-4.25 {ImgPhotoCmd procedure: get option} -setup { + image create photo photo1 +} -body { + photo1 get +} -cleanup { + image delete photo1 +} -returnCodes error -result {wrong # args: should be "photo1 get x y"} +test imgPhoto-4.26 {ImgPhotoCmd procedure: put option} -setup { + image create photo photo1 +} -body { + photo1 put +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 put data ?-option value ...?"} +test imgPhoto-4.27 {ImgPhotoCmd procedure: put option} -setup { + image create photo photo1 +} -body { + photo1 put {{white} {white white}} +} -returnCodes error -cleanup { + image delete photo1 +} -result {all elements of color list must have the same number of elements} +test imgPhoto-4.28 {ImgPhotoCmd procedure: put option} -setup { + image create photo photo1 +} -body { + photo1 put {{blahgle}} +} -cleanup { + image delete photo1 +} -returnCodes error -result {can't parse color "blahgle"} +test imgPhoto-4.29 {ImgPhotoCmd procedure: put option} -setup { + image create photo photo1 +} -body { + photo1 put -to 10 10 20 20 {{white}} + photo1 get 19 19 +} -cleanup { + image delete photo1 +} -result {255 255 255} +test imgPhoto-4.30 {ImgPhotoCmd procedure: read option} -setup { + image create photo photo1 +} -body { + photo1 read +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 read fileName ?-option value ...?"} +test imgPhoto-4.31 {ImgPhotoCmd procedure: read option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 +} -body { + photo1 read $teapotPhotoFile -zoom 2 +} -returnCodes error -cleanup { + image delete photo1 +} -result {unrecognized option "-zoom": must be -format, -from, -shrink, or -to} +test imgPhoto-4.32 {ImgPhotoCmd procedure: read option} -setup { + image create photo photo1 +} -body { + list [catch {photo1 read bogus} err] [string tolower $err] +} -cleanup { + image delete photo1 +} -result {1 {couldn't open "bogus": no such file or directory}} +test imgPhoto-4.33 {ImgPhotoCmd procedure: read option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 +} -body { + photo1 read $teapotPhotoFile -format bogus +} -cleanup { + image delete photo1 +} -returnCodes error -result {image file format "bogus" is not supported} +test imgPhoto-4.34 {ImgPhotoCmd procedure: read option} -setup { + image create photo photo1 +} -body { + photo1 read $README +} -returnCodes error -cleanup { + image delete photo1 +} -result [subst {couldn't recognize data in image file "$README"}] +test imgPhoto-4.35 {ImgPhotoCmd procedure: read option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 +} -body { + photo1 read $teapotPhotoFile + list [image width photo1] [image height photo1] [photo1 get 120 120] +} -cleanup { + image delete photo1 +} -result {256 256 {161 109 82}} +test imgPhoto-4.36 {ImgPhotoCmd procedure: read option} -constraints { + hasTeapotPhoto +} -setup { + image create photo photo1 +} -body { + photo1 read $teapotPhotoFile -from 0 70 60 120 -to 10 10 -shrink + list [image width photo1] [image height photo1] [photo1 get 29 19] +} -cleanup { + image delete photo1 +} -result {70 60 {244 180 144}} +test imgPhoto-4.37 {ImgPhotoCmd procedure: redither option} -setup { + image create photo photo1 +} -body { + photo1 redither + photo1 redither x +} -cleanup { + image delete photo1 +} -returnCodes error -result {wrong # args: should be "photo1 redither"} +test imgPhoto-4.38 {ImgPhotoCmd procedure: write option} -setup { + image create photo photo1 +} -body { + photo1 write +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 write fileName ?-option value ...?"} +test imgPhoto-4.39 {ImgPhotoCmd procedure: write option} -setup { + image create photo photo1 +} -body { + photo1 write teapot.tmp -format bogus +} -cleanup { + image delete photo1 +} -returnCodes error -result {image file format "bogus" is unknown} +test imgPhoto-4.40 {ImgPhotoCmd procedure: transparency option} -setup { + image create photo photo1 +} -body { + photo1 transparency +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency option ?arg ...?"} +test imgPhoto-4.41 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency get x y"} +test imgPhoto-4.42 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency get x y"} +test imgPhoto-4.43 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get 0 0 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency get x y"} +test imgPhoto-4.44 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get bogus 0 +} -cleanup { + image delete photo1 +} -returnCodes error -result {expected integer but got "bogus"} +test imgPhoto-4.45 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get 0 bogus +} -cleanup { + image delete photo1 +} -returnCodes error -result {expected integer but got "bogus"} +test imgPhoto-4.46 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 put white + photo1 transparency get 0 0 +} -cleanup { + image delete photo1 +} -result 0 +test imgPhoto-4.47 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get 1 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency get: coordinates out of range} +test imgPhoto-4.48 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get -1 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency get: coordinates out of range} +test imgPhoto-4.49 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get 0 1 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency get: coordinates out of range} +test imgPhoto-4.50 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 transparency get 0 -1 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency get: coordinates out of range} +test imgPhoto-4.51 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 put white + photo1 blank + photo1 transparency get 0 0 +} -cleanup { + image delete photo1 +} -result 1 +test imgPhoto-4.52 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency set x y boolean"} +test imgPhoto-4.53 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency set x y boolean"} +test imgPhoto-4.54 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency set x y boolean"} +test imgPhoto-4.55 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 0 0 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {wrong # args: should be "photo1 transparency set x y boolean"} +test imgPhoto-4.56 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set bogus 0 0 +} -cleanup { + image delete photo1 +} -returnCodes error -result {expected integer but got "bogus"} +test imgPhoto-4.57 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 bogus 0 +} -cleanup { + image delete photo1 +} -returnCodes error -result {expected integer but got "bogus"} +test imgPhoto-4.58 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 0 bogus +} -cleanup { + image delete photo1 +} -returnCodes error -result {expected boolean value but got "bogus"} +test imgPhoto-4.59 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 1 0 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency set: coordinates out of range} +test imgPhoto-4.60 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set -1 0 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency set: coordinates out of range} +test imgPhoto-4.61 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 1 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency set: coordinates out of range} +test imgPhoto-4.62 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 transparency set 0 -1 0 +} -returnCodes error -cleanup { + image delete photo1 +} -result {photo1 transparency set: coordinates out of range} +test imgPhoto-4.63 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 put white + photo1 transparency set 0 0 false + photo1 transparency get 0 0 +} -cleanup { + image delete photo1 +} -result 0 +test imgPhoto-4.64 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 put white + photo1 transparency set 0 0 true + photo1 transparency get 0 0 +} -cleanup { + image delete photo1 +} -result 1 +# Now for some heftier testing, checking that setting and resetting of pixels' +# transparency status doesn't "leak" with any one-off errors. +test imgPhoto-4.65 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 3 3 + checkImgTrans photo1 +} -cleanup { + image delete photo1 +} -result {} +test imgPhoto-4.66 {ImgPhotoCmd procedure: transparency get option} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 3 3 + photo1 blank + checkImgTrans photo1 +} -result {0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2} +test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 3 3 + checkImgTransLoop photo1 { + photo1 put white -to 0 0 3 3 + photo1 transparency set $x $y 1 + } { + photo1 transparency set $x $y 0 } - return $result -} -test imgPhoto-4.67 {ImgPhotoCmd procedure: transparency set option} { - checkImgTransLoopSetReset p1 3 3 -} {0 0 , . 0 1 , . 0 2 , . 1 0 , . 1 1 , . 1 2 , . 2 0 , . 2 1 , . 2 2 , .} -proc checkImgTransLoopResetSet {img width height} { - set result {} - for {set x 0} {$x<$width} {incr x} { - for {set y 0} {$y<$height} {incr y} { - $img blank - $img transparency set $x $y 0 - set result [concat $result [checkImgTrans $img $width $height]] - lappend result , - $img transparency set $x $y 1 - set result [concat $result [checkImgTrans $img $width $height]] - lappend result . - } +} -cleanup { + image delete photo1 +} -result {0,0:. 0,1:. 0,2:. 1,0:. 1,1:. 1,2:. 2,0:. 2,1:. 2,2:.} +test imgPhoto-4.68 {ImgPhotoCmd procedure: transparency set option} -setup { + image create photo photo1 +} -body { + photo1 put white -to 0 0 3 3 + checkImgTransLoop photo1 { + photo1 blank + photo1 transparency set $x $y 0 + } { + photo1 transparency set $x $y 1 } - return $result -} -test imgPhoto-4.67a {ImgPhotoCmd procedure: transparency set option} { - checkImgTransLoopResetSet p1 3 3 -} {0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 2 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 1 0 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 1 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 2 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 2 0 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 1 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 2 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 . 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 , 0 0 0 1 0 2 1 0 1 1 1 2 2 0 2 1 2 2 .} -catch {rename checkImgTransLoopSetReset {}} -catch {rename checkImgTransLoopResetSet {}} -# Test the compositing rules for copying images -image create photo p1 -width 3 -height 3 -image create photo p2 -width 2 -height 2 -test imgPhoto-4.68 {ImgPhotoCmd procedure: copy with -compositingrule} { - list [catch {p1 copy p2 -to 1 1 -compositingrule} msg] $msg -} {1 {the "-compositingrule" option requires a value}} -test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} { - list [catch {p1 copy p2 -to 1 1 -compositingrule BAD} msg] $msg -} {1 {bad compositing rule "BAD": must be overlay or set}} -test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} { +} -cleanup { + image delete photo1 +} -result {0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,2 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 1,0 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,1 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,2 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 2,0 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,1 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,2: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2. 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1: 0,0 0,1 0,2 1,0 1,1 1,2 2,0 2,1 2,2.} +test imgPhoto-4.69 {ImgPhotoCmd procedure: copy with -compositingrule} -setup { + # Test the compositing rules for copying images + image create photo photo1 -width 3 -height 3 + image create photo photo2 -width 2 -height 2 +} -body { + photo1 copy photo2 -to 1 1 -compositingrule +} -cleanup { + image delete photo1 photo2 +} -returnCodes error -result {the "-compositingrule" option requires a value} +test imgPhoto-4.70 {ImgPhotoCmd procedure: copy with -compositingrule} -setup { + # Test the compositing rules for copying images + image create photo photo1 -width 3 -height 3 + image create photo photo2 -width 2 -height 2 +} -body { + photo1 copy photo2 -to 1 1 -compositingrule BAD +} -returnCodes error -cleanup { + image delete photo1 photo2 +} -result {bad compositing rule "BAD": must be overlay or set} +test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} -setup { + # Test the compositing rules for copying images + image create photo photo1 -width 3 -height 3 + image create photo photo2 -width 2 -height 2 +} -body { # Tests default compositing rule - p1 blank - p2 blank - p1 put white -to 0 0 2 2 - p2 put white -to 0 0 2 2 - p2 transparency set 0 0 true - p1 copy p2 -to 1 1 - checkImgTrans p1 3 3 -} {0 2 2 0} -test imgPhoto-4.71 {ImgPhotoCmd procedure: copy with -compositingrule} { - p1 blank - p2 blank - p1 put white -to 0 0 2 2 - p2 put white -to 0 0 2 2 - p2 transparency set 0 0 true - p1 copy p2 -to 1 1 -compositingrule overlay - checkImgTrans p1 3 3 -} {0 2 2 0} -test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} { - p1 blank - p2 blank - p1 put white -to 0 0 2 2 - p2 put white -to 0 0 2 2 - p2 transparency set 0 0 true - p1 copy p2 -to 1 1 -compositingrule set - checkImgTrans p1 3 3 -} {0 2 1 1 2 0} -catch {rename checkImgTrans {}} + photo1 blank + photo2 blank + photo1 put white -to 0 0 2 2 + photo2 put white -to 0 0 2 2 + photo2 transparency set 0 0 true + photo1 copy photo2 -to 1 1 + checkImgTrans photo1 +} -cleanup { + image delete photo1 photo2 +} -result {0,2 2,0} +test imgPhoto-4.72 {ImgPhotoCmd procedure: copy with -compositingrule} -setup { + # Test the compositing rules for copying images + image create photo photo1 -width 3 -height 3 + image create photo photo2 -width 2 -height 2 +} -body { + photo1 blank + photo2 blank + photo1 put white -to 0 0 2 2 + photo2 put white -to 0 0 2 2 + photo2 transparency set 0 0 true + photo1 copy photo2 -to 1 1 -compositingrule overlay + checkImgTrans photo1 +} -cleanup { + image delete photo1 photo2 +} -result {0,2 2,0} +test imgPhoto-4.73 {ImgPhotoCmd procedure: copy with -compositingrule} -setup { + # Test the compositing rules for copying images + image create photo photo1 -width 3 -height 3 + image create photo photo2 -width 2 -height 2 +} -body { + photo1 blank + photo2 blank + photo1 put white -to 0 0 2 2 + photo2 put white -to 0 0 2 2 + photo2 transparency set 0 0 true + photo1 copy photo2 -to 1 1 -compositingrule set + checkImgTrans photo1 +} -cleanup { + image delete photo1 photo2 +} -result {0,2 1,1 2,0} -test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} hasTeapotPhoto { - eval image delete [image names] - .c delete all - image create photo p1 -file $teapotPhotoFile - .c create image 0 0 -image p1 -tags p1.1 - .c create image 256 0 -image p1 -tags p1.2 - .c create image 0 256 -image p1 -tags p1.3 +test imgPhoto-5.1 {ImgPhotoGet/Free procedures, shared instances} -constraints { + hasTeapotPhoto +} -setup { + destroy .c + pack [canvas .c] + imageCleanup +} -body { + image create photo photo1 -file $teapotPhotoFile + .c create image 0 0 -image photo1 -tags photo1.1 + .c create image 256 0 -image photo1 -tags photo1.2 + .c create image 0 256 -image photo1 -tags photo1.3 update .c delete i1.1 - p1 configure -width 1 + photo1 configure -width 1 update .c delete i1.2 - p1 configure -height 1 + photo1 configure -height 1 update - image delete p1 -} {} + image delete photo1 +} -cleanup { + destroy .c +} -result {} -test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} { - .c delete all - image create photo p1 -width 10 -height 10 - p1 blank - .c create image 10 10 -image p1 +test imgPhoto-6.1 {ImgPhotoDisplay procedure, blank display} -setup { + destroy .c + pack [canvas .c] + imageCleanup +} -body { + image create photo photo1 -width 10 -height 10 + photo1 blank + .c create image 10 10 -image photo1 update -} {} +} -cleanup { + destroy .c + image delete photo1 +} -result {} -test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} hasTeapotPhoto { - eval image delete [image names] - .c delete all - image create photo p1 -file $teapotPhotoFile - .c create image 0 0 -image p1 -anchor nw +test imgPhoto-7.1 {ImgPhotoFree procedure, resource freeing} -constraints { + hasTeapotPhoto +} -setup { + destroy .c + pack [canvas .c] + imageCleanup +} -body { + image create photo photo1 -file $teapotPhotoFile + .c create image 0 0 -image photo1 -anchor nw update .c delete all - image delete p1 -} {} -test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} hasTeapotPhoto { - image create photo p1 -file $teapotPhotoFile - .c create image 10 10 -image p1 -anchor nw - button .b1 -image p1 - button .b2 -image p1 - button .b3 -image p1 + image delete photo1 +} -cleanup { + destroy .c +} -result {} +test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} -constraints { + hasTeapotPhoto +} -setup { + deleteWindows + imageCleanup +} -body { + image create photo photo1 -file $teapotPhotoFile + pack [canvas .c] + .c create image 10 10 -image photo1 -anchor nw + button .b1 -image photo1 + button .b2 -image photo1 + button .b3 -image photo1 pack .b1 .b2 .b3 update destroy .b2 @@ -490,12 +871,20 @@ test imgPhoto-7.2 {ImgPhotoFree procedures, unlinking} hasTeapotPhoto { destroy .b1 update .c delete all -} {} -test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} hasTeapotPhoto { - image create photo p1 -file $teapotPhotoFile - button .b1 -image p1 +} -cleanup { + destroy .c + image delete photo1 +} -result {} +test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} -constraints { + hasTeapotPhoto +} -setup { + deleteWindows + imageCleanup +} -body { + image create photo photo1 -file $teapotPhotoFile + button .b1 -image photo1 frame .f -visual best - button .f.b2 -image p1 + button .f.b2 -image photo1 pack .f.b2 pack .b1 .f update @@ -504,59 +893,71 @@ test imgPhoto-7.3 {ImgPhotoFree procedures, multiple visuals} hasTeapotPhoto { .f.b2 configure -image {} update destroy .f - image delete p1 -} {} + image delete photo1 +} -result {} -test imgPhoto-8.1 {ImgPhotoDelete procedure} hasTeapotPhoto { - image create photo p2 -file $teapotPhotoFile - image delete p2 -} {} -test imagePhoto-8.2 {ImgPhotoDelete procedure} hasTeapotPhoto { - image create photo p2 -file $teapotPhotoFile - rename p2 newp2 - set x [list [info command p2] [info command new*] [newp2 cget -file]] - image delete p2 - append x [info command new*] -} [list {} newp2 $teapotPhotoFile] -test imagePhoto-8.3 {ImgPhotoDelete procedure, name cleanup} { - image create photo p1 - image create photo p2 -width 10 -height 10 - image delete p2 - list [catch {p1 copy p2} msg] $msg -} {1 {image "p2" doesn't exist or is not a photo image}} +test imgPhoto-8.1 {ImgPhotoDelete procedure} -constraints hasTeapotPhoto -body { + image create photo photo2 -file $teapotPhotoFile + image delete photo2 +} -result {} +test imgPhoto-8.2 {ImgPhotoDelete procedure} -constraints { + hasTeapotPhoto +} -setup { + set x {} +} -body { + image create photo photo2 -file $teapotPhotoFile + rename photo2 newphoto2 + lappend x [info command photo2] [info command new*] [newphoto2 cget -file] + image delete photo2 + lappend x [info command new*] +} -result [list {} newphoto2 $teapotPhotoFile {}] +test imgPhoto-8.3 {ImgPhotoDelete procedure, name cleanup} -body { + image create photo photo1 + image create photo photo2 -width 10 -height 10 + image delete photo2 + photo1 copy photo2 +} -returnCodes error -cleanup { + imageCleanup +} -result {image "photo2" doesn't exist or is not a photo image} -test imagePhoto-9.1 {ImgPhotoCmdDeletedProc procedure} hasTeapotPhoto { - image create photo p2 -file $teapotPhotoFile - rename p2 {} - list [lsearch -exact [image names] p2] [catch {p2 foo} msg] $msg -} {-1 1 {invalid command name "p2"}} +test imgPhoto-9.1 {ImgPhotoCmdDeletedProc procedure} -constraints { + hasTeapotPhoto +} -body { + image create photo photo2 -file $teapotPhotoFile + rename photo2 {} + list [lsearch -exact [imageNames] photo2] [catch {photo2 foo} msg] $msg +} -result {-1 1 {invalid command name "photo2"}} -test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} { - eval image delete [image names] - image create photo p1 - p1 put {{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}} -to 0 0 - p1 put {{#00ff00 #00ff00}} -to 2 0 - list [p1 get 2 0] [p1 get 3 0] [p1 get 4 0] -} {{0 255 0} {0 255 0} {255 0 0}} +test imgPhoto-10.1 {Tk_ImgPhotoPutBlock procedure} -setup { + imageCleanup +} -body { + image create photo photo1 + photo1 put "{#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000}" -to 0 0 + photo1 put "{#00ff00 #00ff00}" -to 2 0 + list [photo1 get 2 0] [photo1 get 3 0] [photo1 get 4 0] +} -result {{0 255 0} {0 255 0} {255 0 0}} -test imgPhoto-11.1 {Tk_FindPhoto} { - eval image delete [image names] +test imgPhoto-11.1 {Tk_FindPhoto} -setup { + imageCleanup +} -body { image create bitmap i1 - image create photo p1 - list [catch {p1 copy i1} msg] $msg -} {1 {image "i1" doesn't exist or is not a photo image}} + image create photo photo1 + photo1 copy i1 +} -cleanup { + imageCleanup +} -returnCodes error -result {image "i1" doesn't exist or is not a photo image} -test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} hasTeapotPhoto { +test imgPhoto-12.1 {Tk_PhotoPutZoomedBlock} -constraints hasTeapotPhoto -body { image create photo p3 -file $teapotPhotoFile set result [list [p3 get 50 50] [p3 get 100 100]] p3 copy p3 -zoom 2 lappend result [image width p3] [image height p3] [p3 get 100 100] +} -cleanup { image delete p3 - set result -} {{19 92 192} {169 117 90} 512 512 {19 92 192}} +} -result {{19 92 192} {169 117 90} 512 512 {19 92 192}} -test imgPhoto-13.1 {check separation of images in different interpreters} { - image delete {*}[image names] +test imgPhoto-13.1 {check separation of images in different interpreters} -setup { + imageCleanup set data { R0lGODlhQgBkAPUAANbWxs7Wxs7OxsbOxsbGxsbGvb3Gvca9vcDAwL21vbW1vbW1tbWtta2t ta2ltaWltaWlraWctaWcrZycrZyUrZSUrZSMrZSMpYyMrYyMpYyEpYSEpYR7pYR7nHp7pYRz @@ -592,82 +993,79 @@ test imgPhoto-13.1 {check separation of images in different interpreters} { interp create x2 x1 eval {load {} Tk} x2 eval {load {} Tk} +} -body { x1 eval [list image create photo T1_data -data $data] x2 eval [list image create photo T1_data -data $data] - unset data +} -cleanup { interp delete x1 interp delete x2 -} {} +} -result T1_data -test imgPhoto-14.1 {GIF writes work correctly} { - set data "R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM -hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA -AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwP8AAAD/ -AP//AAAA//8A/wD//////ywAAAAAYwA5AAAI/wAZCBxIsKDBgwgTKlzIsKHD -hxAjSpxIsaLFixgzatzIsaPHjyBDihxJsqTJkyhTqlzJsqXLlzBjypxJs6bN -mzhz6tzJs6fPn0CDCh1KtKhRiwoSKEXAtGlTpUqPGkyagOmCq1edNsWalWkC -BUSXIuDqFepBqFWtZv3KU+zYrkrBSqT6dgECtjOTbu16NwFHvV3lshRLti/J -qlgRCE6ZuO9ik4Dt+k0ZVyZiyVIvXr77ODPEy5g9T4zMWfTEzXdNz1VbWvXn -uqldP1TAOrbshqBb314Y2W7n3Qdpv7UNPCHpycUVbv6dnODy5sqzQldIe8H0 -hciva9/Ovbv37+BzBgEEADs= -" - set photo [image create photo -data $data] - set filename [makeFile {} imgPhoto-14.1.gif] - removeFile imgPhoto-14.1.gif - $photo write $filename -format gif - set photo2 [image create photo -file $filename] - set result [string equal [$photo data] [$photo2 data]] - image delete $photo $photo2 - catch {file delete -force $filename} - set result -} 1 -test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup { - set i [image create photo] +test imgPhoto-14.1 {GIF writes work correctly} -setup { + set data { + R0lGODlhYwA5APcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgAysnGy8hKzM + hASs3MTcjAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAMDAwP8AAAD/ + AP//AAAA//8A/wD//////ywAAAAAYwA5AAAI/wAZCBxIsKDBgwgTKlzIsKHD + hxAjSpxIsaLFixgzatzIsaPHjyBDihxJsqTJkyhTqlzJsqXLlzBjypxJs6bN + mzhz6tzJs6fPn0CDCh1KtKhRiwoSKEXAtGlTpUqPGkyagOmCq1edNsWalWkC + BUSXIuDqFepBqFWtZv3KU+zYrkrBSqT6dgECtjOTbu16NwFHvV3lshRLti/J + qlgRCE6ZuO9ik4Dt+k0ZVyZiyVIvXr77ODPEy5g9T4zMWfTEzXdNz1VbWvXn + uqldP1TAOrbshqBb314Y2W7n3Qdpv7UNPCHpycUVbv6dnODy5sqzQldIe8H0 + hciva9/Ovbv37+BzBgEEADs= + } + set tmpfilename [makeFile {} imgPhoto-14.1.gif] + removeFile $tmpfilename } -body { - # Bug 1458234 makes this crash when trying to access buffers of the - # wrong size, caused when the initial frame is not the largest frame. + image create photo photo1 -data $data + photo1 write $tmpfilename -format gif + image create photo photo2 -file $tmpfilename + string equal [photo1 data] [photo2 data] +} -cleanup { + catch {image delete photo1 photo2} + catch {file delete -force $tmpfilename} +} -result 1 +test imgPhoto-14.2 {GIF -index handler buffer sizing} -setup { set data { R0lGODlhIAAgAKEAAPkOSQsi7////////yH/C05FVFNDQVBFMi4wAwEAAAAh +QQJMgAAACwGAAYAFAAUAAACEYyPqcvtD6OctNqLs968+68VACH5BAkyAAEA LAMAAwAaABoAAAI0jH+gq+gfmFzQzUsr3gBybn1gIm5kaUaoubbuC8fyTNel Ohv1CSO533u8KrgbUfc5Ci/EAgA7 } +} -body { + # Bug 1458234 makes this crash when trying to access buffers of the wrong + # size, caused when the initial frame is not the largest frame. + set i [image create photo] $i configure -data $data -format {gif -index 2} } -cleanup { image delete $i } -returnCodes error -result {no image data for this index} - -test imgPhoto-14.3 {GIF -index interleaving and small frames} -setup { +test imgPhoto-14.3 {GIF -index interleaving and small frames} -body { + # Interleaved GIFs used to crash us when a smaller subsequent frame was + # accessed. set i [image create photo] -} -body { - # Interleaved GIFs used to crash us when a smaller subsequent frame - # was accessed. $i configure -format {GIF -index 1} -data { R0lGODdhAQAFAPAAAP8AAAAAACwAAAAAAQAFAEACAoRdACwAAAAAAQAEAEACAoRRADs= } } -cleanup { image delete $i } - test imgPhoto-14.4 {GIF buffer overflow} -setup { - set i [image create photo] -} -body { - # This crashes Tk up to 8.4.17 and 8.5.0 - $i configure -data { + set data { R0lGODlhCgAKAPcAAAAAAIAAAACAAICAAAAAgIAAgACAgICAgMDAwP8AAAD/ AP//AAAA//8A/wD//////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA @@ -687,30 +1085,85 @@ test imgPhoto-14.4 {GIF buffer overflow} -setup { mf9mzP9m//+ZAP+ZM/+ZZv+Zmf+ZzP+Z///MAP/MM//MZv/Mmf/MzP/M//// AP//M///Zv//mf//zP///yH5BAEAABAALAAAAAAKAAoAABUSAAD/HEiwoMGD CBMqXMiwYcKAADs= - } + } +} -body { + # This crashes Tk up to 8.4.17 and 8.5.0 + set i [image create photo] + $i configure -data $data } -cleanup { image delete $i } -returnCodes error -result {malformed image} -test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} \ - {nonPortable} { - # This is not portable to very large machines with more around - # 3GB of free memory available... - list [catch {image create photo -width 32000 -height 32000} msg] $msg -} {1 {not enough free memory for image buffer}} +test imgPhoto-15.1 {photo images can fail to allocate memory gracefully} -constraints { + nonPortable +} -body { + # This is not portable to very large machines with more than around 3GB of + # free memory available... + image create photo -width 32000 -height 32000 +} -returnCodes error -result {not enough free memory for image buffer} -test imgPhoto-16.1 {copying to self doesn't access freed memory} { - # Bug 877950 makes this crash when trying to copy out of a deallocated area +test imgPhoto-16.1 {copying to self doesn't access freed memory} -setup { set i [image create photo] +} -body { + # Bug 877950 makes this crash when trying to copy out of a deallocated + # area. $i put red -to 0 0 1000 1000 $i copy $i -from 0 0 1000 1000 -to 500 0 +} -cleanup { + image delete $i +} -result {} + +# Check that we can guess our supported output formats [Bug 2983824] +test imgPhoto-17.1 {photo write: format guessing from filename} -setup { + set i [image create photo -width 3 -height 3] +} -body { + set f [makeFile {} test.png] + $i write $f + set fd [open $f] + seek $fd 1 + read $fd 3 +} -cleanup { + catch {close $fd} + image delete $i + catch {removeFile $f} +} -result PNG +test imgPhoto-17.2 {photo write: format guessing from filename} -setup { + set i [image create photo -width 3 -height 3] +} -body { + set f [makeFile {} test.gif] + $i write $f + set fd [open $f] + read $fd 3 +} -cleanup { + catch {close $fd} + image delete $i + catch {removeFile $f} +} -result GIF +test imgPhoto-17.3 {photo write: format guessing from filename} -setup { + set i [image create photo -width 3 -height 3] +} -body { + set f [makeFile {} test.ppm] + $i write $f + set fd [open $f] + read $fd 3 +} -cleanup { + catch {close $fd} image delete $i -} {} + catch {removeFile $f} +} -result "P6\n" -destroy .c -eval image delete [image names] +# ---------------------------------------------------------------------- + +catch {rename foreachPixel {}} +catch {rename checkImgTrans {}} +catch {rename checkImgTransLoop {}} +imageFinish # cleanup removeFile README-imgPhoto cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/listbox.test b/tests/listbox.test index 25bc606..0805528 100644 --- a/tests/listbox.test +++ b/tests/listbox.test @@ -6,9 +6,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test set fixed {Courier -12} @@ -39,7 +40,7 @@ proc resetGridInfo {} { # to partially visible lines. proc mkPartial {{w .partial}} { - catch {destroy $w} + destroy $w toplevel $w wm geometry $w +0+0 listbox $w.l -width 30 -height 5 @@ -59,128 +60,332 @@ option add *Listbox.borderWidth 2 option add *Listbox.highlightThickness 2 option add *Listbox.font {Helvetica -12 bold} +# Listbox used in 3.* configuration options tests listbox .l pack .l update resetGridInfo -set i 1 - -foreach test { - {-activestyle under underline foo {bad activestyle "foo": must be dotbox, none, or underline}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-disabledforeground #110022 #110022 bogus {unknown color name "bogus"}} - {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-height 30 30 20p {expected integer but got "20p"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} - {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} - {-highlightthickness -2 0 {} {}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} - {-selectmode string string {} {}} - {-setgrid false 0 lousy {expected boolean value but got "lousy"}} - {-state disabled disabled foo {bad state "foo": must be disabled or normal}} - {-takefocus "any string" "any string" {} {}} - {-width 45 45 3p {expected integer but got "3p"}} - {-xscrollcommand {Some command} {Some command} {} {}} - {-yscrollcommand {Another command} {Another command} {} {}} - {-listvar testVariable testVariable {} {}} -} { - set name [lindex $test 0] - test listbox-1.$i {configuration options} { - .l configure $name [lindex $test 1] - list [lindex [.l configure $name] 4] [.l cget $name] - } [list [lindex $test 2] [lindex $test 2]] - incr i - if {[lindex $test 3] != ""} { - test listbox-1.$i {configuration options} { - list [catch {.l configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .l configure $name [lindex [.l configure $name] 3] - incr i -} +test listbox-1.1 {configuration options} -body { + .l configure -activestyle under + list [lindex [.l configure -activestyle] 4] [.l cget -activestyle] +} -cleanup { + .l configure -activestyle [lindex [.l configure -activestyle] 3] +} -result {underline underline} +test listbox-1.2 {configuration options} -body { + .l configure -activestyle foo +} -returnCodes error -result {bad activestyle "foo": must be dotbox, none, or underline} +test listbox-1.3 {configuration options} -body { + .l configure -background #ff0000 + list [lindex [.l configure -background] 4] [.l cget -background] +} -cleanup { + .l configure -background [lindex [.l configure -background] 3] +} -result {{#ff0000} #ff0000} +test listbox-1.4 {configuration options} -body { + .l configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test listbox-1.5 {configuration options} -body { + .l configure -bd 4 + list [lindex [.l configure -bd] 4] [.l cget -bd] +} -cleanup { + .l configure -bd [lindex [.l configure -bd] 3] +} -result {4 4} +test listbox-1.6 {configuration options} -body { + .l configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test listbox-1.7 {configuration options} -body { + .l configure -bg #ff0000 + list [lindex [.l configure -bg] 4] [.l cget -bg] +} -cleanup { + .l configure -bg [lindex [.l configure -bg] 3] +} -result {{#ff0000} #ff0000} +test listbox-1.8 {configuration options} -body { + .l configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test listbox-1.9 {configuration options} -body { + .l configure -borderwidth 1.3 + list [lindex [.l configure -borderwidth] 4] [.l cget -borderwidth] +} -cleanup { + .l configure -borderwidth [lindex [.l configure -borderwidth] 3] +} -result {1 1} +test listbox-1.10 {configuration options} -body { + .l configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test listbox-1.11 {configuration options} -body { + .l configure -cursor arrow + list [lindex [.l configure -cursor] 4] [.l cget -cursor] +} -cleanup { + .l configure -cursor [lindex [.l configure -cursor] 3] +} -result {arrow arrow} +test listbox-1.12 {configuration options} -body { + .l configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test listbox-1.13 {configuration options} -body { + .l configure -disabledforeground #110022 + list [lindex [.l configure -disabledforeground] 4] [.l cget -disabledforeground] +} -cleanup { + .l configure -disabledforeground [lindex [.l configure -disabledforeground] 3] +} -result {{#110022} #110022} +test listbox-1.14 {configuration options} -body { + .l configure -disabledforeground bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-1.15 {configuration options} -body { + .l configure -exportselection yes + list [lindex [.l configure -exportselection] 4] [.l cget -exportselection] +} -cleanup { + .l configure -exportselection [lindex [.l configure -exportselection] 3] +} -result {1 1} +test listbox-1.16 {configuration options} -body { + .l configure -exportselection xyzzy +} -returnCodes error -result {expected boolean value but got "xyzzy"} +test listbox-1.17 {configuration options} -body { + .l configure -fg #110022 + list [lindex [.l configure -fg] 4] [.l cget -fg] +} -cleanup { + .l configure -fg [lindex [.l configure -fg] 3] +} -result {{#110022} #110022} +test listbox-1.18 {configuration options} -body { + .l configure -fg bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-1.19 {configuration options} -body { + .l configure -font {Helvetica 12} + list [lindex [.l configure -font] 4] [.l cget -font] +} -cleanup { + .l configure -font [lindex [.l configure -font] 3] +} -result {{Helvetica 12} {Helvetica 12}} +test listbox-1.21 {configuration options} -body { + .l configure -foreground #110022 + list [lindex [.l configure -foreground] 4] [.l cget -foreground] +} -cleanup { + .l configure -foreground [lindex [.l configure -foreground] 3] +} -result {{#110022} #110022} +test listbox-1.22 {configuration options} -body { + .l configure -foreground bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-1.23 {configuration options} -body { + .l configure -height 30 + list [lindex [.l configure -height] 4] [.l cget -height] +} -cleanup { + .l configure -height [lindex [.l configure -height] 3] +} -result {30 30} +test listbox-1.24 {configuration options} -body { + .l configure -height 20p +} -returnCodes error -result {expected integer but got "20p"} +test listbox-1.25 {configuration options} -body { + .l configure -highlightbackground #112233 + list [lindex [.l configure -highlightbackground] 4] [.l cget -highlightbackground] +} -cleanup { + .l configure -highlightbackground [lindex [.l configure -highlightbackground] 3] +} -result {{#112233} #112233} +test listbox-1.26 {configuration options} -body { + .l configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test listbox-1.27 {configuration options} -body { + .l configure -highlightcolor #123456 + list [lindex [.l configure -highlightcolor] 4] [.l cget -highlightcolor] +} -cleanup { + .l configure -highlightcolor [lindex [.l configure -highlightcolor] 3] +} -result {{#123456} #123456} +test listbox-1.28 {configuration options} -body { + .l configure -highlightcolor bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-1.29 {configuration options} -body { + .l configure -highlightthickness 6 + list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness] +} -cleanup { + .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3] +} -result {6 6} +test listbox-1.30 {configuration options} -body { + .l configure -highlightthickness bogus +} -returnCodes error -result {bad screen distance "bogus"} +test listbox-1.31 {configuration options} -body { + .l configure -highlightthickness -2 + list [lindex [.l configure -highlightthickness] 4] [.l cget -highlightthickness] +} -cleanup { + .l configure -highlightthickness [lindex [.l configure -highlightthickness] 3] +} -result {0 0} +test listbox-1.33 {configuration options} -body { + .l configure -relief groove + list [lindex [.l configure -relief] 4] [.l cget -relief] +} -cleanup { + .l configure -relief [lindex [.l configure -relief] 3] +} -result {groove groove} +test listbox-1.34 {configuration options} -body { + .l configure -relief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test listbox-1.35 {configuration options} -body { + .l configure -selectbackground #110022 + list [lindex [.l configure -selectbackground] 4] [.l cget -selectbackground] +} -cleanup { + .l configure -selectbackground [lindex [.l configure -selectbackground] 3] +} -result {{#110022} #110022} +test listbox-1.36 {configuration options} -body { + .l configure -selectbackground bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-1.37 {configuration options} -body { + .l configure -selectborderwidth 1.3 + list [lindex [.l configure -selectborderwidth] 4] [.l cget -selectborderwidth] +} -cleanup { + .l configure -selectborderwidth [lindex [.l configure -selectborderwidth] 3] +} -result {1 1} +test listbox-1.38 {configuration options} -body { + .l configure -selectborderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test listbox-1.39 {configuration options} -body { + .l configure -selectforeground #654321 + list [lindex [.l configure -selectforeground] 4] [.l cget -selectforeground] +} -cleanup { + .l configure -selectforeground [lindex [.l configure -selectforeground] 3] +} -result {{#654321} #654321} +test listbox-1.40 {configuration options} -body { + .l configure -selectforeground bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-1.41 {configuration options} -body { + .l configure -selectmode string + list [lindex [.l configure -selectmode] 4] [.l cget -selectmode] +} -cleanup { + .l configure -selectmode [lindex [.l configure -selectmode] 3] +} -result {string string} +test listbox-1.43 {configuration options} -body { + .l configure -setgrid false + list [lindex [.l configure -setgrid] 4] [.l cget -setgrid] +} -cleanup { + .l configure -setgrid [lindex [.l configure -setgrid] 3] +} -result {0 0} +test listbox-1.44 {configuration options} -body { + .l configure -setgrid lousy +} -returnCodes error -result {expected boolean value but got "lousy"} +test listbox-1.45 {configuration options} -body { + .l configure -state disabled + list [lindex [.l configure -state] 4] [.l cget -state] +} -cleanup { + .l configure -state [lindex [.l configure -state] 3] +} -result {disabled disabled} +test listbox-1.46 {configuration options} -body { + .l configure -state foo +} -returnCodes error -result {bad state "foo": must be disabled or normal} +test listbox-1.47 {configuration options} -body { + .l configure -takefocus {any string} + list [lindex [.l configure -takefocus] 4] [.l cget -takefocus] +} -cleanup { + .l configure -takefocus [lindex [.l configure -takefocus] 3] +} -result {{any string} {any string}} +test listbox-1.49 {configuration options} -body { + .l configure -width 45 + list [lindex [.l configure -width] 4] [.l cget -width] +} -cleanup { + .l configure -width [lindex [.l configure -width] 3] +} -result {45 45} +test listbox-1.50 {configuration options} -body { + .l configure -width 3p +} -returnCodes error -result {expected integer but got "3p"} +test listbox-1.51 {configuration options} -body { + .l configure -xscrollcommand {Some command} + list [lindex [.l configure -xscrollcommand] 4] [.l cget -xscrollcommand] +} -cleanup { + .l configure -xscrollcommand [lindex [.l configure -xscrollcommand] 3] +} -result {{Some command} {Some command}} +test listbox-1.53 {configuration options} -body { + .l configure -yscrollcommand {Another command} + list [lindex [.l configure -yscrollcommand] 4] [.l cget -yscrollcommand] +} -cleanup { + .l configure -yscrollcommand [lindex [.l configure -yscrollcommand] 3] +} -result {{Another command} {Another command}} +test listbox-1.55 {configuration options} -body { + .l configure -listvar testVariable + list [lindex [.l configure -listvar] 4] [.l cget -listvar] +} -cleanup { + .l configure -listvar [lindex [.l configure -listvar] 3] +} -result {testVariable testVariable} + -test listbox-2.1 {Tk_ListboxCmd procedure} { - list [catch {listbox} msg] $msg -} {1 {wrong # args: should be "listbox pathName ?options?"}} -test listbox-2.2 {Tk_ListboxCmd procedure} { - list [catch {listbox gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test listbox-2.3 {Tk_ListboxCmd procedure} { - catch {destroy .l} +test listbox-2.1 {Tk_ListboxCmd procedure} -body { + listbox +} -returnCodes error -result {wrong # args: should be "listbox pathName ?-option value ...?"} +test listbox-2.2 {Tk_ListboxCmd procedure} -body { + listbox gorp +} -returnCodes error -result {bad window path name "gorp"} +test listbox-2.3 {Tk_ListboxCmd procedure} -setup { + destroy .l +} -body { listbox .l list [winfo exists .l] [winfo class .l] [info commands .l] -} {1 Listbox .l} -test listbox-2.4 {Tk_ListboxCmd procedure} { - catch {destroy .l} - list [catch {listbox .l -gorp foo} msg] $msg [winfo exists .l] \ - [info commands .l] -} {1 {unknown option "-gorp"} 0 {}} -test listbox-2.5 {Tk_ListboxCmd procedure} { - catch {destroy .l} +} -result {1 Listbox .l} +test listbox-2.4 {Tk_ListboxCmd procedure} -setup { + destroy .l +} -body { + listbox .l -gorp foo +} -cleanup { + destroy .l +} -returnCodes error -result {unknown option "-gorp"} +test listbox-2.4.1 {Tk_ListboxCmd procedure} -setup { + destroy .l +} -body { + catch {listbox .l -gorp foo} + list [winfo exists .l] [info commands .l] +} -cleanup { + destroy .l +} -result {0 {}} +test listbox-2.5 {Tk_ListboxCmd procedure} -setup { + destroy .l +} -body { listbox .l -} {.l} +} -cleanup { + destroy .l +} -result {.l} -catch {destroy .l} + +# Listbox used in 3.1 -3.115 tests +destroy .l listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 pack .l .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ el15 el16 el17 update -test listbox-3.1 {ListboxWidgetCmd procedure} { - list [catch .l msg] $msg -} {1 {wrong # args: should be ".l option ?arg arg ...?"}} -test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} { - list [catch {.l activate} msg] $msg -} {1 {wrong # args: should be ".l activate index"}} -test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} { - list [catch {.l activate a b} msg] $msg -} {1 {wrong # args: should be ".l activate index"}} -test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} { - list [catch {.l activate fooey} msg] $msg -} {1 {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}} -test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} { +test listbox-3.1 {ListboxWidgetCmd procedure} -body { + .l +} -returnCodes error -result {wrong # args: should be ".l option ?arg ...?"} +test listbox-3.2 {ListboxWidgetCmd procedure, "activate" option} -body { + .l activate +} -returnCodes error -result {wrong # args: should be ".l activate index"} +test listbox-3.3 {ListboxWidgetCmd procedure, "activate" option} -body { + .l activate a b +} -returnCodes error -result {wrong # args: should be ".l activate index"} +test listbox-3.4 {ListboxWidgetCmd procedure, "activate" option} -body { + .l activate fooey +} -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number} +test listbox-3.5 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate 3 .l index active -} 3 -test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} { +} -result 3 +test listbox-3.6 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate -1 .l index active -} {0} -test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} { +} -result {0} +test listbox-3.7 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate 30 .l index active -} {17} -test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} { +} -result {17} +test listbox-3.8 {ListboxWidgetCmd procedure, "activate" option} -body { .l activate end .l index active -} {17} -test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} { - list [catch {.l bbox} msg] $msg -} {1 {wrong # args: should be ".l bbox index"}} -test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} { - list [catch {.l bbox a b} msg] $msg -} {1 {wrong # args: should be ".l bbox index"}} -test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} { - list [catch {.l bbox fooey} msg] $msg -} {1 {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number}} -test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} { +} -result {17} +test listbox-3.9 {ListboxWidgetCmd procedure, "bbox" option} -body { + .l bbox +} -returnCodes error -result {wrong # args: should be ".l bbox index"} +test listbox-3.10 {ListboxWidgetCmd procedure, "bbox" option} -body { + .l bbox a b +} -returnCodes error -result {wrong # args: should be ".l bbox index"} +test listbox-3.11 {ListboxWidgetCmd procedure, "bbox" option} -body { + .l bbox fooey +} -returnCodes error -result {bad listbox index "fooey": must be active, anchor, end, @x,y, or a number} +test listbox-3.12 {ListboxWidgetCmd procedure, "bbox" option} -body { .l yview 3 update list [.l bbox 2] [.l bbox 8] -} {{} {}} -test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} { +} -result {{} {}} +test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} -cleanup { + destroy .l2 +} -body { # Used to generate a core dump before a bug was fixed (the last # element would be on-screen if it existed, but it doesn't exist). @@ -190,24 +395,35 @@ test listbox-3.13 {ListboxWidgetCmd procedure, "bbox" option} { set x [.l2 bbox 0] destroy .l2 set x -} {} -test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { +} -cleanup { + destroy .l2 +} -result {} +test listbox-3.14 {ListboxWidgetCmd procedure, "bbox" option} -constraints { + fonts +} -body { .l yview 3 update list [.l bbox 3] [.l bbox 4] -} {{7 7 17 14} {7 26 17 14}} -test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { +} -result {{7 7 17 14} {7 26 17 14}} +test listbox-3.15 {ListboxWidgetCmd procedure, "bbox" option} -constraints { + fonts +} -body { .l yview 0 update list [.l bbox -1] [.l bbox 0] -} {{} {7 7 17 14}} -test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { +} -result {{} {7 7 17 14}} +test listbox-3.16 {ListboxWidgetCmd procedure, "bbox" option} -constraints { + fonts +} -body { .l yview end update list [.l bbox 17] [.l bbox end] [.l bbox 18] -} {{7 83 24 14} {7 83 24 14} {}} -test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { - catch {destroy .t} +} -result {{7 83 24 14} {7 83 24 14} {}} +test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} -constraints { + fonts +} -setup { + destroy .t +} -body { toplevel .t wm geom .t +0+0 listbox .t.l -width 10 -height 5 @@ -216,255 +432,307 @@ test listbox-3.17 {ListboxWidgetCmd procedure, "bbox" option} {fonts} { update .t.l xview moveto .2 .t.l bbox 2 -} {-72 39 393 14} -test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} {fonts} { +} -cleanup { + destroy .t +} -result {-72 39 393 14} +test listbox-3.18 {ListboxWidgetCmd procedure, "bbox" option, partial last line} -constraints { + fonts +} -body { mkPartial list [.partial.l bbox 3] [.partial.l bbox 4] -} {{5 56 24 14} {5 73 23 14}} -test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} { - list [catch {.l cget} msg] $msg -} {1 {wrong # args: should be ".l cget option"}} -test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} { - list [catch {.l cget a b} msg] $msg -} {1 {wrong # args: should be ".l cget option"}} -test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} { - list [catch {.l cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} { +} -result {{5 56 24 14} {5 73 23 14}} +test listbox-3.19 {ListboxWidgetCmd procedure, "cget" option} -body { + .l cget +} -returnCodes error -result {wrong # args: should be ".l cget option"} +test listbox-3.20 {ListboxWidgetCmd procedure, "cget" option} -body { + .l cget a b +} -returnCodes error -result {wrong # args: should be ".l cget option"} +test listbox-3.21 {ListboxWidgetCmd procedure, "cget" option} -body { + .l cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test listbox-3.22 {ListboxWidgetCmd procedure, "cget" option} -body { .l cget -setgrid -} {0} -test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} { +} -result {0} +test listbox-3.23 {ListboxWidgetCmd procedure, "configure" option} -body { llength [.l configure] -} {27} -test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} { - list [catch {.l configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} { +} -result {27} +test listbox-3.24 {ListboxWidgetCmd procedure, "configure" option} -body { + .l configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test listbox-3.25 {ListboxWidgetCmd procedure, "configure" option} -body { .l configure -setgrid -} {-setgrid setGrid SetGrid 0 0} -test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} { - list [catch {.l configure -gorp is_messy} msg] $msg -} {1 {unknown option "-gorp"}} -test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} { +} -result {-setgrid setGrid SetGrid 0 0} +test listbox-3.26 {ListboxWidgetCmd procedure, "configure" option} -body { + .l configure -gorp is_messy +} -returnCodes error -result {unknown option "-gorp"} +test listbox-3.27 {ListboxWidgetCmd procedure, "configure" option} -body { set oldbd [.l cget -bd] set oldht [.l cget -highlightthickness] .l configure -bd 3 -highlightthickness 0 set x "[.l cget -bd] [.l cget -highlightthickness]" .l configure -bd $oldbd -highlightthickness $oldht set x -} {3 0} -test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} { - list [catch {.l curselection a} msg] $msg -} {1 {wrong # args: should be ".l curselection"}} -test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} { +} -result {3 0} +test listbox-3.28 {ListboxWidgetCmd procedure, "curselection" option} -body { + .l curselection a +} -returnCodes error -result {wrong # args: should be ".l curselection"} +test listbox-3.29 {ListboxWidgetCmd procedure, "curselection" option} -body { .l selection clear 0 end .l selection set 3 6 .l selection set 9 .l curselection -} {3 4 5 6 9} -test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} { - list [catch {.l delete} msg] $msg -} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}} -test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} { - list [catch {.l delete a b c} msg] $msg -} {1 {wrong # args: should be ".l delete firstIndex ?lastIndex?"}} -test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} { - list [catch {.l delete badIndex} msg] $msg -} {1 {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}} -test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} { - list [catch {.l delete 2 123ab} msg] $msg -} {1 {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number}} -test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -result {3 4 5 6 9} +test listbox-3.30 {ListboxWidgetCmd procedure, "delete" option} -body { + .l delete +} -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"} +test listbox-3.31 {ListboxWidgetCmd procedure, "delete" option} -body { + .l delete a b c +} -returnCodes error -result {wrong # args: should be ".l delete firstIndex ?lastIndex?"} +test listbox-3.32 {ListboxWidgetCmd procedure, "delete" option} -body { + .l delete badIndex +} -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number} +test listbox-3.33 {ListboxWidgetCmd procedure, "delete" option} -body { + .l delete 2 123ab +} -returnCodes error -result {bad listbox index "123ab": must be active, anchor, end, @x,y, or a number} +test listbox-3.34 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 3 list [.l2 get 2] [.l2 get 3] [.l2 index end] -} {el2 el4 7} -test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el2 el4 7} +test listbox-3.35 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 2 4 list [.l2 get 1] [.l2 get 2] [.l2 index end] -} {el1 el5 5} -test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el1 el5 5} +test listbox-3.36 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete -3 2 .l2 get 0 end -} {el3 el4 el5 el6 el7} -test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el3 el4 el5 el6 el7} +test listbox-3.37 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete -3 -1 .l2 get 0 end -} {el0 el1 el2 el3 el4 el5 el6 el7} -test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el0 el1 el2 el3 el4 el5 el6 el7} +test listbox-3.38 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 2 end .l2 get 0 end -} {el0 el1} -test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el0 el1} +test listbox-3.39 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 5 20 .l2 get 0 end -} {el0 el1 el2 el3 el4} -test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el0 el1 el2 el3 el4} +test listbox-3.40 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete end 20 .l2 get 0 end -} {el0 el1 el2 el3 el4 el5 el6} -test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el0 el1 el2 el3 el4 el5 el6} +test listbox-3.41 {ListboxWidgetCmd procedure, "delete" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 .l2 delete 8 20 .l2 get 0 end -} {el0 el1 el2 el3 el4 el5 el6 el7} -test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} { - list [catch {.l get} msg] $msg -} {1 {wrong # args: should be ".l get firstIndex ?lastIndex?"}} -test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} { - list [catch {.l get a b c} msg] $msg -} {1 {wrong # args: should be ".l get firstIndex ?lastIndex?"}} -test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} { - list [catch {.l get 2.4} msg] $msg -} {1 {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number}} -test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} { - list [catch {.l get end bogus} msg] $msg -} {1 {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}} -test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el0 el1 el2 el3 el4 el5 el6 el7} +test listbox-3.42 {ListboxWidgetCmd procedure, "get" option} -body { + .l get +} -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"} +test listbox-3.43 {ListboxWidgetCmd procedure, "get" option} -body { + .l get a b c +} -returnCodes error -result {wrong # args: should be ".l get firstIndex ?lastIndex?"} +test listbox-3.44 {ListboxWidgetCmd procedure, "get" option} -body { + .l get 2.4 +} -returnCodes error -result {bad listbox index "2.4": must be active, anchor, end, @x,y, or a number} +test listbox-3.45 {ListboxWidgetCmd procedure, "get" option} -body { + .l get end bogus +} -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number} +test listbox-3.46 {ListboxWidgetCmd procedure, "get" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 el3 el4 el5 el6 el7 list [.l2 get 0] [.l2 get 3] [.l2 get end] -} {el0 el3 el7} -test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {el0 el3 el7} +test listbox-3.47 {ListboxWidgetCmd procedure, "get" option} -setup { + destroy .l2 +} -body { listbox .l2 list [.l2 get 0] [.l2 get end] -} {{} {}} -test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {{} {}} +test listbox-3.48 {ListboxWidgetCmd procedure, "get" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 el0 el1 el2 "two words" el4 el5 el6 el7 .l2 get 3 end -} {{two words} el4 el5 el6 el7} -test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .l2 +} -result {{two words} el4 el5 el6 el7} +test listbox-3.49 {ListboxWidgetCmd procedure, "get" option} -body { .l get -1 -} {} -test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} { +} -result {} +test listbox-3.50 {ListboxWidgetCmd procedure, "get" option} -body { .l get -2 -1 -} {} -test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} { +} -result {} +test listbox-3.51 {ListboxWidgetCmd procedure, "get" option} -body { .l get -2 3 -} {el0 el1 el2 el3} -test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} { +} -result {el0 el1 el2 el3} +test listbox-3.52 {ListboxWidgetCmd procedure, "get" option} -body { .l get 12 end -} {el12 el13 el14 el15 el16 el17} -test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} { +} -result {el12 el13 el14 el15 el16 el17} +test listbox-3.53 {ListboxWidgetCmd procedure, "get" option} -body { .l get 12 20 -} {el12 el13 el14 el15 el16 el17} -test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} { +} -result {el12 el13 el14 el15 el16 el17} +test listbox-3.54 {ListboxWidgetCmd procedure, "get" option} -body { .l get end -} {el17} -test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} { +} -result {el17} +test listbox-3.55 {ListboxWidgetCmd procedure, "get" option} -body { .l get 30 -} {} -test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} { +} -result {} +test listbox-3.56 {ListboxWidgetCmd procedure, "get" option} -body { .l get 30 35 -} {} -test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} { - list [catch {.l index} msg] $msg -} {1 {wrong # args: should be ".l index index"}} -test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} { - list [catch {.l index a b} msg] $msg -} {1 {wrong # args: should be ".l index index"}} -test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} { - list [catch {.l index @} msg] $msg -} {1 {bad listbox index "@": must be active, anchor, end, @x,y, or a number}} -test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} { +} -result {} +test listbox-3.57 {ListboxWidgetCmd procedure, "index" option} -body { + .l index +} -returnCodes error -result {wrong # args: should be ".l index index"} +test listbox-3.58 {ListboxWidgetCmd procedure, "index" option} -body { + .l index a b +} -returnCodes error -result {wrong # args: should be ".l index index"} +test listbox-3.59 {ListboxWidgetCmd procedure, "index" option} -body { + .l index @ +} -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number} +test listbox-3.60 {ListboxWidgetCmd procedure, "index" option} -body { .l index 2 -} 2 -test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} { +} -result 2 +test listbox-3.61 {ListboxWidgetCmd procedure, "index" option} -body { .l index -1 -} -1 -test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} { +} -result {-1} +test listbox-3.62 {ListboxWidgetCmd procedure, "index" option} -body { .l index end -} 18 -test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} { +} -result 18 +test listbox-3.63 {ListboxWidgetCmd procedure, "index" option} -body { .l index 34 -} 34 -test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} { - list [catch {.l insert} msg] $msg -} {1 {wrong # args: should be ".l insert index ?element element ...?"}} -test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} { - list [catch {.l insert badIndex} msg] $msg -} {1 {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number}} -test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} { - catch {destroy .l2} +} -result 34 +test listbox-3.64 {ListboxWidgetCmd procedure, "insert" option} -body { + .l insert +} -returnCodes error -result {wrong # args: should be ".l insert index ?element ...?"} +test listbox-3.65 {ListboxWidgetCmd procedure, "insert" option} -body { + .l insert badIndex +} -returnCodes error -result {bad listbox index "badIndex": must be active, anchor, end, @x,y, or a number} +test listbox-3.66 {ListboxWidgetCmd procedure, "insert" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert end a b c d e .l2 insert 3 x y z .l2 get 0 end -} {a b c x y z d e} -test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {a b c x y z d e} +test listbox-3.67 {ListboxWidgetCmd procedure, "insert" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert end a b c .l2 insert -1 x .l2 get 0 end -} {x a b c} -test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {x a b c} +test listbox-3.68 {ListboxWidgetCmd procedure, "insert" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert end a b c .l2 insert end x .l2 get 0 end -} {a b c x} -test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {a b c x} +test listbox-3.69 {ListboxWidgetCmd procedure, "insert" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert end a b c .l2 insert 43 x .l2 get 0 end -} {a b c x} -test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} { - list [catch {.l nearest} msg] $msg -} {1 {wrong # args: should be ".l nearest y"}} -test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} { - list [catch {.l nearest a b} msg] $msg -} {1 {wrong # args: should be ".l nearest y"}} -test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} { - list [catch {.l nearest 20p} msg] $msg -} {1 {expected integer but got "20p"}} -test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} { +} -cleanup { + destroy .l2 +} -result {a b c x} +test listbox-3.70 {ListboxWidgetCmd procedure, "nearest" option} -body { + .l nearest +} -returnCodes error -result {wrong # args: should be ".l nearest y"} +test listbox-3.71 {ListboxWidgetCmd procedure, "nearest" option} -body { + .l nearest a b +} -returnCodes error -result {wrong # args: should be ".l nearest y"} +test listbox-3.72 {ListboxWidgetCmd procedure, "nearest" option} -body { + .l nearest 20p +} -returnCodes error -result {expected integer but got "20p"} +test listbox-3.73 {ListboxWidgetCmd procedure, "nearest" option} -body { .l yview 3 .l nearest 1000 -} {7} -test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} { - list [catch {.l scan a b} msg] $msg -} {1 {wrong # args: should be ".l scan mark|dragto x y"}} -test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} { - list [catch {.l scan a b c d} msg] $msg -} {1 {wrong # args: should be ".l scan mark|dragto x y"}} -test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} { - list [catch {.l scan foo bogus 2} msg] $msg -} {1 {expected integer but got "bogus"}} -test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} { - list [catch {.l scan foo 2 2.3} msg] $msg -} {1 {expected integer but got "2.3"}} -test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} { - catch {destroy .t} +} -result {7} +test listbox-3.74 {ListboxWidgetCmd procedure, "scan" option} -body { + .l scan a b +} -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"} +test listbox-3.75 {ListboxWidgetCmd procedure, "scan" option} -body { + .l scan a b c d +} -returnCodes error -result {wrong # args: should be ".l scan mark|dragto x y"} +test listbox-3.76 {ListboxWidgetCmd procedure, "scan" option} -body { + .l scan foo bogus 2 +} -returnCodes error -result {expected integer but got "bogus"} +test listbox-3.77 {ListboxWidgetCmd procedure, "scan" option} -body { + .l scan foo 2 2.3 +} -returnCodes error -result {expected integer but got "2.3"} +test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} -constraints { + fonts +} -setup { + destroy .t +} -body { toplevel .t wm geom .t +0+0 listbox .t.l -width 10 -height 5 @@ -475,312 +743,461 @@ test listbox-3.78 {ListboxWidgetCmd procedure, "scan" option} {fonts} { .t.l scan dragto 90 137 update list [format {%.6g %.6g} {*}[.t.l xview]] [format {%.6g %.6g} {*}[.t.l yview]] -} {{0.249364 0.427481} {0.0714286 0.428571}} -test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} { - list [catch {.l scan foo 2 4} msg] $msg -} {1 {bad option "foo": must be mark or dragto}} -test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} { - list [catch {.l see} msg] $msg -} {1 {wrong # args: should be ".l see index"}} -test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} { - list [catch {.l see a b} msg] $msg -} {1 {wrong # args: should be ".l see index"}} -test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} { - list [catch {.l see gorp} msg] $msg -} {1 {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number}} -test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} { +} -cleanup { + destroy .t +} -result {{0.249364 0.427481} {0.0714286 0.428571}} +test listbox-3.79 {ListboxWidgetCmd procedure, "scan" option} -body { + .l scan foo 2 4 +} -returnCodes error -result {bad option "foo": must be mark or dragto} +test listbox-3.80 {ListboxWidgetCmd procedure, "see" option} -body { + .l see +} -returnCodes error -result {wrong # args: should be ".l see index"} +test listbox-3.81 {ListboxWidgetCmd procedure, "see" option} -body { + .l see a b +} -returnCodes error -result {wrong # args: should be ".l see index"} +test listbox-3.82 {ListboxWidgetCmd procedure, "see" option} -body { + .l see gorp +} -returnCodes error -result {bad listbox index "gorp": must be active, anchor, end, @x,y, or a number} +test listbox-3.83 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 7 .l index @0,0 -} {7} -test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} { +} -result {7} +test listbox-3.84 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 11 .l index @0,0 -} {7} -test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} { +} -result {7} +test listbox-3.85 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 6 .l index @0,0 -} {6} -test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} { +} -result {6} +test listbox-3.86 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 5 .l index @0,0 -} {3} -test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} { +} -result {3} +test listbox-3.87 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 12 .l index @0,0 -} {8} -test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} { +} -result {8} +test listbox-3.88 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 13 .l index @0,0 -} {11} -test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} { +} -result {11} +test listbox-3.89 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see -1 .l index @0,0 -} {0} -test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} { +} -result {0} +test listbox-3.90 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see end .l index @0,0 -} {13} -test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} { +} -result {13} +test listbox-3.91 {ListboxWidgetCmd procedure, "see" option} -body { .l yview 7 .l see 322 .l index @0,0 -} {13} -test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} { +} -result {13} +test listbox-3.92 {ListboxWidgetCmd procedure, "see" option, partial last line} -body { mkPartial .partial.l see 4 .partial.l index @0,0 -} {1} -test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l select a} msg] $msg -} {1 {wrong # args: should be ".l selection option index ?index?"}} -test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l select a b c d} msg] $msg -} {1 {wrong # args: should be ".l selection option index ?index?"}} -test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l selection a bogus} msg] $msg -} {1 {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number}} -test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l selection a 0 lousy} msg] $msg -} {1 {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number}} -test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l selection anchor 0 0} msg] $msg -} {1 {wrong # args: should be ".l selection anchor index"}} -test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} { +} -result {1} +test listbox-3.93 {ListboxWidgetCmd procedure, "selection" option} -body { + .l select a +} -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"} +test listbox-3.94 {ListboxWidgetCmd procedure, "selection" option} -body { + .l select a b c d +} -returnCodes error -result {wrong # args: should be ".l selection option index ?index?"} +test listbox-3.95 {ListboxWidgetCmd procedure, "selection" option} -body { + .l selection a bogus +} -returnCodes error -result {bad listbox index "bogus": must be active, anchor, end, @x,y, or a number} +test listbox-3.96 {ListboxWidgetCmd procedure, "selection" option} -body { + .l selection a 0 lousy +} -returnCodes error -result {bad listbox index "lousy": must be active, anchor, end, @x,y, or a number} +test listbox-3.97 {ListboxWidgetCmd procedure, "selection" option} -body { + .l selection anchor 0 0 +} -returnCodes error -result {wrong # args: should be ".l selection anchor index"} +test listbox-3.98 {ListboxWidgetCmd procedure, "selection" option} -body { list [.l selection anchor 5; .l index anchor] \ [.l selection anchor 0; .l index anchor] -} {5 0} -test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} { +} -result {5 0} +test listbox-3.99 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor -1 .l index anchor -} {0} -test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} { +} -result {0} +test listbox-3.100 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor end .l index anchor -} {17} -test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} { +} -result {17} +test listbox-3.101 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection anchor 44 .l index anchor -} {17} -test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} { +} -result {17} +test listbox-3.102 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 8 .l selection clear 3 4 .l curselection -} {2 5 6 7 8} -test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l selection includes 0 0} msg] $msg -} {1 {wrong # args: should be ".l selection includes index"}} -test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} { +} -result {2 5 6 7 8} +test listbox-3.103 {ListboxWidgetCmd procedure, "selection" option} -body { + .l selection includes 0 0 +} -returnCodes error -result {wrong # args: should be ".l selection includes index"} +test listbox-3.104 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 8 .l selection clear 4 list [.l selection includes 3] [.l selection includes 4] \ [.l selection includes 5] -} {1 0 1} -test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} { +} -result {1 0 1} +test listbox-3.105 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection set 0 end .l selection includes -1 -} {0} -test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} { +} -result {0} +test listbox-3.106 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set end .l selection includes end -} {1} -test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} { +} -result {1} +test listbox-3.107 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection set 0 end .l selection includes 44 -} {0} -test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} { - catch {destroy .l2} +} -result {0} +test listbox-3.108 {ListboxWidgetCmd procedure, "selection" option} -setup { + destroy .l2 +} -body { listbox .l2 .l2 selection includes 0 -} {0} -test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} { +} -cleanup { + destroy .l2 +} -result {0} +test listbox-3.109 {ListboxWidgetCmd procedure, "selection" option} -body { .l selection clear 0 end .l selection set 2 .l selection set 5 7 .l curselection -} {2 5 6 7} -test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} { +} -result {2 5 6 7} +test listbox-3.110 {ListboxWidgetCmd procedure, "selection" option} -body { + .l selection clear 0 end + .l selection set 2 + .l selection set 5 7 .l selection set 5 7 .l curselection -} {2 5 6 7} -test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} { - list [catch {.l selection badOption 0 0} msg] $msg -} {1 {bad option "badOption": must be anchor, clear, includes, or set}} -test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} { - list [catch {.l size a} msg] $msg -} {1 {wrong # args: should be ".l size"}} -test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} { +} -result {2 5 6 7} +test listbox-3.111 {ListboxWidgetCmd procedure, "selection" option} -body { + .l selection badOption 0 0 +} -returnCodes error -result {bad option "badOption": must be anchor, clear, includes, or set} +test listbox-3.112 {ListboxWidgetCmd procedure, "size" option} -body { + .l size a +} -returnCodes error -result {wrong # args: should be ".l size"} +test listbox-3.113 {ListboxWidgetCmd procedure, "size" option} -body { .l size -} {18} -test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} { - catch {destroy .l2} +} -result {18} +test listbox-3.114 {ListboxWidgetCmd procedure, "xview" option} -setup { + destroy .l2 +} -body { listbox .l2 update format {%.6g %.6g} {*}[.l2 xview] -} {0 1} -test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} { - catch {destroy .l} - listbox .l -width 10 -height 5 -font $fixed - .l insert 0 a b c d e f g h i j k l m n o p q r s t - pack .l +} -cleanup { + destroy .l2 +} -result {0 1} +test listbox-3.115 {ListboxWidgetCmd procedure, "xview" option} -setup { + destroy .l2 +} -body { + listbox .l2 -width 10 -height 5 -font $fixed + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + pack .l2 update - format {%.6g %.6g} {*}[.l xview] -} {0 1} -catch {destroy .l} -listbox .l -width 10 -height 5 -font $fixed -.l insert 0 a b c d e f g h i j k l m n o p q r s t -.l insert 1 "0123456789a123456789b123456789c123456789d123456789" -pack .l -update -test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} {fonts} { - .l xview 4 - format {%.6g %.6g} {*}[.l xview] -} {0.08 0.28} -test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l xview foo} msg] $msg -} {1 {expected integer but got "foo"}} -test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l xview zoom a b} msg] $msg -} {1 {unknown option "zoom": must be moveto or scroll}} -test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} {fonts} { - .l xview 0 - .l xview moveto .4 + format {%.6g %.6g} {*}[.l2 xview] +} -cleanup { + destroy .l2 +} -result {0 1} + +test listbox-3.116 {ListboxWidgetCmd procedure, "xview" option} -constraints { + fonts +} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 update - format {%.6g %.6g} {*}[.l xview] -} {0.4 0.6} -test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} {fonts} { +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" + .l2 xview 4 + format {%.6g %.6g} {*}[.l2 xview] +} -cleanup { + destroy .l2 +} -result {0.08 0.28} +test listbox-3.117 {ListboxWidgetCmd procedure, "xview" option} -body { + .l xview foo +} -returnCodes error -result {expected integer but got "foo"} +test listbox-3.118 {ListboxWidgetCmd procedure, "xview" option} -body { + .l xview zoom a b +} -returnCodes error -result {unknown option "zoom": must be moveto or scroll} +test listbox-3.119 {ListboxWidgetCmd procedure, "xview" option} -constraints { + fonts +} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" .l xview 0 - .l xview scroll 2 units - update - format {%.6g %.6g} {*}[.l xview] -} {0.04 0.24} -test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} {fonts} { - .l xview 30 - .l xview scroll -1 pages - update - format {%.6g %.6g} {*}[.l xview] -} {0.44 0.64} -test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} {fonts} { - .l configure -width 1 - update - .l xview 30 - .l xview scroll -4 pages - update - format {%.6g %.6g} {*}[.l xview] -} {0.52 0.54} -test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} { - catch {destroy .l} - listbox .l - pack .l + .l2 xview moveto .4 update - format {%.6g %.6g} {*}[.l yview] -} {0 1} -test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} { - catch {destroy .l} - listbox .l - .l insert 0 el1 - pack .l + format {%.6g %.6g} {*}[.l2 xview] +} -cleanup { + destroy .l2 +} -result {0.4 0.6} +test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} -constraints { + fonts +} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 update - format {%.6g %.6g} {*}[.l yview] -} {0 1} -catch {destroy .l} -listbox .l -width 10 -height 5 -font $fixed -.l insert 0 a b c d e f g h i j k l m n o p q r s t -pack .l -update -test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} { - .l yview 4 +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" + .l2 xview 0 + .l2 xview scroll 2 units + update + format {%.6g %.6g} {*}[.l2 xview] +} -cleanup { + destroy .l2 +} -result {0.04 0.24} +test listbox-3.121 {ListboxWidgetCmd procedure, "xview" option} -constraints { + fonts +} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" + .l2 xview 30 + .l2 xview scroll -1 pages + update + format {%.6g %.6g} {*}[.l2 xview] +} -cleanup { + destroy .l2 +} -result {0.44 0.64} +test listbox-3.122 {ListboxWidgetCmd procedure, "xview" option} -constraints { + fonts +} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 update - format {%.6g %.6g} {*}[.l yview] -} {0.2 0.45} -test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} { +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 insert 1 "0123456789a123456789b123456789c123456789d123456789" + .l2 configure -width 1 + update + .l2 xview 30 + .l2 xview scroll -4 pages + update + format {%.6g %.6g} {*}[.l2 xview] +} -cleanup { + destroy .l2 +} -result {0.52 0.54} +test listbox-3.123 {ListboxWidgetCmd procedure, "yview" option} -setup { + destroy .l2 +} -body { + listbox .l2 + pack .l2 + update + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0 1} +test listbox-3.124 {ListboxWidgetCmd procedure, "yview" option} -setup { + destroy .l2 +} -body { + listbox .l2 + .l2 insert 0 el1 + pack .l2 + update + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0 1} + +test listbox-3.125 {ListboxWidgetCmd procedure, "yview" option} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 yview 4 + update + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0.2 0.45} +test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} -setup { + destroy .l + listbox .l -width 10 -height 5 -font $fixed + pack .l + update +} -body { + .l insert 0 a b c d e f g h i j k l m n o p q r s t mkPartial format {%.6g %.6g} {*}[.partial.l yview] -} {0 0.266667} -test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l yview foo} msg] $msg -} {1 {bad listbox index "foo": must be active, anchor, end, @x,y, or a number}} -test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l yview foo a b} msg] $msg -} {1 {unknown option "foo": must be moveto or scroll}} -test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} { - .l yview 0 - .l yview moveto .31 - format {%.6g %.6g} {*}[.l yview] -} {0.3 0.55} -test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} { - .l yview 2 - .l yview scroll 2 pages - format {%.6g %.6g} {*}[.l yview] -} {0.4 0.65} -test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} { - .l yview 10 - .l yview scroll -3 units - format {%.6g %.6g} {*}[.l yview] -} {0.35 0.6} -test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} { - .l configure -height 2 - update - .l yview 15 - .l yview scroll -4 pages - format {%.6g %.6g} {*}[.l yview] -} {0.55 0.65} -test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l whoknows} msg] $msg -} {1 {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} -test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l c} msg] $msg -} {1 {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} -test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l in} msg] $msg -} {1 {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} -test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l s} msg] $msg -} {1 {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} -test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} { - list [catch {.l se} msg] $msg -} {1 {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview}} +} -cleanup { + destroy .l +} -result {0 0.266667} + +# Listbox used in 3.127 -3.137 tests +destroy .l +listbox .l -width 20 -height 5 -bd 4 -highlightthickness 1 -selectborderwidth 2 +pack .l +.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 el12 el13 el14 \ + el15 el16 el17 +update +test listbox-3.127 {ListboxWidgetCmd procedure, "xview" option} -body { + .l yview foo +} -returnCodes error -result {bad listbox index "foo": must be active, anchor, end, @x,y, or a number} +test listbox-3.128 {ListboxWidgetCmd procedure, "xview" option} -body { + .l yview foo a b +} -returnCodes error -result {unknown option "foo": must be moveto or scroll} +test listbox-3.129 {ListboxWidgetCmd procedure, "xview" option} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 yview 0 + .l2 yview moveto .31 + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0.3 0.55} +test listbox-3.130 {ListboxWidgetCmd procedure, "xview" option} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 yview 2 + .l2 yview scroll 2 pages + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0.4 0.65} +test listbox-3.131 {ListboxWidgetCmd procedure, "xview" option} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 yview 10 + .l2 yview scroll -3 units + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0.35 0.6} +test listbox-3.132 {ListboxWidgetCmd procedure, "xview" option} -setup { + destroy .l2 + listbox .l2 -width 10 -height 5 -font $fixed + pack .l2 + update +} -body { + .l2 insert 0 a b c d e f g h i j k l m n o p q r s t + .l2 configure -height 2 + update + .l2 yview 15 + .l2 yview scroll -4 pages + format {%.6g %.6g} {*}[.l2 yview] +} -cleanup { + destroy .l2 +} -result {0.55 0.65} +test listbox-3.133 {ListboxWidgetCmd procedure, "xview" option} -body { + .l whoknows +} -returnCodes error -result {bad option "whoknows": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} +test listbox-3.134 {ListboxWidgetCmd procedure, "xview" option} -body { + .l c +} -returnCodes error -result {ambiguous option "c": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} +test listbox-3.135 {ListboxWidgetCmd procedure, "xview" option} -body { + .l in +} -returnCodes error -result {ambiguous option "in": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} +test listbox-3.136 {ListboxWidgetCmd procedure, "xview" option} -body { + .l s +} -returnCodes error -result {ambiguous option "s": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} +test listbox-3.137 {ListboxWidgetCmd procedure, "xview" option} -body { + .l se +} -returnCodes error -result {ambiguous option "se": must be activate, bbox, cget, configure, curselection, delete, get, index, insert, itemcget, itemconfigure, nearest, scan, see, selection, size, xview, or yview} # No tests for DestroyListbox: I can't come up with anything to test # in this procedure. -test listbox-4.1 {ConfigureListbox procedure} {fonts} { - catch {destroy .l} + +test listbox-4.1 {ConfigureListbox procedure} -constraints { + fonts +} -setup { + deleteWindows + destroy .l listbox .l -setgrid 1 -width 25 -height 15 pack .l update +} -body { set x [getsize .] .l configure -setgrid 0 update list $x [getsize .] -} {25x15 185x263} +} -cleanup { + deleteWindows +} -result {25x15 185x263} resetGridInfo -test listbox-4.2 {ConfigureListbox procedure} { +test listbox-4.2 {ConfigureListbox procedure} -setup { + deleteWindows + destroy .l + listbox .l -setgrid 1 -width 25 -height 15 + pack .l + update +} -body { .l configure -highlightthickness -3 .l cget -highlightthickness -} {0} -test listbox-4.3 {ConfigureListbox procedure} { +} -cleanup { + deleteWindows +} -result {0} +test listbox-4.3 {ConfigureListbox procedure} -setup { + deleteWindows + destroy .l + listbox .l -setgrid 1 -width 25 -height 15 + pack .l + update +} -body { .l configure -exportselection 0 .l delete 0 end .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 .l selection set 3 5 .l configure -exportselection 1 selection get -} {el3 +} -cleanup { + deleteWindows +} -result {el3 el4 el5} -test listbox-4.4 {ConfigureListbox procedure} { - catch {destroy .e} +test listbox-4.4 {ConfigureListbox procedure} -setup { + deleteWindows + listbox .l -setgrid 1 -width 25 -height 15 + pack .l + update +} -body { entry .e .e insert 0 abc .e select from 0 @@ -792,8 +1209,15 @@ test listbox-4.4 {ConfigureListbox procedure} { .l selection clear 3 5 .l configure -exportselection 1 list [selection own] [selection get] -} {.e ab} -test listbox-4.5 {-exportselection option} { +} -cleanup { + deleteWindows +} -result {.e ab} +test listbox-4.5 {-exportselection option} -setup { + deleteWindows + listbox .l -setgrid 1 -width 25 -height 15 + pack .l + update +} -body { selection clear . .l configure -exportselection 1 .l delete 0 end @@ -809,11 +1233,16 @@ test listbox-4.5 {-exportselection option} { lappend x [catch {selection get} msg] $msg [.l curselection] .l config -exportselection 1 lappend x [catch {selection get} msg] $msg [.l curselection] -} {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1 +} -cleanup { + deleteWindows +} -result {0 el1 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined} {1 2 3} 0 {el1 el2 el3} {1 2 3}} -test listbox-4.6 {ConfigureListbox procedure} {fonts} { - catch {destroy .l} +test listbox-4.6 {ConfigureListbox procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { # The following code (reset geometry, withdraw, etc.) is necessary # to reset the state of some window managers like olvwm under @@ -823,246 +1252,307 @@ test listbox-4.6 {ConfigureListbox procedure} {fonts} { update wm geom . {} wm withdraw . - listbox .l -font $fixed -width 15 -height 20 - pack .l + listbox .l2 -font $fixed -width 15 -height 20 + pack .l2 update wm deiconify . set x [getsize .] - .l configure -setgrid 1 + .l2 configure -setgrid 1 update list $x [getsize .] -} {115x328 15x20} -test listbox-4.7 {ConfigureListbox procedure} { - catch {destroy .l} +} -cleanup { + deleteWindows +} -result {115x328 15x20} +test listbox-4.7 {ConfigureListbox procedure} -setup { + deleteWindows +} -body { wm withdraw . - listbox .l -font $fixed -width 30 -height 20 -setgrid 1 + listbox .l2 -font $fixed -width 30 -height 20 -setgrid 1 wm geom . +25+25 - pack .l + pack .l2 update wm deiconify . set result [getsize .] wm geom . 26x15 update lappend result [getsize .] - .l configure -setgrid 1 + .l2 configure -setgrid 1 update lappend result [getsize .] -} {30x20 26x15 26x15} -wm geom . {} -catch {destroy .l} +} -cleanup { + deleteWindows + wm geom . {} +} -result {30x20 26x15 26x15} + resetGridInfo -test listbox-4.8 {ConfigureListbox procedure} { - catch {destroy .l} - listbox .l -width 15 -height 20 -xscrollcommand "record x" \ +test listbox-4.8 {ConfigureListbox procedure} -setup { + destroy .l2 +} -body { + listbox .l2 -width 15 -height 20 -xscrollcommand "record x" \ -yscrollcommand "record y" - pack .l + pack .l2 update - .l configure -fg black + .l2 configure -fg black set log {} update set log -} {{y 0 1} {x 0 1}} -test listbox-4.9 {ConfigureListbox procedure, -listvar} { - catch {destroy .l} +} -cleanup { + destroy .l2 +} -result {{y 0 1} {x 0 1}} +test listbox-4.9 {ConfigureListbox procedure, -listvar} -setup { + destroy .l2 +} -body { set x [list a b c d] - listbox .l -listvar x - .l get 0 end -} [list a b c d] -test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} { - catch {destroy .l} + listbox .l2 -listvar x + .l2 get 0 end +} -cleanup { + destroy .l2 +} -result [list a b c d] +test listbox-4.10 {ConfigureListbox, no listvar -> existing listvar} -setup { + destroy .l2 +} -body { set x [list a b c d] - listbox .l - .l insert end 1 2 3 4 - .l configure -listvar x - .l get 0 end -} [list a b c d] -test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} { - catch {destroy .l} + listbox .l2 + .l2 insert end 1 2 3 4 + .l2 configure -listvar x + .l2 get 0 end +} -cleanup { + destroy .l2 +} -result [list a b c d] +test listbox-4.11 {ConfigureListbox procedure, listvar -> no listvar} -setup { + destroy .l2 +} -body { set x [list a b c d] - listbox .l -listvar x - .l configure -listvar {} - .l insert end 1 2 3 4 - list $x [.l get 0 end] -} [list [list a b c d] [list a b c d 1 2 3 4]] -test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} { - catch {destroy .l} + listbox .l2 -listvar x + .l2 configure -listvar {} + .l2 insert end 1 2 3 4 + list $x [.l2 get 0 end] +} -cleanup { + destroy .l2 +} -result [list [list a b c d] [list a b c d 1 2 3 4]] +test listbox-4.12 {ConfigureListbox procedure, listvar -> different listvar} -setup { + destroy .l2 +} -body { set x [list a b c d] set y [list 1 2 3 4] - listbox .l - .l configure -listvar x - .l configure -listvar y - .l insert end 5 6 7 8 + listbox .l2 + .l2 configure -listvar x + .l2 configure -listvar y + .l2 insert end 5 6 7 8 list $x $y -} [list [list a b c d] [list 1 2 3 4 5 6 7 8]] -test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} { - catch {destroy .l} +} -cleanup { + destroy .l2 +} -result [list [list a b c d] [list 1 2 3 4 5 6 7 8]] +test listbox-4.13 {ConfigureListbox, no listvar -> non-existant listvar} -setup { + destroy .l2 +} -body { catch {unset x} - listbox .l - .l insert end a b c d - .l configure -listvar x + listbox .l2 + .l2 insert end a b c d + .l2 configure -listvar x set x -} [list a b c d] -test listbox-4.14 {ConfigureListbox, non-existant listvar} { - catch {destroy .l} +} -cleanup { + destroy .l2 +} -result [list a b c d] +test listbox-4.14 {ConfigureListbox, non-existant listvar} -setup { + destroy .l2 +} -body { catch {unset x} - listbox .l -listvar x + listbox .l2 -listvar x list [info exists x] $x -} [list 1 {}] -test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} { - catch {destroy .l} +} -cleanup { + destroy .l2 +} -result [list 1 {}] +test listbox-4.15 {ConfigureListbox, listvar -> non-existant listvar} -setup { + destroy .l2 +} -body { catch {unset y} set x [list a b c d] - listbox .l -listvar x - .l configure -listvar y + listbox .l2 -listvar x + .l2 configure -listvar y list [info exists y] $y -} [list 1 [list a b c d]] -test listbox-4.16 {ConfigureListbox, listvar -> same listvar} { - catch {destroy .l} +} -cleanup { + destroy .l2 +} -result [list 1 [list a b c d]] +test listbox-4.16 {ConfigureListbox, listvar -> same listvar} -setup { + destroy .l2 +} -body { set x [list a b c d] - listbox .l -listvar x - .l configure -listvar x + listbox .l2 -listvar x + .l2 configure -listvar x set x -} [list a b c d] -test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} { - catch {destroy .l} - listbox .l - .l insert end a b c d - .l configure -listvar {} - .l get 0 end -} [list a b c d] -test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} { - catch {destroy .l} - listbox .l - .l insert end a b c d +} -cleanup { + destroy .l2 +} -result [list a b c d] +test listbox-4.17 {ConfigureListbox, no listvar -> no listvar} -setup { + destroy .l2 +} -body { + listbox .l2 + .l2 insert end a b c d + .l2 configure -listvar {} + .l2 get 0 end +} -cleanup { + destroy .l2 +} -result [list a b c d] +test listbox-4.18 {ConfigureListbox, no listvar -> bad listvar} -setup { + destroy .l2 +} -body { + listbox .l2 + .l2 insert end a b c d set x "this is a \" bad list" - catch {.l configure -listvar x} result - list [.l get 0 end] [.l cget -listvar] $result -} [list [list a b c d] {} \ + catch {.l2 configure -listvar x} result + list [.l2 get 0 end] [.l2 cget -listvar] $result +} -cleanup { + destroy .l2 +} -result [list [list a b c d] {} \ "unmatched open quote in list: invalid -listvariable value"] -test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} { - catch {destroy .l} +test listbox-4.19 {ConfigureListbox, no listvar -> bad non-existent listvar} -setup { + destroy .l2 +} -body { unset -nocomplain ::foo - listbox .l -listvar foo - .l insert end a b c d - catch {.l configure -listvar ::zoo::bar::foo} result - list [.l get 0 end] [.l cget -listvar] $foo $result -} [list [list a b c d] foo [list a b c d] \ + listbox .l2 -listvar foo + .l2 insert end a b c d + catch {.l2 configure -listvar ::zoo::bar::foo} result + list [.l2 get 0 end] [.l2 cget -listvar] $foo $result +} -cleanup { + destroy .l2 +} -result [list [list a b c d] foo [list a b c d] \ {can't set "::zoo::bar::foo": parent namespace doesn't exist}] + # No tests for DisplayListbox: I don't know how to test this procedure. -test listbox-5.1 {ListboxComputeGeometry procedure} {fonts} { - catch {destroy .l} +test listbox-5.1 {ListboxComputeGeometry procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -font $fixed -width 15 -height 20 pack .l list [winfo reqwidth .l] [winfo reqheight .l] -} {115 328} -test listbox-5.2 {ListboxComputeGeometry procedure} {fonts} { - catch {destroy .l} +} -result {115 328} +test listbox-5.2 {ListboxComputeGeometry procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -font $fixed -width 0 -height 10 pack .l update list [winfo reqwidth .l] [winfo reqheight .l] -} {17 168} -test listbox-5.3 {ListboxComputeGeometry procedure} {fonts} { - catch {destroy .l} +} -result {17 168} +test listbox-5.3 {ListboxComputeGeometry procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -font $fixed -width 0 -height 10 -bd 3 .l insert 0 Short "Really much longer" Longer pack .l update list [winfo reqwidth .l] [winfo reqheight .l] -} {138 170} -test listbox-5.4 {ListboxComputeGeometry procedure} {fonts} { - catch {destroy .l} +} -result {138 170} +test listbox-5.4 {ListboxComputeGeometry procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -font $fixed -width 10 -height 0 pack .l update list [winfo reqwidth .l] [winfo reqheight .l] -} {80 24} -test listbox-5.5 {ListboxComputeGeometry procedure} {fonts} { - catch {destroy .l} +} -result {80 24} +test listbox-5.5 {ListboxComputeGeometry procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -font $fixed -width 10 -height 0 -highlightthickness 0 .l insert 0 Short "Really much longer" Longer pack .l update list [winfo reqwidth .l] [winfo reqheight .l] -} {76 52} -test listbox-5.6 {ListboxComputeGeometry procedure} { +} -result {76 52} +test listbox-5.6 {ListboxComputeGeometry procedure} -setup { + destroy .l +} -body { # If "0" in selected font had 0 width, caused divide-by-zero error. - catch {destroy .l} pack [listbox .l -font {{open look glyph}}] update -} {} +} -cleanup { + destroy .l +} -result {} -catch {destroy .l} +# Listbox used in 6.*, 7.* tests +destroy .l listbox .l -height 2 -xscrollcommand "record x" -yscrollcommand "record y" pack .l update -test listbox-6.1 {InsertEls procedure} { +test listbox-6.1 {InsertEls procedure} -body { .l delete 0 end .l insert end a b c d .l insert 5 x y z .l insert 2 A .l insert 0 q r s .l get 0 end -} {q r s a b A c d x y z} -test listbox-6.2 {InsertEls procedure} { +} -result {q r s a b A c d x y z} +test listbox-6.2 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l insert 2 A B .l index anchor -} {4} -test listbox-6.3 {InsertEls procedure} { +} -result {4} +test listbox-6.3 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l insert 3 A B .l index anchor -} {2} -test listbox-6.4 {InsertEls procedure} { +} -result {2} +test listbox-6.4 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l insert 2 A B .l index @0,0 -} {5} -test listbox-6.5 {InsertEls procedure} { +} -result {5} +test listbox-6.5 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l insert 3 A B .l index @0,0 -} {3} -test listbox-6.6 {InsertEls procedure} { +} -result {3} +test listbox-6.6 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 5 .l insert 5 A B .l index active -} {7} -test listbox-6.7 {InsertEls procedure} { +} -result {7} +test listbox-6.7 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 5 .l insert 6 A B .l index active -} {5} -test listbox-6.8 {InsertEls procedure} { +} -result {5} +test listbox-6.8 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b c .l index active -} {2} -test listbox-6.9 {InsertEls procedure} { +} -result {2} +test listbox-6.9 {InsertEls procedure} -body { .l delete 0 end .l insert 0 .l index active -} {0} -test listbox-6.10 {InsertEls procedure} { +} -result {0} +test listbox-6.10 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b "two words" c d e f g h i j update @@ -1070,8 +1560,8 @@ test listbox-6.10 {InsertEls procedure} { .l insert 0 word update set log -} {{y 0 0.166667}} -test listbox-6.11 {InsertEls procedure} { +} -result {{y 0 0.166667}} +test listbox-6.11 {InsertEls procedure} -body { .l delete 0 end .l insert 0 a b "two words" c d e f g h i j update @@ -1079,9 +1569,12 @@ test listbox-6.11 {InsertEls procedure} { .l insert 0 "much longer entry" update set log -} {{y 0 0.166667} {x 0 1}} -test listbox-6.12 {InsertEls procedure} {fonts} { - catch {destroy .l2} +} -result {{y 0 0.166667} {x 0 1}} +test listbox-6.12 {InsertEls procedure} -constraints { + fonts +} -setup { + destroy .l2 +} -body { listbox .l2 -width 0 -height 0 pack .l2 -side top .l2 insert 0 a b "two words" c d @@ -1089,23 +1582,31 @@ test listbox-6.12 {InsertEls procedure} {fonts} { lappend x [winfo reqwidth .l2] [winfo reqheight .l2] .l2 insert 0 "much longer entry" lappend x [winfo reqwidth .l2] [winfo reqheight .l2] -} {80 93 122 110} -test listbox-6.13 {InsertEls procedure, check -listvar update} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result {80 93 122 110} +test listbox-6.13 {InsertEls procedure, check -listvar update} -setup { + destroy .l2 +} -body { set x [list a b c d] listbox .l2 -listvar x .l2 insert 0 1 2 3 4 set x -} [list 1 2 3 4 a b c d] -test listbox-6.14 {InsertEls procedure, check selection update} { - catch {destroy .l2} +} -cleanup { + destroy .l2 +} -result [list 1 2 3 4 a b c d] +test listbox-6.14 {InsertEls procedure, check selection update} -setup { + destroy .l2 +} -body { listbox .l2 .l2 insert 0 0 1 2 3 4 .l2 selection set 2 4 .l2 insert 0 a .l2 curselection -} [list 3 4 5] -test listbox-6.15 {InsertEls procedure, lost namespaced listvar} { +} -cleanup { + destroy .l2 +} -result [list 3 4 5] +test listbox-6.15 {InsertEls procedure, lost namespaced listvar} -body { destroy .l2 namespace eval test { variable foo {a b} } listbox .l2 -listvar ::test::foo @@ -1115,137 +1616,139 @@ test listbox-6.15 {InsertEls procedure, lost namespaced listvar} { .l2 insert end e f catch {set ::test::foo} result list [.l2 get 0 end] [.l2 cget -listvar] $result -} [list [list a b c e f] ::test::foo \ +} -cleanup { + destroy .l2 +} -result [list [list a b c e f] ::test::foo \ {can't read "::test::foo": no such variable}] -test listbox-7.1 {DeleteEls procedure} { +test listbox-7.1 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection set 1 6 .l delete 4 3 list [.l size] [selection get] -} {10 {b +} -result {10 {b c d e f g}} -test listbox-7.2 {DeleteEls procedure} { +test listbox-7.2 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection set 3 6 .l delete 4 4 list [.l size] [.l get 4] [.l curselection] -} {9 f {3 4 5}} -test listbox-7.3 {DeleteEls procedure} { +} -result {9 f {3 4 5}} +test listbox-7.3 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l delete 0 3 list [.l size] [.l get 0] [.l get 1] -} {6 e f} -test listbox-7.4 {DeleteEls procedure} { +} -result {6 e f} +test listbox-7.4 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l delete 8 1000 list [.l size] [.l get 7] -} {8 h} -test listbox-7.5 {DeleteEls procedure} { +} -result {8 h} +test listbox-7.5 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l delete 0 1 .l index anchor -} {0} -test listbox-7.6 {DeleteEls procedure} { +} -result {0} +test listbox-7.6 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 2 .l delete 2 .l index anchor -} {2} -test listbox-7.7 {DeleteEls procedure} { +} -result {2} +test listbox-7.7 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 4 .l delete 2 5 .l index anchor -} {2} -test listbox-7.8 {DeleteEls procedure} { +} -result {2} +test listbox-7.8 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l selection anchor 3 .l delete 4 5 .l index anchor -} {3} -test listbox-7.9 {DeleteEls procedure} { +} -result {3} +test listbox-7.9 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 1 2 .l index @0,0 -} {1} -test listbox-7.10 {DeleteEls procedure} { +} -result {1} +test listbox-7.10 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 3 4 .l index @0,0 -} {3} -test listbox-7.11 {DeleteEls procedure} { +} -result {3} +test listbox-7.11 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 4 6 .l index @0,0 -} {3} -test listbox-7.12 {DeleteEls procedure} { +} -result {3} +test listbox-7.12 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l yview 3 update .l delete 3 end .l index @0,0 -} {1} -test listbox-7.13 {DeleteEls procedure, updating view with partial last line} { +} -result {1} +test listbox-7.13 {DeleteEls procedure, updating view with partial last line} -body { mkPartial .partial.l yview 8 update .partial.l delete 10 13 .partial.l index @0,0 -} {7} -test listbox-7.14 {DeleteEls procedure} { +} -result {7} +test listbox-7.14 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 3 4 .l index active -} {4} -test listbox-7.15 {DeleteEls procedure} { +} -result {4} +test listbox-7.15 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 5 7 .l index active -} {5} -test listbox-7.16 {DeleteEls procedure} { +} -result {5} +test listbox-7.16 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 5 end .l index active -} {4} -test listbox-7.17 {DeleteEls procedure} { +} -result {4} +test listbox-7.17 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j .l activate 6 .l delete 0 end .l index active -} {0} -test listbox-7.18 {DeleteEls procedure} { +} -result {0} +test listbox-7.18 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c "two words" d e f g h i j update @@ -1253,8 +1756,8 @@ test listbox-7.18 {DeleteEls procedure} { .l delete 4 6 update set log -} {{y 0 0.25}} -test listbox-7.19 {DeleteEls procedure} { +} -result {{y 0 0.25}} +test listbox-7.19 {DeleteEls procedure} -body { .l delete 0 end .l insert 0 a b c "two words" d e f g h i j update @@ -1262,9 +1765,12 @@ test listbox-7.19 {DeleteEls procedure} { .l delete 3 update set log -} {{y 0 0.2} {x 0 1}} -test listbox-7.20 {DeleteEls procedure} {fonts} { - catch {destroy .l2} +} -result {{y 0 0.2} {x 0 1}} +test listbox-7.20 {DeleteEls procedure} -constraints { + fonts +} -setup { + destroy .l2 +} -body { listbox .l2 -width 0 -height 0 pack .l2 -side top .l2 insert 0 a b "two words" c d e f g @@ -1272,28 +1778,37 @@ test listbox-7.20 {DeleteEls procedure} {fonts} { lappend x [winfo reqwidth .l2] [winfo reqheight .l2] .l2 delete 2 4 lappend x [winfo reqwidth .l2] [winfo reqheight .l2] -} {80 144 17 93} -catch {destroy .l2} -test listbox-7.21 {DeleteEls procedure, check -listvar update} { - catch {destroy .l2} +} -result {80 144 17 93} +test listbox-7.21 {DeleteEls procedure, check -listvar update} -setup { + destroy .l2 +} -body { set x [list a b c d] listbox .l2 -listvar x .l2 delete 0 1 set x -} [list c d] +} -result [list c d] -test listbox-8.1 {ListboxEventProc procedure} {fonts} { - catch {destroy .l} + +test listbox-8.1 {ListboxEventProc procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -setgrid 1 pack .l update set x [getsize .] destroy .l list $x [getsize .] [winfo exists .l] [info command .l] -} {20x10 150x178 0 {}} +} -cleanup { + destroy .l +} -result {20x10 150x178 0 {}} resetGridInfo -test listbox-8.2 {ListboxEventProc procedure} {fonts} { - catch {destroy .l} +test listbox-8.2 {ListboxEventProc procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { listbox .l -height 5 -width 10 .l insert 0 a b c "A string that is very very long" d e f g h i j k pack .l @@ -1301,9 +1816,12 @@ test listbox-8.2 {ListboxEventProc procedure} {fonts} { place .l -width 50 -height 80 update list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] -} {{0 0.222222} {0 0.333333}} -test listbox-8.3 {ListboxEventProc procedure} { +} -cleanup { + destroy .l +} -result {{0 0.222222} {0 0.333333}} +test listbox-8.3 {ListboxEventProc procedure} -setup { deleteWindows +} -body { listbox .l1 -bg #543210 rename .l1 .l2 set x {} @@ -1311,107 +1829,257 @@ test listbox-8.3 {ListboxEventProc procedure} { lappend x [.l2 cget -bg] destroy .l1 lappend x [info command .l*] [winfo children .] -} {.l1 #543210 {} {}} +} -cleanup { + deleteWindows +} -result {.l1 #543210 {} {}} + -test listbox-9.1 {ListboxCmdDeletedProc procedure} { +test listbox-9.1 {ListboxCmdDeletedProc procedure} -setup { deleteWindows +} -body { listbox .l1 rename .l1 {} list [info command .l*] [winfo children .] -} {{} {}} -test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} fonts { - catch {destroy .top} +} -cleanup { + deleteWindows +} -result {{} {}} +test listbox-9.2 {ListboxCmdDeletedProc procedure, disabling -setgrid} -constraints { + fonts +} -setup { + destroy .top +} -body { toplevel .top wm geom .top +0+0 listbox .top.l -setgrid 1 -width 20 -height 10 pack .top.l update - set x [wm geometry .top] + set x [getsize .top] rename .top.l {} update - lappend x [wm geometry .top] + lappend x [getsize .top] +} -cleanup { destroy .top - set x -} {20x10+0+0 150x178+0+0} +} -result {20x10 150x178} -catch {destroy .l} -listbox .l -pack .l -.l delete 0 end -.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 -test listbox-10.1 {GetListboxIndex procedure} { + +# Listbox used in 10.* tests +destroy .l +test listbox-10.1 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l activate 3 + update list [.l activate 3; .l index active] [.l activate 6; .l index active] -} {3 6} -test listbox-10.2 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {3 6} +test listbox-10.2 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l selection anchor 2 + update .l index anchor -} 2 -test listbox-10.3 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result 2 +test listbox-10.3 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l insert end A B C D E .l selection anchor end + update .l delete 12 end list [.l index anchor] [.l index end] -} {12 12} -test listbox-10.4 {GetListboxIndex procedure} { - list [catch {.l index a} msg] $msg -} {1 {bad listbox index "a": must be active, anchor, end, @x,y, or a number}} -test listbox-10.5 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {12 12} +test listbox-10.4 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index a +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "a": must be active, anchor, end, @x,y, or a number} +test listbox-10.5 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update .l index end -} {12} -test listbox-10.6 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {12} +test listbox-10.6 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update .l get end -} {el11} -test listbox-10.7 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {el11} +test listbox-10.7 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l delete 0 end + update .l index end -} 0 -.l delete 0 end -.l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 -update -test listbox-10.8 {GetListboxIndex procedure} { - list [catch {.l index @} msg] $msg -} {1 {bad listbox index "@": must be active, anchor, end, @x,y, or a number}} -test listbox-10.9 {GetListboxIndex procedure} { - list [catch {.l index @foo} msg] $msg -} {1 {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number}} -test listbox-10.10 {GetListboxIndex procedure} { - list [catch {.l index @1x3} msg] $msg -} {1 {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number}} -test listbox-10.11 {GetListboxIndex procedure} { - list [catch {.l index @1,} msg] $msg -} {1 {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number}} -test listbox-10.12 {GetListboxIndex procedure} { - list [catch {.l index @1,foo} msg] $msg -} {1 {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number}} -test listbox-10.13 {GetListboxIndex procedure} { - list [catch {.l index @1,2x} msg] $msg -} {1 {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number}} -test listbox-10.14 {GetListboxIndex procedure} {fonts} { +} -cleanup { + destroy .l +} -result 0 +test listbox-10.8 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index @ +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "@": must be active, anchor, end, @x,y, or a number} +test listbox-10.9 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index @foo +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "@foo": must be active, anchor, end, @x,y, or a number} +test listbox-10.10 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index @1x3 +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "@1x3": must be active, anchor, end, @x,y, or a number} +test listbox-10.11 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index @1, +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "@1,": must be active, anchor, end, @x,y, or a number} +test listbox-10.12 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index @1,foo +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "@1,foo": must be active, anchor, end, @x,y, or a number} +test listbox-10.13 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index @1,2x +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "@1,2x": must be active, anchor, end, @x,y, or a number} +test listbox-10.14 {GetListboxIndex procedure} -constraints { + fonts +} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update list [.l index @5,57] [.l index @5,58] -} {3 3} -test listbox-10.15 {GetListboxIndex procedure} { - list [catch {.l index 1xy} msg] $msg -} {1 {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number}} -test listbox-10.16 {GetListboxIndex procedure} { +} -cleanup { + .l delete 0 end +} -cleanup { + destroy .l +} -result {3 3} +test listbox-10.15 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update + .l index 1xy +} -cleanup { + destroy .l +} -returnCodes error -result {bad listbox index "1xy": must be active, anchor, end, @x,y, or a number} +test listbox-10.16 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update .l index 3 -} {3} -test listbox-10.17 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {3} +test listbox-10.17 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update .l index 20 -} {20} -test listbox-10.18 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {20} +test listbox-10.18 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update .l get 20 -} {} -test listbox-10.19 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result {} +test listbox-10.19 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 + update .l index -2 -} -2 -test listbox-10.20 {GetListboxIndex procedure} { +} -cleanup { + destroy .l +} -result -2 +test listbox-10.20 {GetListboxIndex procedure} -setup { + destroy .l +} -body { + pack [listbox .l] + .l insert 0 el0 el1 el2 el3 el4 el5 el6 el7 el8 el9 el10 el11 .l delete 0 end + update .l index 1 -} 1 +} -cleanup { + destroy .l +} -result 1 + -test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} { - catch {destroy .l} +test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} -setup { + destroy .l +} -body { listbox .l -height 5 pack .l .l insert 0 a b c d e f g h i j @@ -1421,9 +2089,12 @@ test listbox-11.1 {ChangeListboxView procedure, boundary conditions for index} { .l yview -1 update lappend x [.l index @0,0] -} {3 0} -test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {3 0} +test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} -setup { + destroy .l +} -body { listbox .l -height 5 pack .l .l insert 0 a b c d e f g h i j @@ -1433,9 +2104,12 @@ test listbox-11.2 {ChangeListboxView procedure, boundary conditions for index} { .l yview 20 update lappend x [.l index @0,0] -} {3 5} -test listbox-11.3 {ChangeListboxView procedure} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {3 5} +test listbox-11.3 {ChangeListboxView procedure} -setup { + destroy .l +} -body { listbox .l -height 5 -yscrollcommand "record y" pack .l .l insert 0 a b c d e f g h i j @@ -1444,9 +2118,12 @@ test listbox-11.3 {ChangeListboxView procedure} { .l yview 2 update list [format {%.6g %.6g} {*}[.l yview]] $log -} {{0.2 0.7} {{y 0.2 0.7}}} -test listbox-11.4 {ChangeListboxView procedure} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {{0.2 0.7} {{y 0.2 0.7}}} +test listbox-11.4 {ChangeListboxView procedure} -setup { + destroy .l +} -body { listbox .l -height 5 -yscrollcommand "record y" pack .l .l insert 0 a b c d e f g h i j @@ -1455,9 +2132,12 @@ test listbox-11.4 {ChangeListboxView procedure} { .l yview 8 update list [format {%.6g %.6g} {*}[.l yview]] $log -} {{0.5 1} {{y 0.5 1}}} -test listbox-11.5 {ChangeListboxView procedure} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {{0.5 1} {{y 0.5 1}}} +test listbox-11.5 {ChangeListboxView procedure} -setup { + destroy .l +} -body { listbox .l -height 5 -yscrollcommand "record y" pack .l .l insert 0 a b c d e f g h i j @@ -1467,40 +2147,55 @@ test listbox-11.5 {ChangeListboxView procedure} { .l yview 3 update list [format {%.6g %.6g} {*}[.l yview]] $log -} {{0.3 0.8} {}} -test listbox-11.6 {ChangeListboxView procedure, partial last line} { +} -cleanup { + destroy .l +} -result {{0.3 0.8} {}} +test listbox-11.6 {ChangeListboxView procedure, partial last line} -body { mkPartial .partial.l yview 13 .partial.l index @0,0 -} {11} +} -cleanup { + destroy .l +} -result {11} -catch {destroy .l} + +# Listbox used in 12.* tests +destroy .l listbox .l -font $fixed -xscrollcommand "record x" -width 10 .l insert 0 0123456789a123456789b123456789c123456789d123456789e123456789f123456789g123456789h123456789i123456789 pack .l update -test listbox-12.1 {ChangeListboxOffset procedure} {fonts} { +test listbox-12.1 {ChangeListboxOffset procedure} -constraints { + fonts +} -body { set log {} .l xview 99 update list [format {%.6g %.6g} {*}[.l xview]] $log -} {{0.9 1} {{x 0.9 1}}} -test listbox-12.2 {ChangeListboxOffset procedure} {fonts} { +} -result {{0.9 1} {{x 0.9 1}}} +test listbox-12.2 {ChangeListboxOffset procedure} -constraints { + fonts +} -body { set log {} + .l xview 99 .l xview moveto -.25 update list [format {%.6g %.6g} {*}[.l xview]] $log -} {{0 0.1} {{x 0 0.1}}} -test listbox-12.3 {ChangeListboxOffset procedure} {fonts} { +} -result {{0 0.1} {{x 0 0.1}}} +test listbox-12.3 {ChangeListboxOffset procedure} -constraints { + fonts +} -body { .l xview 10 update set log {} .l xview 10 update list [format {%.6g %.6g} {*}[.l xview]] $log -} {{0.1 0.2} {}} +} -result {{0.1 0.2} {}} + -catch {destroy .l} +# Listbox used in 13.* tests +destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l .l insert 0 a bb c d e f g h i j k l m n o p q r s @@ -1508,15 +2203,19 @@ pack .l update set width [expr [lindex [.l bbox 2] 2] - [lindex [.l bbox 1] 2]] set height [expr [lindex [.l bbox 2] 1] - [lindex [.l bbox 1] 1]] -test listbox-13.1 {ListboxScanTo procedure} {fonts} { +test listbox-13.1 {ListboxScanTo procedure} -constraints { + fonts +} -body { .l yview 0 .l xview 0 .l scan mark 10 20 .l scan dragto [expr 10-$width] [expr 20-$height] update list [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] -} {{0.2 0.4} {0.5 0.75}} -test listbox-13.2 {ListboxScanTo procedure} {fonts} { +} -result {{0.2 0.4} {0.5 0.75}} +test listbox-13.2 {ListboxScanTo procedure} -constraints { + fonts +} -body { .l yview 5 .l xview 10 .l scan mark 10 20 @@ -1526,8 +2225,10 @@ test listbox-13.2 {ListboxScanTo procedure} {fonts} { .l scan dragto [expr 20-$width] [expr 40-$height] update lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] -} {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}} -test listbox-13.3 {ListboxScanTo procedure} {fonts} { +} -result {{0 0.2} {0 0.25} {0.2 0.4} {0.5 0.75}} +test listbox-13.3 {ListboxScanTo procedure} -constraints { + fonts +} -body { .l yview moveto 1.0 .l xview moveto 1.0 .l scan mark 10 20 @@ -1537,40 +2238,55 @@ test listbox-13.3 {ListboxScanTo procedure} {fonts} { .l scan dragto [expr 5+$width] [expr 10+$height] update lappend x [format {%.6g %.6g} {*}[.l xview]] [format {%.6g %.6g} {*}[.l yview]] -} {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}} +} -result {{0.8 1} {0.75 1} {0.64 0.84} {0.25 0.5}} -test listbox-14.1 {NearestListboxElement procedure, partial last line} { + +test listbox-14.1 {NearestListboxElement procedure, partial last line} -body { mkPartial .partial.l nearest [winfo height .partial.l] -} {4} -catch {destroy .l} +} -result {4} +# Listbox used in 14.* tests +destroy .l listbox .l -font $fixed -width 20 -height 10 .l insert 0 a b c d e f g h i j k l m n o p q r s t .l yview 4 pack .l update -test listbox-14.2 {NearestListboxElement procedure} {fonts} { +test listbox-14.2 {NearestListboxElement procedure} -constraints { + fonts +} -body { .l index @50,0 -} {4} -test listbox-14.3 {NearestListboxElement procedure} {fonts} { +} -result {4} +test listbox-14.3 {NearestListboxElement procedure} -constraints { + fonts +} -body { list [.l index @50,35] [.l index @50,36] -} {5 6} -test listbox-14.4 {NearestListboxElement procedure} {fonts} { +} -result {5 6} +test listbox-14.4 {NearestListboxElement procedure} -constraints { + fonts +} -body { .l index @50,200 -} {13} +} -result {13} + -test listbox-15.1 {ListboxSelect procedure} { +# Listbox used in 15.* 16.* and 17.* tests +destroy .l +listbox .l -font $fixed -width 20 -height 10 +pack .l +update +test listbox-15.1 {ListboxSelect procedure} -body { .l delete 0 end .l insert 0 a b c d e f g h i j k l m n o p .l select set 2 4 .l select set 7 12 .l select clear 4 7 .l curselection -} {2 3 8 9 10 11 12} -test listbox-15.2 {ListboxSelect procedure} { +} -result {2 3 8 9 10 11 12} +test listbox-15.2 {ListboxSelect procedure} -setup { + destroy .e +} -body { .l delete 0 end .l insert 0 a b c d e f g h i j k l m n o p - catch {destroy .e} entry .e .e insert 0 "This is some text" .e select from 0 @@ -1579,78 +2295,81 @@ test listbox-15.2 {ListboxSelect procedure} { set x [selection own] .l selection set 3 list $x [selection own] [selection get] -} {.e .l d} -test listbox-15.3 {ListboxSelect procedure} { +} -cleanup { + destroy .e +} -result {.e .l d} +test listbox-15.3 {ListboxSelect procedure} -body { .l delete 0 end .l selection clear 0 end .l select set 0 end .l curselection -} {} -test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} { +} -result {} +test listbox-15.4 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set -2 -1 .l curselection -} {} -test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} { +} -result {} +test listbox-15.5 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set -1 3 .l curselection -} {0 1 2 3} -test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} { +} -result {0 1 2 3} +test listbox-15.6 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 2 4 .l curselection -} {2 3 4} -test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} { +} -result {2 3 4} +test listbox-15.7 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 4 end .l curselection -} {4 5} -test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} { +} -result {4 5} +test listbox-15.8 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 4 30 .l curselection -} {4 5} -test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} { +} -result {4 5} +test listbox-15.9 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set end 30 .l curselection -} {5} -test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} { +} -result {5} +test listbox-15.10 {ListboxSelect procedure, boundary conditions for indices} -body { .l delete 0 end .l insert 0 a b c d e f .l select clear 0 end .l select set 20 25 .l curselection -} {} +} -result {} + -test listbox-16.1 {ListboxFetchSelection procedure} { +test listbox-16.1 {ListboxFetchSelection procedure} -body { .l delete 0 end .l insert 0 a b c "two words" e f g h i \\ k l m n o p .l selection set 2 4 .l selection set 9 .l selection set 11 12 selection get -} "c\ntwo words\ne\n\\\nl\nm" -test listbox-16.2 {ListboxFetchSelection procedure} { +} -result "c\ntwo words\ne\n\\\nl\nm" +test listbox-16.2 {ListboxFetchSelection procedure} -body { .l delete 0 end .l insert 0 a b c "two words" e f g h i \\ k l m n o p .l selection set 3 selection get -} "two words" -test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} { +} -result "two words" +test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} -body { set long "This is quite a long string\n" append long $long $long $long $long append long $long $long $long $long @@ -1660,38 +2379,48 @@ test listbox-16.3 {ListboxFetchSelection procedure, retrieve in several parts} { .l selection set 0 end set sel [selection get] string compare 1$long\n2$long\n3$long\n4$long\n5$long $sel -} {0} -catch {unset long sel} +} -cleanup { + catch {unset long sel} +} -result {0} + -test listbox-17.1 {ListboxLostSelection procedure} { +test listbox-17.1 {ListboxLostSelection procedure} -setup { + destroy .e +} -body { .l delete 0 end .l insert 0 a b c d e .l select set 0 end - catch {destroy .e} entry .e .e insert 0 "This is some text" .e select from 0 .e select to 5 .l curselection -} {} -test listbox-17.2 {ListboxLostSelection procedure} { +} -cleanup { + destroy .e +} -result {} +test listbox-17.2 {ListboxLostSelection procedure} -setup { + destroy .e +} -body { .l delete 0 end .l insert 0 a b c d e .l select set 0 end .l configure -exportselection 0 - catch {destroy .e} entry .e .e insert 0 "This is some text" .e select from 0 .e select to 5 .l curselection -} {0 1 2 3 4} +} -cleanup { + destroy .e +} -result {0 1 2 3 4} -catch {destroy .l} + +# Listbox used in 18.* tests +destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l update -test listbox-18.1 {ListboxUpdateVScrollbar procedure} { +test listbox-18.1 {ListboxUpdateVScrollbar procedure} -body { .l configure -yscrollcommand "record y" set log {} .l insert 0 a b c @@ -1701,37 +2430,40 @@ test listbox-18.1 {ListboxUpdateVScrollbar procedure} { .l delete 0 end update set log -} {{y 0 1} {y 0 0.625} {y 0 1}} -test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} { +} -result {{y 0 1} {y 0 0.625} {y 0 1}} +test listbox-18.2 {ListboxUpdateVScrollbar procedure, partial last line} -body { mkPartial .partial.l configure -yscrollcommand "record y" set log {} .partial.l yview 3 update set log -} {{y 0.2 0.466667}} -test listbox-18.3 {ListboxUpdateVScrollbar procedure} { +} -result {{y 0.2 0.466667}} +test listbox-18.3 {ListboxUpdateVScrollbar procedure} -body { proc bgerror args { - global x errorInfo - set x [list $args $errorInfo] + global x errorInfo + set x [list $args $errorInfo] } .l configure -yscrollcommand gorp .l insert 0 foo update set x -} {{{invalid command name "gorp"}} {invalid command name "gorp" +} -cleanup { + rename bgerror {} +} -result {{{invalid command name "gorp"}} {invalid command name "gorp" while executing "gorp 0.0 1.0" (vertical scrolling command executed by listbox)}} -if {[info exists bgerror]} { - rename bgerror {} -} -catch {destroy .l} + +# Listbox used in 19.* tests +destroy .l listbox .l -font $fixed -width 10 -height 5 pack .l update -test listbox-19.1 {ListboxUpdateVScrollbar procedure} {fonts} { +test listbox-19.1 {ListboxUpdateVScrollbar procedure} -constraints { + fonts +} -body { .l configure -xscrollcommand "record x" set log {} .l insert 0 abc @@ -1741,97 +2473,125 @@ test listbox-19.1 {ListboxUpdateVScrollbar procedure} {fonts} { .l delete 0 end update set log -} {{x 0 1} {x 0 0.322581} {x 0 1}} -test listbox-19.2 {ListboxUpdateVScrollbar procedure} { +} -result {{x 0 1} {x 0 0.322581} {x 0 1}} +test listbox-19.2 {ListboxUpdateVScrollbar procedure} -body { proc bgerror args { - global x errorInfo - set x [list $args $errorInfo] + global x errorInfo + set x [list $args $errorInfo] } .l configure -xscrollcommand bogus .l insert 0 foo update set x -} {{{invalid command name "bogus"}} {invalid command name "bogus" +} -result {{{invalid command name "bogus"}} {invalid command name "bogus" while executing "bogus 0.0 1.0" (horizontal scrolling command executed by listbox)}} -set l [interp hidden] -deleteWindows -test listbox-20.1 {listbox vs hidden commands} { - catch {destroy .l} +test listbox-20.1 {listbox vs hidden commands} -setup { + deleteWindows +} -body { + set l [interp hidden] listbox .l interp hide {} .l destroy .l - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -result 1 + # tests for ListboxListVarProc -test listbox-21.1 {ListboxListVarProc} { - catch {destroy .l} +test listbox-21.1 {ListboxListVarProc} -setup { + destroy .l +} -body { catch {unset x} listbox .l -listvar x set x [list a b c d] .l get 0 end -} [list a b c d] -test listbox-21.2 {ListboxListVarProc} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list a b c d] +test listbox-21.2 {ListboxListVarProc} -setup { + destroy .l +} -body { set x [list a b c d] listbox .l -listvar x unset x set x -} [list a b c d] -test listbox-21.3 {ListboxListVarProc} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list a b c d] +test listbox-21.3 {ListboxListVarProc} -setup { + destroy .l +} -body { set x [list a b c d] listbox .l -listvar x .l configure -listvar {} unset x info exists x -} 0 -test listbox-21.4 {ListboxListVarProc} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result 0 +test listbox-21.4 {ListboxListVarProc} -setup { + destroy .l +} -body { set x [list a b c d] listbox .l -listvar x lappend x e f g .l size -} 7 -test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result 7 +test listbox-21.5 {ListboxListVarProc, test selection after listvar mod} -setup { + destroy .l +} -body { set x [list a b c d e f g] listbox .l -listvar x .l selection set end set x [list a b c d] set x [list 0 1 2 3 4 5 6] .l curselection -} {} -test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {} +test listbox-21.6 {ListboxListVarProc, test selection after listvar mod} -setup { + destroy .l +} -body { set x [list a b c d] listbox .l -listvar x .l selection set 3 lappend x e f g .l curselection -} 3 -test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result 3 +test listbox-21.7 {ListboxListVarProc, test selection after listvar mod} -setup { + destroy .l +} -body { set x [list a b c d] listbox .l -listvar x .l selection set 0 set x [linsert $x 0 1 2 3 4] .l curselection -} 0 -test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result 0 +test listbox-21.8 {ListboxListVarProc, test selection after listvar mod} -setup { + destroy .l +} -body { set x [list a b c d] listbox .l -listvar x .l selection set 2 set x [list a b c] .l curselection -} 2 -test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result 2 +test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} -setup { + destroy .l +} -body { catch {unset x} set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x @@ -1842,9 +2602,12 @@ test listbox-21.9 {ListboxListVarProc, test hscrollbar after listvar mod} { lappend x "00000000000000000000" update set log -} [list {x 0 1} {x 0 1} {x 0 0.5}] -test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list {x 0 1} {x 0 1} {x 0 0.5}] +test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} -setup { + destroy .l +} -body { catch {unset x} set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" -listvar x @@ -1857,53 +2620,71 @@ test listbox-21.10 {ListboxListVarProc, test hscrollbar after listvar mod} { set x [list "0000000000"] update set log -} [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}] -test listbox-21.11 {ListboxListVarProc, bad list} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list {x 0 1} {x 0 1} {x 0 0.5} {x 0 1}] +test listbox-21.11 {ListboxListVarProc, bad list} -setup { + destroy .l +} -body { catch {unset x} listbox .l -listvar x set x [list a b c d] catch {set x "this is a \" bad list"} result set result -} {can't set "x": invalid listvar value} -test listbox-21.12 {ListboxListVarProc, cleanup item attributes} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {can't set "x": invalid listvar value} +test listbox-21.12 {ListboxListVarProc, cleanup item attributes} -setup { + destroy .l +} -body { set x [list a b c d e f g] listbox .l -listvar x .l itemconfigure end -fg red set x [list a b c d] set x [list 0 1 2 3 4 5 6] .l itemcget end -fg -} {} -test listbox-21.12a {ListboxListVarProc, cleanup item attributes} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {} +test listbox-21.12a {ListboxListVarProc, cleanup item attributes} -setup { + destroy .l +} -body { set x [list a b c d e f g] listbox .l -listvar x .l itemconfigure end -fg red set x [list a b c d] set x [list 0 1 2 3 4 5 6] .l itemcget end -fg -} {} -test listbox-21.13 {listbox item configurations and listvar based deletions} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {} +test listbox-21.13 {listbox item configurations and listvar based deletions} -setup { + destroy .l +} -body { catch {unset x} listbox .l -listvar x .l insert end a b c .l itemconfigure 1 -fg red set x [list b c] .l itemcget 1 -fg -} red -test listbox-21.14 {listbox item configurations and listvar based inserts} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result red +test listbox-21.14 {listbox item configurations and listvar based inserts} -setup { + destroy .l +} -body { catch {unset x} listbox .l -listvar x .l insert end a b c .l itemconfigure 0 -fg red set x [list 1 2 3 4 a b c] .l itemcget 0 -fg -} red -test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result red +test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} -setup { + destroy .l +} -body { catch {unset x} set log {} listbox .l -listvar x -yscrollcommand "record y" -font fixed -height 3 @@ -1912,9 +2693,12 @@ test listbox-21.15 {ListboxListVarProc, update vertical scrollbar} { lappend x a b c d e f update set log -} [list {y 0 1} {y 0 0.5}] -test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list {y 0 1} {y 0 0.5}] +test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} -setup { + destroy .l +} -body { catch {unset x} listbox .l -listvar x -height 3 pack .l @@ -1930,11 +2714,15 @@ test listbox-21.16 {ListboxListVarProc, update vertical scrollbar} { update lappend result [format {%.6g %.6g} {*}[.l yview]] set result -} [list {0.5 1} {0 1}] +} -cleanup { + destroy .l +} -result [list {0.5 1} {0 1}] + # UpdateHScrollbar -test listbox-22.1 {UpdateHScrollbar} { - catch {destroy .l} +test listbox-22.1 {UpdateHScrollbar} -setup { + destroy .l +} -body { set log {} listbox .l -font $fixed -width 10 -xscrollcommand "record x" pack .l @@ -1944,41 +2732,57 @@ test listbox-22.1 {UpdateHScrollbar} { .l insert end "00000000000000000000" update set log -} [list {x 0 1} {x 0 1} {x 0 0.5}] +} -cleanup { + destroy .l +} -result [list {x 0 1} {x 0 1} {x 0 0.5}] + # ConfigureListboxItem -test listbox-23.1 {ConfigureListboxItem} { - catch {destroy .l} +test listbox-23.1 {ConfigureListboxItem} -setup { + destroy .l +} -body { listbox .l catch {.l itemconfigure 0} result set result -} {item number "0" out of range} -test listbox-23.2 {ConfigureListboxItem} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {item number "0" out of range} +test listbox-23.2 {ConfigureListboxItem} -setup { + destroy .l +} -body { listbox .l .l insert end a b c d .l itemconfigure 0 -} [list {-background background Background {} {}} \ +} -cleanup { + destroy .l +} -result [list {-background background Background {} {}} \ {-bg -background} \ {-fg -foreground} \ {-foreground foreground Foreground {} {}} \ {-selectbackground selectBackground Foreground {} {}} \ {-selectforeground selectForeground Background {} {}}] -test listbox-23.3 {ConfigureListboxItem, itemco shortcut} { - catch {destroy .l} +test listbox-23.3 {ConfigureListboxItem, itemco shortcut} -setup { + destroy .l +} -body { listbox .l .l insert end a b c d .l itemco 0 -background -} {-background background Background {} {}} -test listbox-23.4 {ConfigureListboxItem, wrong num args} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {-background background Background {} {}} +test listbox-23.4 {ConfigureListboxItem, wrong num args} -setup { + destroy .l +} -body { listbox .l .l insert end a catch {.l itemco} result set result -} {wrong # args: should be ".l itemconfigure index ?option? ?value? ?option value ...?"} -test listbox-23.5 {ConfigureListboxItem, multiple calls} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {wrong # args: should be ".l itemconfigure index ?-option? ?value? ?-option value ...?"} +test listbox-23.5 {ConfigureListboxItem, multiple calls} -setup { + destroy .l +} -body { listbox .l set i 0 foreach color {red orange yellow green blue white violet} { @@ -1991,102 +2795,164 @@ test listbox-23.5 {ConfigureListboxItem, multiple calls} { list [.l itemcget 0 -bg] [.l itemcget 1 -bg] [.l itemcget 2 -bg] \ [.l itemcget 3 -bg] [.l itemcget 4 -bg] [.l itemcget 5 -bg] \ [.l itemcget 6 -bg] -} {red orange yellow green blue white violet} -catch {destroy .l} +} -cleanup { + destroy .l +} -result {red orange yellow green blue white violet} + +# Listbox used in 23.6 -23.17 tests +destroy .l listbox .l .l insert end a b c d -set i 6 -foreach test { - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} -} { - set name [lindex $test 0] - test listbox-23.$i {configuration options} { - .l itemconfigure 0 $name [lindex $test 1] - list [lindex [.l itemconfigure 0 $name] 4] [.l itemcget 0 $name] - } [list [lindex $test 2] [lindex $test 2]] - incr i - if {[lindex $test 3] != ""} { - test listbox-23.$i {configuration options} { - list [catch {.l configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .l configure $name [lindex [.l configure $name] 3] - incr i -} +test listbox-23.6 {configuration options} -body { + .l itemconfigure 0 -background #ff0000 + list [lindex [.l itemconfigure 0 -background] 4] [.l itemcget 0 -background] +} -cleanup { + .l configure -background #ffffff +} -result {{#ff0000} #ff0000} +test listbox-23.7 {configuration options} -body { + .l configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test listbox-23.8 {configuration options} -body { + .l itemconfigure 0 -bg #ff0000 + list [lindex [.l itemconfigure 0 -bg] 4] [.l itemcget 0 -bg] +} -cleanup { + .l configure -bg #ffffff +} -result {{#ff0000} #ff0000} +test listbox-23.9 {configuration options} -body { + .l configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test listbox-23.10 {configuration options} -body { + .l itemconfigure 0 -fg #110022 + list [lindex [.l itemconfigure 0 -fg] 4] [.l itemcget 0 -fg] +} -cleanup { + .l configure -fg #000000 +} -result {{#110022} #110022} +test listbox-23.11 {configuration options} -body { + .l configure -fg bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-23.12 {configuration options} -body { + .l itemconfigure 0 -foreground #110022 + list [lindex [.l itemconfigure 0 -foreground] 4] [.l itemcget 0 -foreground] +} -cleanup { + .l configure -foreground #000000 +} -result {{#110022} #110022} +test listbox-23.13 {configuration options} -body { + .l configure -foreground bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-23.14 {configuration options} -body { + .l itemconfigure 0 -selectbackground #110022 + list [lindex [.l itemconfigure 0 -selectbackground] 4] [.l itemcget 0 -selectbackground] +} -cleanup { + .l configure -selectbackground #c3c3c3 +} -result {{#110022} #110022} +test listbox-23.15 {configuration options} -body { + .l configure -selectbackground bogus +} -returnCodes error -result {unknown color name "bogus"} +test listbox-23.16 {configuration options} -body { + .l itemconfigure 0 -selectforeground #654321 + list [lindex [.l itemconfigure 0 -selectforeground] 4] [.l itemcget 0 -selectforeground] +} -cleanup { + .l configure -selectforeground #000000 +} -result {{#654321} #654321} +test listbox-23.17 {configuration options} -body { + .l configure -selectforeground bogus +} -returnCodes error -result {unknown color name "bogus"} + # ListboxWidgetObjCmd, itemcget -test listbox-24.1 {itemcget} { - catch {destroy .l} +test listbox-24.1 {itemcget} -setup { + destroy .l +} -body { listbox .l .l insert end a b c d .l itemcget 0 -fg -} {} -test listbox-24.2 {itemcget} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {} +test listbox-24.2 {itemcget} -setup { + destroy .l +} -body { listbox .l .l insert end a b c d .l itemconfigure 0 -fg red .l itemcget 0 -fg -} red -test listbox-24.3 {itemcget} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result red +test listbox-24.3 {itemcget} -setup { + destroy .l +} -body { listbox .l .l insert end a b c d catch {.l itemcget 0} result set result -} {wrong # args: should be ".l itemcget index option"} -test listbox-24.4 {itemcget, itemcg shortcut} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {wrong # args: should be ".l itemcget index option"} +test listbox-24.4 {itemcget, itemcg shortcut} -setup { + destroy .l +} -body { listbox .l .l insert end a b c d catch {.l itemcg 0} result set result -} {wrong # args: should be ".l itemcget index option"} +} -cleanup { + destroy .l +} -result {wrong # args: should be ".l itemcget index option"} + # General item configuration issues -test listbox-25.1 {listbox item configurations and widget based deletions} { - catch {destroy .l} +test listbox-25.1 {listbox item configurations and widget based deletions} -setup { + destroy .l +} -body { listbox .l .l insert end a .l itemconfigure 0 -fg red .l delete 0 end .l insert end a .l itemcget 0 -fg -} {} -test listbox-25.2 {listbox item configurations and widget based inserts} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result {} +test listbox-25.2 {listbox item configurations and widget based inserts} -setup { + destroy .l +} -body { listbox .l .l insert end a b c .l itemconfigure 0 -fg red .l insert 0 1 2 3 4 list [.l itemcget 0 -fg] [.l itemcget 4 -fg] -} [list {} red] +} -cleanup { + destroy .l +} -result {{} red} + # state issues -test listbox-26.1 {listbox disabled state disallows inserts} { - catch {destroy .l} +test listbox-26.1 {listbox disabled state disallows inserts} -setup { + destroy .l +} -body { listbox .l .l insert end a b c .l configure -state disabled .l insert end d e f .l get 0 end -} [list a b c] -test listbox-26.2 {listbox disabled state disallows deletions} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list a b c] +test listbox-26.2 {listbox disabled state disallows deletions} -setup { + destroy .l +} -body { listbox .l .l insert end a b c .l configure -state disabled .l delete 0 end .l get 0 end -} [list a b c] -test listbox-26.3 {listbox disabled state disallows selection modification} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list a b c] +test listbox-26.3 {listbox disabled state disallows selection modification} -setup { + destroy .l +} -body { listbox .l .l insert end a b c .l selection set 0 @@ -2095,58 +2961,89 @@ test listbox-26.3 {listbox disabled state disallows selection modification} { .l selection clear 0 end .l selection set 1 .l curselection -} [list 0 2] -test listbox-26.4 {listbox disabled state disallows anchor modification} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result [list 0 2] +test listbox-26.4 {listbox disabled state disallows anchor modification} -setup { + destroy .l +} -body { listbox .l .l insert end a b c .l selection anchor 0 .l configure -state disabled .l selection anchor 2 .l index anchor -} 0 -test listbox-26.5 {listbox disabled state disallows active modification} { - catch {destroy .l} +} -cleanup { + destroy .l +} -result 0 +test listbox-26.5 {listbox disabled state disallows active modification} -setup { + destroy .l +} -body { listbox .l .l insert end a b c .l activate 0 .l configure -state disabled .l activate 2 .l index active -} 0 +} -cleanup { + destroy .l +} -result 0 -test listbox-27.1 {widget deletion while active} { + +test listbox-27.1 {widget deletion while active} -setup { destroy .l +} -body { pack [listbox .l] update .l configure -cursor xterm -xscrollcommand { destroy .l } update idle winfo exists .l -} 0 +} -cleanup { + destroy .l +} -result 0 -test listbox-28.1 {listbox -activestyle} { + +test listbox-28.1 {listbox -activestyle} -setup { destroy .l +} -body { listbox .l -activ non .l cget -activestyle -} none -test listbox-28.2-nonwin {listbox -activestyle} {nonwin} { +} -cleanup { + destroy .l +} -result none +test listbox-28.2 {listbox -activestyle} -constraints { + nonwin +} -setup { destroy .l +} -body { listbox .l .l cget -activestyle -} dotbox -test listbox-28.2-win {listbox -activestyle} {win} { +} -cleanup { destroy .l +} -result dotbox +test listbox-28.3 {listbox -activestyle} -constraints { + win +} -setup { + destroy .l +} -body { listbox .l .l cget -activestyle -} underline -test listbox-28.3 {listbox -activestyle} { +} -cleanup { + destroy .l +} -result underline +test listbox-28.4 {listbox -activestyle} -setup { destroy .l +} -body { listbox .l -activestyle und .l cget -activestyle -} underline +} -cleanup { + destroy .l +} -result underline -test listbox-29.1 {listbox selection behavior, -state disabled} { + +test listbox-29.1 {listbox selection behavior, -state disabled} -setup { destroy .l +} -body { listbox .l .l insert end 1 2 3 .l selection set 2 @@ -2156,7 +3053,9 @@ test listbox-29.1 {listbox selection behavior, -state disabled} { # but selection cannot be changed (new behavior since 8.4) .l selection set 3 lappend out [.l selection includes 2] [.l curselection] -} {1 1 2} +} -cleanup { + destroy .l +} -result {1 1 2} resetGridInfo deleteWindows @@ -2165,3 +3064,8 @@ option clear # cleanup cleanupTests return + + + + + diff --git a/tests/main.test b/tests/main.test index 1d33fbb..7ab624f 100644 --- a/tests/main.test +++ b/tests/main.test @@ -8,59 +8,55 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands test main-1.1 {StdinProc} -constraints stdio -setup { - set script [makeFile { - close stdin; exit - } script] + set script [makeFile {close stdin; exit} script] } -body { - list [catch {exec [interpreter] <$script} msg] $msg + exec [interpreter] <$script } -cleanup { removeFile script -} -result {0 {}} +} -returnCodes ok -test main-2.1 {Tk_MainEx: -encoding option} -constraints { - stdio - } -setup { - set script [makeFile {} script] - file delete $script - set f [open $script w] - fconfigure $f -encoding utf-8 - puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]; exit" - close $f - catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} - } -body { - read $f - } -cleanup { - close $f - removeFile script - } -result [list script {} 0]\n1\n +test main-2.1 {Tk_MainEx: -encoding option} -constraints stdio -setup { + set script [makeFile {} script] + file delete $script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]; exit" + close $f + catch {set f [open "|[list [interpreter] -encoding utf-8 script]" r]} +} -body { + read $f +} -cleanup { + close $f + removeFile script +} -result "script {} 0\n1\n" -test main-2.2 {Tk_MainEx: -encoding option} -constraints { - stdio - } -setup { - set script [makeFile {} script] - file delete $script - set f [open $script w] - fconfigure $f -encoding utf-8 - puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]; exit" - close $f - catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} - } -body { - read $f - } -cleanup { - close $f - removeFile script - } -result [list script {} 0]\n0\n +test main-2.2 {Tk_MainEx: -encoding option} -constraints stdio -setup { + set script [makeFile {} script] + file delete $script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]; exit" + close $f + catch {set f [open "|[list [interpreter] -encoding ascii script]" r]} +} -body { + read $f +} -cleanup { + close $f + removeFile script +} -result "script {} 0\n0\n" - # Procedure to simulate interactive typing of commands, line by line + # Procedure to simulate interactive typing of commands, line by line, + # for test 2.3 proc type {chan script} { foreach line [split $script \n] { if {[catch { @@ -74,52 +70,50 @@ test main-2.2 {Tk_MainEx: -encoding option} -constraints { } } -test main-2.3 {Tk_MainEx: -encoding option} -constraints { - stdio - } -setup { - set script [makeFile {} script] - file delete $script - set f [open $script w] - fconfigure $f -encoding utf-8 - puts $f {puts [list $argv0 $argv $tcl_interactive]} - puts -nonewline $f {puts [string equal \u20ac } - puts $f "\u20ac]" - close $f - catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} - } -body { - type $f { - puts $argv - exit - } - list [catch {gets $f} line] $line - } -cleanup { - close $f - removeFile script - } -result {0 {-enc utf-8 script}} +test main-2.3 {Tk_MainEx: -encoding option} -constraints stdio -setup { + set script [makeFile {} script] + file delete $script + set f [open $script w] + fconfigure $f -encoding utf-8 + puts $f {puts [list $argv0 $argv $tcl_interactive]} + puts -nonewline $f {puts [string equal \u20ac } + puts $f "\u20ac]" + close $f + catch {set f [open "|[list [interpreter] -enc utf-8 script]" r+]} +} -body { + type $f { + puts $argv + exit + } + gets $f +} -cleanup { + close $f + removeFile script +} -returnCodes ok -result {-enc utf-8 script} test main-3.1 {Tk_ParseArgv: -help option} -constraints unix -body { # Run only on unix as Win32 pops up native dialog - list [catch {exec [interpreter] -help} msg] $msg -} -match glob -result {1 {% Application initialization failed: Command-specific options:*}} + exec [interpreter] -help +} -returnCodes error -match glob -result {% application-specific initialization failed: Command-specific options:*} test main-3.2 {Tk_ParseArgv: -help option} -setup { set maininterp [interp create] } -body { $maininterp eval { set argc 1 ; set argv -help } - list [catch {load {} Tk $maininterp} msg] $msg + load {} Tk $maininterp } -cleanup { interp delete $maininterp -} -match glob -result {1 {Command-specific options:*}} +} -returnCodes error -match glob -result {Command-specific options:*} test main-3.3 {Tk_ParseArgv: -help option} -setup { set maininterp [interp create] } -body { # Repeat of 3.2 to catch cleanup, eg Bug 1927135 $maininterp eval { set argc 1 ; set argv -help } - list [catch {load {} Tk $maininterp} msg] $msg + load {} Tk $maininterp } -cleanup { interp delete $maininterp -} -match glob -result {1 {Command-specific options:*}} +} -returnCodes error -match glob -result {Command-specific options:*} # cleanup cleanupTests diff --git a/tests/menu.test b/tests/menu.test index 3cb47c3..595a21b 100644 --- a/tests/menu.test +++ b/tests/menu.test @@ -5,95 +5,103 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit -# find the earth.gif file for use in these tests +# find the earth.gif file for use in these tests (tests 2.*) set earthPhotoFile [file join [file dirname [info script]] earth.gif] testConstraint hasEarthPhoto [file exists $earthPhotoFile] -test menu-1.1 {Tk_MenuCmd procedure} { - list [catch menu msg] $msg -} {1 {wrong # args: should be "menu pathName ?options?"}} -test menu-1.2 {Tk_MenuCmd procedure} { - list [catch "menu bogus" msg] $msg -} {1 {bad window path name "bogus"}} -test menu-1.3 {Tk_MenuCmd procedure} { - list [catch "menu .m1 foo" msg] $msg -} {1 {unknown option "foo"}} -test menu-1.4 {Tk_MenuCmd procedure} { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test menu-1.5 {Tk_MenuCmd - creating menubar} { - catch {destroy .m1} +test menu-1.1 {Tk_MenuCmd procedure} -body { + menu +} -returnCodes error -result {wrong # args: should be "menu pathName ?-option value ...?"} +test menu-1.2 {Tk_MenuCmd procedure} -body { + menu bogus +} -returnCodes error -result {bad window path name "bogus"} +test menu-1.3 {Tk_MenuCmd procedure} -body { + destroy .m1 + menu .m1 foo +} -returnCodes error -result {unknown option "foo"} +test menu-1.4 {Tk_MenuCmd procedure} -body { + destroy .m1 + menu .m1 +} -cleanup { + deleteWindows +} -result {.m1} +test menu-1.5 {Tk_MenuCmd - creating menubar} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label Test -menu "" - list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] -} {{} {} {}} -test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} { - catch {destroy .t2} - catch {destroy .m1} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-1.6 {Tk_MenuCmd procedure menu ref no cascade} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 - list [catch {menu .m1} msg] $msg [destroy .m1 .t2] -} {0 .m1 {}} -test menu-1.7 {Tk_MenuCmd procedure one clone cascade} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .t2} + menu .m1 +} -cleanup { + deleteWindows +} -result {.m1} +test menu-1.7 {Tk_MenuCmd procedure one clone cascade} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 menu .m1 .m1 add cascade -menu .m2 - list [catch {menu .m2} msg] $msg [destroy .t2 .m1 .m2] -} {0 .m2 {}} -test menu-1.8 {Tk_MenuCmd procedure two clone cascades} { - catch {destroy .m1} - catch {destroy .t2} - catch {destroy .t3} - catch {destroy .m2} + menu .m2 +} -cleanup { + deleteWindows +} -result {.m2} +test menu-1.8 {Tk_MenuCmd procedure two clone cascades} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m2 toplevel .t2 -menu .m1 wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 - list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] -} {0 .m2 {}} -test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} { - catch {destroy .t2} - catch {destroy .m1} - catch {destroy .t3} - catch {destroy .m2} + menu .m2 +} -cleanup { + deleteWindows +} -result {.m2} +test menu-1.9 {Tk_MenuCmd procedure two clone cascades different order} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 menu .m1 .m1 add cascade -menu .m2 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 - list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] -} {0 .m2 {}} -test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} { - catch {destroy .t2} - catch {destroy .t3} - catch {destroy .m1} - catch {destroy .m2} + list [menu .m2] +} -cleanup { + deleteWindows +} -result {.m2} +test menu-1.10 {Tk_MenuCmd procedure two clone cascades menus last} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 menu .m1 .m1 add cascade -menu .m2 - list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .m1 .m2] -} {0 .m2 {}} -test menu-1.11 {Tk_MenuCmd procedure three clones cascades} { - catch {destroy .t2} - catch {destroy .t3} - catch {destroy .t4} - catch {destroy .m1} - catch {destroy .m2} + list [menu .m2] +} -cleanup { + deleteWindows +} -result {.m2} +test menu-1.11 {Tk_MenuCmd procedure three clones cascades} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 toplevel .t3 -menu .m1 @@ -102,93 +110,175 @@ test menu-1.11 {Tk_MenuCmd procedure three clones cascades} { wm geometry .t4 +0+0 menu .m1 .m1 add cascade -menu .m2 - list [catch {menu .m2} msg] $msg [destroy .t2 .t3 .t4 .m1 .m2] -} {0 .m2 {}} -test menu-1.12 {Tk_MenuCmd procedure} { - catch {destroy .t2} - catch {destroy .m1} + list [menu .m2] +} -cleanup { + deleteWindows +} -result {.m2} +test menu-1.12 {Tk_MenuCmd procedure} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 - list [catch {menu .m1} msg] $msg [destroy .t2 .m1] -} {0 .m1 {}} -test menu-1.13 {Tk_MenuCmd procedure} { - catch {destroy .t2} - catch {destroy .t3} - catch {destroy .m1} + list [menu .m1] +} -cleanup { + deleteWindows +} -result {.m1} +test menu-1.13 {Tk_MenuCmd procedure} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 - list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .m1] -} {0 .m1 {}} -test menu-1.14 {Tk_MenuCmd procedure} { - catch {destroy .t2} - catch {destroy .t3} - catch {destroy .t4} - catch {destroy .m1} + list [menu .m1] +} -cleanup { + deleteWindows +} -result {.m1} +test menu-1.14 {Tk_MenuCmd procedure} -setup { + deleteWindows +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 toplevel .t4 -menu .m1 wm geometry .t4 +0+0 - list [catch {menu .m1} msg] $msg [destroy .t2 .t3 .t4 .m1] -} {0 .m1 {}} + list [menu .m1] +} -cleanup { + deleteWindows +} -result {.m1} -catch {destroy .m1} +# Used for 2.1 - 2.30 tests +destroy .m1 menu .m1 -set i 1 -foreach configTest { - {-activebackground #012345 #012345 non-existent - {unknown color name "non-existent"}} - {-activeborderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} - {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bg #110022 #110022 bogus {unknown color name "bogus"}} - {-borderwidth 1.3 1.3 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {} - {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-postcommand "any old string" "any old string" {} {}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-selectcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-takefocus "any string" "any string" {} {}} - {-tearoff 0 0} - {-tearoff 1 1} - {-tearoffcommand "any old string" "any old string" {} {}} -} { - set name [lindex $configTest 0] - set value [lindex $configTest 1] - set result [lindex $configTest 2] - test menu-2.$i [list configuration options $name $value $result] { - .m1 configure $name $value - lindex [.m1 configure $name] 4 - } $result - incr i - if {[lindex $configTest 3] != ""} { - set value [lindex $configTest 3] - set result [lindex $configTest 4] - test menu-2.$i [list configuration options $name $value $result] { - list [catch {.m1 configure $name $value} msg] $msg - } [list 1 $result] - } - .m1 configure $name [lindex [.m1 configure $name] 3] - incr i -} +test menu-2.1 {configuration options -activebackground #012345} -body { + .m1 configure -activebackground #012345 + .m1 cget -activebackground +} -result {#012345} +test menu-2.2 {configuration options -activebackground non-existent} -body { + .m1 configure -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.3 {configuration options -activeborderwidth 1.3} -body { + .m1 configure -activeborderwidth 1.3 + .m1 cget -activeborderwidth +} -result {1.3} +test menu-2.4 {configuration options -activeborderwidth badValue} -body { + .m1 configure -activeborderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} + +test menu-2.5 {configuration options -activeforeground #ff0000} -body { + .m1 configure -activeforeground #ff0000 + .m1 cget -activeforeground +} -result {#ff0000} +test menu-2.6 {configuration options -activeforeground non-existent} -body { + .m1 configure -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.7 {configuration options -background #ff0000} -body { + .m1 configure -background #ff0000 + .m1 cget -background +} -result {#ff0000} +test menu-2.8 {configuration options -background non-existent} -body { + .m1 configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.9 {configuration options -bg #110022} -body { + .m1 configure -bg #110022 + .m1 cget -bg +} -result {#110022} +test menu-2.10 {configuration options -bg bogus} -body { + .m1 configure -bg bogus +} -returnCodes error -result {unknown color name "bogus"} + +test menu-2.11 {configuration options -borderwidth 1.3} -body { + .m1 configure -borderwidth 1.3 + .m1 cget -borderwidth +} -result {1.3} +test menu-2.12 {configuration options -borderwidth badValue} -body { + .m1 configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} + +test menu-2.13 {configuration options -cursor arrow} -body { + .m1 configure -cursor arrow + .m1 cget -cursor +} -result {arrow} +test menu-2.14 {configuration options -cursor badValue} -body { + .m1 configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} + +test menu-2.15 {configuration options -disabledforeground #00ff00} -body { + .m1 configure -disabledforeground #00ff00 + .m1 cget -disabledforeground +} -result {#00ff00} +test menu-2.16 {configuration options -disabledforeground xyzzy} -body { + .m1 configure -disabledforeground xyzzy +} -returnCodes error -result {unknown color name "xyzzy"} + +test menu-2.17 {configuration options -fg #110022} -body { + .m1 configure -fg #110022 + .m1 cget -fg +} -result {#110022} +test menu-2.18 {configuration options -fg bogus} -body { + .m1 configure -fg bogus +} -returnCodes error -result {unknown color name "bogus"} + +test menu-2.19 {configuration options -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} -body { + .m1 configure -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + .m1 cget -font +} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} +test menu-2.20 {configuration options -foreground #110022} -body { + .m1 configure -foreground #110022 + .m1 cget -foreground +} -result {#110022} +test menu-2.21 {configuration options -foreground bogus} -body { + .m1 configure -foreground bogus +} -returnCodes error -result {unknown color name "bogus"} + +test menu-2.22 {configuration options -postcommand {any old string}} -body { + .m1 configure -postcommand {any old string} + .m1 cget -postcommand +} -result {any old string} +test menu-2.23 {configuration options -relief groove} -body { + .m1 configure -relief groove + .m1 cget -relief +} -result {groove} +test menu-2.24 {configuration options -relief 1.5} -body { + .m1 configure -relief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} + +test menu-2.25 {configuration options -selectcolor #110022} -body { + .m1 configure -selectcolor #110022 + .m1 cget -selectcolor +} -result {#110022} +test menu-2.26 {configuration options -selectcolor bogus} -body { + .m1 configure -selectcolor bogus +} -returnCodes error -result {unknown color name "bogus"} + +test menu-2.27 {configuration options -takefocus {any string}} -body { + .m1 configure -takefocus {any string} + .m1 cget -takefocus +} -result {any string} +test menu-2.28 {configuration options -tearoff 0} -body { + .m1 configure -tearoff 0 + .m1 cget -tearoff +} -result {0} +test menu-2.29 {configuration options -tearoff 1} -body { + .m1 configure -tearoff 1 + .m1 cget -tearoff +} -result {1} +test menu-2.30 {configuration options -tearoffcommand {any old string}} -body { + .m1 configure -tearoffcommand {any old string} + .m1 cget -tearoffcommand +} -result {any old string} destroy .m1 # We need to test all of the options with all of the different types of # menu entries. The following code sets up .m1 with 6 items. It then -# runs through the big table below it. +# runs through the 2.31 - 2.228 tests below # index 0 is tearoff, 1 command, 2 cascade, 3 separator, 4 checkbutton, # 5 radiobutton - +deleteWindows menu .m1 .m1 add command -label "command" menu .m2 @@ -197,488 +287,1172 @@ menu .m2 .m1 add separator .m1 add checkbutton -label "checkbutton" -variable check -onvalue on -offvalue off .m1 add radiobutton -label "radiobutton" -variable radio + if {[testConstraint hasEarthPhoto]} { image create photo image1 -file $earthPhotoFile } -foreach configTest { - {-activebackground - {{#012345 - {{unknown option "-activebackground"} #012345 #012345 - {unknown option "-activebackground"} #012345 #012345 - } - } - {non-existent - {{unknown option "-activebackground"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown option "-activebackground"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - } - }} - } - {-activeforeground - {{#ff0000 - {{unknown option "-activeforeground"} - #ff0000 #ff0000 {unknown option "-activeforeground"} #ff0000 #ff0000 - } - } - {non-existent - {{unknown option "-activeforeground"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown option "-activeforeground"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - } - }} - } - {-accelerator - {{"Ctrl+S" - {{unknown option "-accelerator"} - "Ctrl+S" "Ctrl+S" {unknown option "-accelerator"} - "Ctrl+S" "Ctrl+S" - } - }} - } - {-background - {{#ff0000 - {#ff0000 #ff0000 #ff0000 #ff0000 #ff0000 #ff0000 - } - } - {non-existent - {{unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - } - }} - } - {-bitmap - {{questhead - {{unknown option "-bitmap"} questhead questhead - {unknown option "-bitmap"} questhead questhead - } - } - {badValue - {{unknown option "-bitmap"} - {bitmap "badValue" not defined} - {bitmap "badValue" not defined} - {unknown option "-bitmap"} - {bitmap "badValue" not defined} - {bitmap "badValue" not defined} - } - }} - } - {-columnbreak - {{1 - {{unknown option "-columnbreak"} 1 1 - {unknown option "-columnbreak"} 1 1} - }} - } - {-command - {{beep - {{unknown option "-command"} beep beep - {unknown option "-command"} beep beep - } - }} - } - {-font - {{-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - {{unknown option "-font"} - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - {unknown option "-font"} - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - } - } - {{kill rock stars} - {{unknown option "-font"} - {expected integer but got "rock"} - {expected integer but got "rock"} - {unknown option "-font"} - {expected integer but got "rock"} - {expected integer but got "rock"} - } - }} - } - {-foreground - {{#110022 - {{unknown option "-foreground"} #110022 #110022 - {unknown option "-foreground"} #110022 #110022 - } - } - {non-existent - {{unknown option "-foreground"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - {unknown option "-foreground"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - } - }} - } - {-image - {{image1 - {{unknown option "-image"} image1 image1 - {unknown option "-image"} image1 image1 - } - } - {bogus - {{unknown option "-image"} - {image "bogus" doesn't exist} - {image "bogus" doesn't exist} - {unknown option "-image"} - {image "bogus" doesn't exist} - {image "bogus" doesn't exist} - } - } - {"" - {{unknown option "-image"} - {} - {} - {unknown option "-image"} - {} - {} - } - }} - } - {-indicatoron - {{1 - {{unknown option "-indicatoron"} - {unknown option "-indicatoron"} - {unknown option "-indicatoron"} - {unknown option "-indicatoron"} 1 1 - } - }} - } - {-label - {{test - {{unknown option "-label"} test test - {unknown option "-label"} test test - } - }} - } - {-menu - {{.m2 - {{unknown option "-menu"} - {unknown option "-menu"} .m2 - {unknown option "-menu"} - {unknown option "-menu"} - {unknown option "-menu"} - } - }} - } - {-offvalue - {{off - {{unknown option "-offvalue"} - {unknown option "-offvalue"} - {unknown option "-offvalue"} - {unknown option "-offvalue"} - off - {unknown option "-offvalue"} - } - }} - } - {-onvalue - {{on - {{unknown option "-onvalue"} - {unknown option "-onvalue"} - {unknown option "-onvalue"} - {unknown option "-onvalue"} - on - {unknown option "-onvalue"} - } - }} - } - {-selectcolor - {{#110022 - {{unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} - #110022 - #110022 - } - } - {non-existent - {{unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown option "-selectcolor"} - {unknown color name "non-existent"} - {unknown color name "non-existent"} - } - }} - } - {-selectimage - {{image1 - {{unknown option "-selectimage"} - {unknown option "-selectimage"} - {unknown option "-selectimage"} - {unknown option "-selectimage"} image1 image1 - } - } - {bogus - {{unknown option "-selectimage"} - {unknown option "-selectimage"} - {unknown option "-selectimage"} - {unknown option "-selectimage"} - {image "bogus" doesn't exist} - {image "bogus" doesn't exist} - } - } - {"" - {{unknown option "-selectimage"} - {unknown option "-selectimage"} - {unknown option "-selectimage"} - {unknown option "-selectimage"} - {} - {} - } - }} - } - {-state - {{normal - {normal normal normal {unknown option "-state"} normal normal - } - }} - } - {-value - {{"any string" - {{unknown option "-value"} - {unknown option "-value"} - {unknown option "-value"} - {unknown option "-value"} - {unknown option "-value"} "any string" - } - }} - } - {-variable - {{"any string" - {{unknown option "-variable"} - {unknown option "-variable"} - {unknown option "-variable"} - {unknown option "-variable"} - "any string" - "any string" - } - }} - } - {-underline - {{0 - {{unknown option "-underline"} 0 0 - {unknown option "-underline"} 0 0 - } - } - {3p - {{unknown option "-underline"} - {expected integer but got "3p"} - {expected integer but got "3p"} - {unknown option "-underline"} - {expected integer but got "3p"} - {expected integer but got "3p"} - } - }} - } -} { - set name [lindex $configTest 0] - foreach attempt [lindex $configTest 1] { - set value [lindex $attempt 0] - set options [lindex $attempt 1] - foreach item {0 1 2 3 4 5} { - catch {unset msg} - # OK, it's an overeager constraint, but it should also - # normally hold anyway - test menu-2.$i [list entry configuration options $name $item $value [.m1 type $item]] hasEarthPhoto { - set result [catch {.m1 entryconfigure $item $name $value} msg] - if {$result == 1} { - set msg - } else { - lindex [.m1 entryconfigure $item $name] 4 - } - } [lindex $options $item] - incr i - } - } -} +test menu-2.31 {entry configuration options 0 -activebackground #012345 tearoff} -body { + .m1 entryconfigure 0 -activebackground #012345 +} -returnCodes error -result {unknown option "-activebackground"} + +test menu-2.32 {entry configuration options 1 -activebackground #012345 command} -body { + .m1 entryconfigure 1 -activebackground #012345 + lindex [.m1 entryconfigure 1 -activebackground] 4 +} -result {#012345} + +test menu-2.33 {entry configuration options 2 -activebackground #012345 cascade} -body { + .m1 entryconfigure 2 -activebackground #012345 + lindex [.m1 entryconfigure 2 -activebackground] 4 +} -result {#012345} + +test menu-2.34 {entry configuration options 3 -activebackground #012345 separator} -body { + .m1 entryconfigure 3 -activebackground #012345 +} -returnCodes error -result {unknown option "-activebackground"} + +test menu-2.35 {entry configuration options 4 -activebackground #012345 checkbutton} -body { + .m1 entryconfigure 4 -activebackground #012345 + lindex [.m1 entryconfigure 4 -activebackground] 4 +} -result {#012345} + +test menu-2.36 {entry configuration options 5 -activebackground #012345 radiobutton} -body { + .m1 entryconfigure 5 -activebackground #012345 + lindex [.m1 entryconfigure 5 -activebackground] 4 +} -result {#012345} + +test menu-2.37 {entry configuration options 0 -activebackground non-existent tearoff} -body { + .m1 entryconfigure 0 -activebackground non-existent +} -returnCodes error -result {unknown option "-activebackground"} + +test menu-2.38 {entry configuration options 1 -activebackground non-existent command} -body { + .m1 entryconfigure 1 -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.39 {entry configuration options 2 -activebackground non-existent cascade} -body { + .m1 entryconfigure 2 -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.40 {entry configuration options 3 -activebackground non-existent separator} -body { + .m1 entryconfigure 3 -activebackground non-existent +} -returnCodes error -result {unknown option "-activebackground"} + +test menu-2.41 {entry configuration options 4 -activebackground non-existent checkbutton} -body { + .m1 entryconfigure 4 -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.42 {entry configuration options 5 -activebackground non-existent radiobutton} -body { + .m1 entryconfigure 5 -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.43 {entry configuration options 0 -activeforeground #ff0000 tearoff} -body { + .m1 entryconfigure 0 -activeforeground #ff0000 +} -returnCodes error -result {unknown option "-activeforeground"} + +test menu-2.44 {entry configuration options 1 -activeforeground #ff0000 command} -body { + .m1 entryconfigure 1 -activeforeground #ff0000 + lindex [.m1 entryconfigure 1 -activeforeground] 4 +} -result {#ff0000} + +test menu-2.45 {entry configuration options 2 -activeforeground #ff0000 cascade} -body { + .m1 entryconfigure 2 -activeforeground #ff0000 + lindex [.m1 entryconfigure 2 -activeforeground] 4 +} -result {#ff0000} + +test menu-2.46 {entry configuration options 3 -activeforeground #ff0000 separator} -body { + .m1 entryconfigure 3 -activeforeground #ff0000 +} -returnCodes error -result {unknown option "-activeforeground"} + +test menu-2.47 {entry configuration options 4 -activeforeground #ff0000 checkbutton} -body { + .m1 entryconfigure 4 -activeforeground #ff0000 + lindex [.m1 entryconfigure 4 -activeforeground] 4 +} -result {#ff0000} + +test menu-2.48 {entry configuration options 5 -activeforeground #ff0000 radiobutton} -body { + .m1 entryconfigure 5 -activeforeground #ff0000 + lindex [.m1 entryconfigure 5 -activeforeground] 4 +} -result {#ff0000} + +test menu-2.49 {entry configuration options 0 -activeforeground non-existent tearoff} -body { + .m1 entryconfigure 0 -activeforeground non-existent +} -returnCodes error -result {unknown option "-activeforeground"} + +test menu-2.50 {entry configuration options 1 -activeforeground non-existent command} -body { + .m1 entryconfigure 1 -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.51 {entry configuration options 2 -activeforeground non-existent cascade} -body { + .m1 entryconfigure 2 -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.52 {entry configuration options 3 -activeforeground non-existent separator} -body { + .m1 entryconfigure 3 -activeforeground non-existent +} -returnCodes error -result {unknown option "-activeforeground"} + +test menu-2.53 {entry configuration options 4 -activeforeground non-existent checkbutton} -body { + .m1 entryconfigure 4 -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.54 {entry configuration options 5 -activeforeground non-existent radiobutton} -body { + .m1 entryconfigure 5 -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.55 {entry configuration options 0 -accelerator Ctrl+S tearoff} -body { + .m1 entryconfigure 0 -accelerator Ctrl+S +} -returnCodes error -result {unknown option "-accelerator"} + +test menu-2.56 {entry configuration options 1 -accelerator Ctrl+S command} -body { + .m1 entryconfigure 1 -accelerator Ctrl+S + lindex [.m1 entryconfigure 1 -accelerator] 4 +} -result {Ctrl+S} + +test menu-2.57 {entry configuration options 2 -accelerator Ctrl+S cascade} -body { + .m1 entryconfigure 2 -accelerator Ctrl+S + lindex [.m1 entryconfigure 2 -accelerator] 4 +} -result {Ctrl+S} + +test menu-2.58 {entry configuration options 3 -accelerator Ctrl+S separator} -body { + .m1 entryconfigure 3 -accelerator Ctrl+S +} -returnCodes error -result {unknown option "-accelerator"} + +test menu-2.59 {entry configuration options 4 -accelerator Ctrl+S checkbutton} -body { + .m1 entryconfigure 4 -accelerator Ctrl+S + lindex [.m1 entryconfigure 4 -accelerator] 4 +} -result {Ctrl+S} + +test menu-2.60 {entry configuration options 5 -accelerator Ctrl+S radiobutton} -body { + .m1 entryconfigure 5 -accelerator Ctrl+S + lindex [.m1 entryconfigure 5 -accelerator] 4 +} -result {Ctrl+S} + +test menu-2.61 {entry configuration options 0 -background #ff0000 tearoff} -body { + .m1 entryconfigure 0 -background #ff0000 + lindex [.m1 entryconfigure 0 -background] 4 +} -result {#ff0000} + +test menu-2.62 {entry configuration options 1 -background #ff0000 command} -body { + .m1 entryconfigure 1 -background #ff0000 + lindex [.m1 entryconfigure 1 -background] 4 +} -result {#ff0000} + +test menu-2.63 {entry configuration options 2 -background #ff0000 cascade} -body { + .m1 entryconfigure 2 -background #ff0000 + lindex [.m1 entryconfigure 2 -background] 4 +} -result {#ff0000} + +test menu-2.64 {entry configuration options 3 -background #ff0000 separator} -body { + .m1 entryconfigure 3 -background #ff0000 + lindex [.m1 entryconfigure 3 -background] 4 +} -result {#ff0000} + +test menu-2.65 {entry configuration options 4 -background #ff0000 checkbutton} -body { + .m1 entryconfigure 4 -background #ff0000 + lindex [.m1 entryconfigure 4 -background] 4 +} -result {#ff0000} + +test menu-2.66 {entry configuration options 5 -background #ff0000 radiobutton} -body { + .m1 entryconfigure 5 -background #ff0000 + lindex [.m1 entryconfigure 5 -background] 4 +} -result {#ff0000} + +test menu-2.67 {entry configuration options 0 -background non-existent tearoff} -body { + .m1 entryconfigure 0 -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.68 {entry configuration options 1 -background non-existent command} -body { + .m1 entryconfigure 1 -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.69 {entry configuration options 2 -background non-existent cascade} -body { + .m1 entryconfigure 2 -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.70 {entry configuration options 3 -background non-existent separator} -body { + .m1 entryconfigure 3 -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.71 {entry configuration options 4 -background non-existent checkbutton} -body { + .m1 entryconfigure 4 -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.72 {entry configuration options 5 -background non-existent radiobutton} -body { + .m1 entryconfigure 5 -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.73 {entry configuration options 0 -bitmap questhead tearoff} -body { + .m1 entryconfigure 0 -bitmap questhead +} -returnCodes error -result {unknown option "-bitmap"} + +test menu-2.74 {entry configuration options 1 -bitmap questhead command} -body { + .m1 entryconfigure 1 -bitmap questhead + lindex [.m1 entryconfigure 1 -bitmap] 4 +} -result {questhead} + +test menu-2.75 {entry configuration options 2 -bitmap questhead cascade} -body { + .m1 entryconfigure 2 -bitmap questhead + lindex [.m1 entryconfigure 2 -bitmap] 4 +} -result {questhead} + +test menu-2.76 {entry configuration options 3 -bitmap questhead separator} -body { + .m1 entryconfigure 3 -bitmap questhead +} -returnCodes error -result {unknown option "-bitmap"} + +test menu-2.77 {entry configuration options 4 -bitmap questhead checkbutton} -body { + .m1 entryconfigure 4 -bitmap questhead + lindex [.m1 entryconfigure 4 -bitmap] 4 +} -result {questhead} + +test menu-2.78 {entry configuration options 5 -bitmap questhead radiobutton} -body { + .m1 entryconfigure 5 -bitmap questhead + lindex [.m1 entryconfigure 5 -bitmap] 4 +} -result {questhead} + +test menu-2.79 {entry configuration options 0 -bitmap badValue tearoff} -body { + .m1 entryconfigure 0 -bitmap badValue +} -returnCodes error -result {unknown option "-bitmap"} + +test menu-2.80 {entry configuration options 1 -bitmap badValue command} -body { + .m1 entryconfigure 1 -bitmap badValue +} -returnCodes error -result {bitmap "badValue" not defined} + +test menu-2.81 {entry configuration options 2 -bitmap badValue cascade} -body { + .m1 entryconfigure 2 -bitmap badValue +} -returnCodes error -result {bitmap "badValue" not defined} + +test menu-2.82 {entry configuration options 3 -bitmap badValue separator} -body { + .m1 entryconfigure 3 -bitmap badValue +} -returnCodes error -result {unknown option "-bitmap"} + +test menu-2.83 {entry configuration options 4 -bitmap badValue checkbutton} -body { + .m1 entryconfigure 4 -bitmap badValue +} -returnCodes error -result {bitmap "badValue" not defined} + +test menu-2.84 {entry configuration options 5 -bitmap badValue radiobutton} -body { + .m1 entryconfigure 5 -bitmap badValue +} -returnCodes error -result {bitmap "badValue" not defined} + +test menu-2.85 {entry configuration options 0 -columnbreak 1 tearoff} -body { + .m1 entryconfigure 0 -columnbreak 1 +} -returnCodes error -result {unknown option "-columnbreak"} +test menu-2.86 {entry configuration options 1 -columnbreak 1 command} -body { + .m1 entryconfigure 1 -columnbreak 1 + lindex [.m1 entryconfigure 1 -columnbreak] 4 +} -result {1} + +test menu-2.87 {entry configuration options 2 -columnbreak 1 cascade} -body { + .m1 entryconfigure 2 -columnbreak 1 + lindex [.m1 entryconfigure 2 -columnbreak] 4 +} -result {1} + +test menu-2.88 {entry configuration options 3 -columnbreak 1 separator} -body { + .m1 entryconfigure 3 -columnbreak 1 +} -returnCodes error -result {unknown option "-columnbreak"} + +test menu-2.89 {entry configuration options 4 -columnbreak 1 checkbutton} -body { + .m1 entryconfigure 4 -columnbreak 1 + lindex [.m1 entryconfigure 4 -columnbreak] 4 +} -result {1} + +test menu-2.90 {entry configuration options 5 -columnbreak 1 radiobutton} -body { + .m1 entryconfigure 5 -columnbreak 1 + lindex [.m1 entryconfigure 5 -columnbreak] 4 +} -result {1} + +test menu-2.91 {entry configuration options 0 -command beep tearoff} -body { + .m1 entryconfigure 0 -command beep +} -returnCodes error -result {unknown option "-command"} + +test menu-2.92 {entry configuration options 1 -command beep command} -body { + .m1 entryconfigure 1 -command beep + lindex [.m1 entryconfigure 1 -command] 4 +} -result {beep} + +test menu-2.93 {entry configuration options 2 -command beep cascade} -body { + .m1 entryconfigure 2 -command beep + lindex [.m1 entryconfigure 2 -command] 4 +} -result {beep} + +test menu-2.94 {entry configuration options 3 -command beep separator} -body { + .m1 entryconfigure 3 -command beep +} -returnCodes error -result {unknown option "-command"} + +test menu-2.95 {entry configuration options 4 -command beep checkbutton} -body { + .m1 entryconfigure 4 -command beep + lindex [.m1 entryconfigure 4 -command] 4 +} -result {beep} + +test menu-2.96 {entry configuration options 5 -command beep radiobutton} -body { + .m1 entryconfigure 5 -command beep + lindex [.m1 entryconfigure 5 -command] 4 +} -result {beep} + +test menu-2.97 {entry configuration options 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* tearoff} -body { + .m1 entryconfigure 0 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* +} -returnCodes error -result {unknown option "-font"} + +test menu-2.98 {entry configuration options 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* command} -body { + .m1 entryconfigure 1 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + lindex [.m1 entryconfigure 1 -font] 4 +} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} + +test menu-2.99 {entry configuration options 2 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* cascade} -body { + .m1 entryconfigure 2 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + lindex [.m1 entryconfigure 2 -font] 4 +} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} + +test menu-2.100 {entry configuration options 3 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* separator} -body { + .m1 entryconfigure 3 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* +} -returnCodes error -result {unknown option "-font"} + +test menu-2.101 {entry configuration options 4 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* checkbutton} -body { + .m1 entryconfigure 4 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + lindex [.m1 entryconfigure 4 -font] 4 +} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} + +test menu-2.102 {entry configuration options 5 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* radiobutton} -body { + .m1 entryconfigure 5 -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + lindex [.m1 entryconfigure 5 -font] 4 +} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} + +test menu-2.103 {entry configuration options 0 -font {kill rock stars} tearoff} -body { + .m1 entryconfigure 0 -font {kill rock stars} +} -returnCodes error -result {unknown option "-font"} + +test menu-2.104 {entry configuration options 1 -font {kill rock stars} command} -body { + .m1 entryconfigure 1 -font {kill rock stars} +} -returnCodes error -result {expected integer but got "rock"} + +test menu-2.105 {entry configuration options 2 -font {kill rock stars} cascade} -body { + .m1 entryconfigure 2 -font {kill rock stars} +} -returnCodes error -result {expected integer but got "rock"} + +test menu-2.106 {entry configuration options 3 -font {kill rock stars} separator} -body { + .m1 entryconfigure 3 -font {kill rock stars} +} -returnCodes error -result {unknown option "-font"} + +test menu-2.107 {entry configuration options 4 -font {kill rock stars} checkbutton} -body { + .m1 entryconfigure 4 -font {kill rock stars} +} -returnCodes error -result {expected integer but got "rock"} + +test menu-2.108 {entry configuration options 5 -font {kill rock stars} radiobutton} -body { + .m1 entryconfigure 5 -font {kill rock stars} +} -returnCodes error -result {expected integer but got "rock"} + +test menu-2.109 {entry configuration options 0 -foreground #110022 tearoff} -body { + .m1 entryconfigure 0 -foreground #110022 +} -returnCodes error -result {unknown option "-foreground"} + +test menu-2.110 {entry configuration options 1 -foreground #110022 command} -body { + .m1 entryconfigure 1 -foreground #110022 + lindex [.m1 entryconfigure 1 -foreground] 4 +} -result {#110022} + +test menu-2.111 {entry configuration options 2 -foreground #110022 cascade} -body { + .m1 entryconfigure 2 -foreground #110022 + lindex [.m1 entryconfigure 2 -foreground] 4 +} -result {#110022} + +test menu-2.112 {entry configuration options 3 -foreground #110022 separator} -body { + .m1 entryconfigure 3 -foreground #110022 +} -returnCodes error -result {unknown option "-foreground"} + +test menu-2.113 {entry configuration options 4 -foreground #110022 checkbutton} -body { + .m1 entryconfigure 4 -foreground #110022 + lindex [.m1 entryconfigure 4 -foreground] 4 +} -result {#110022} + +test menu-2.114 {entry configuration options 5 -foreground #110022 radiobutton} -body { + .m1 entryconfigure 5 -foreground #110022 + lindex [.m1 entryconfigure 5 -foreground] 4 +} -result {#110022} + +test menu-2.115 {entry configuration options 0 -foreground non-existent tearoff} -body { + .m1 entryconfigure 0 -foreground non-existent +} -returnCodes error -result {unknown option "-foreground"} + +test menu-2.116 {entry configuration options 1 -foreground non-existent command} -body { + .m1 entryconfigure 1 -foreground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.117 {entry configuration options 2 -foreground non-existent cascade} -body { + .m1 entryconfigure 2 -foreground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.118 {entry configuration options 3 -foreground non-existent separator} -body { + .m1 entryconfigure 3 -foreground non-existent +} -returnCodes error -result {unknown option "-foreground"} + +test menu-2.119 {entry configuration options 4 -foreground non-existent checkbutton} -body { + .m1 entryconfigure 4 -foreground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.120 {entry configuration options 5 -foreground non-existent radiobutton} -body { + .m1 entryconfigure 5 -foreground non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.121 {entry configuration options 0 -image image1 tearoff} -constraints { + hasEarthPhoto +} -body { + .m1 entryconfigure 0 -image image1 +} -returnCodes error -result {unknown option "-image"} + +test menu-2.122 {entry configuration options 1 -image image1 command} -constraints { + hasEarthPhoto +} -setup { + .m1 entryconfigure 1 -image {} +} -body { + .m1 entryconfigure 1 -image image1 + lindex [.m1 entryconfigure 1 -image] 4 +} -cleanup { + .m1 entryconfigure 1 -image {} +} -result {image1} + +test menu-2.123 {entry configuration options 2 -image image1 cascade} -constraints { + hasEarthPhoto +} -setup { + .m1 entryconfigure 2 -image {} +} -body { + .m1 entryconfigure 2 -image image1 + lindex [.m1 entryconfigure 2 -image] 4 +} -cleanup { + .m1 entryconfigure 2 -image {} +} -result {image1} + +test menu-2.124 {entry configuration options 3 -image image1 separator} -constraints { + hasEarthPhoto +} -body { + .m1 entryconfigure 3 -image image1 +} -returnCodes error -result {unknown option "-image"} + +test menu-2.125 {entry configuration options 4 -image image1 checkbutton} -constraints { + hasEarthPhoto +} -setup { + .m1 entryconfigure 4 -image {} +} -body { + .m1 entryconfigure 4 -image image1 + lindex [.m1 entryconfigure 4 -image] 4 +} -cleanup { + .m1 entryconfigure 4 -image {} +} -result {image1} + +test menu-2.126 {entry configuration options 5 -image image1 radiobutton} -constraints { + hasEarthPhoto +} -setup { + .m1 entryconfigure 5 -image {} +} -body { + .m1 entryconfigure 5 -image image1 + lindex [.m1 entryconfigure 5 -image] 4 +} -cleanup { + .m1 entryconfigure 5 -image {} +} -result {image1} + +test menu-2.127 {entry configuration options 0 -image bogus tearoff} -body { + .m1 entryconfigure 0 -image bogus +} -returnCodes error -result {unknown option "-image"} + +test menu-2.128 {entry configuration options 1 -image bogus command} -body { + .m1 entryconfigure 1 -image bogus +} -returnCodes error -result {image "bogus" doesn't exist} + +test menu-2.129 {entry configuration options 2 -image bogus cascade} -body { + .m1 entryconfigure 2 -image bogus +} -returnCodes error -result {image "bogus" doesn't exist} + +test menu-2.130 {entry configuration options 3 -image bogus separator} -body { + .m1 entryconfigure 3 -image bogus +} -returnCodes error -result {unknown option "-image"} + +test menu-2.131 {entry configuration options 4 -image bogus checkbutton} -body { + .m1 entryconfigure 4 -image bogus +} -returnCodes error -result {image "bogus" doesn't exist} + +test menu-2.132 {entry configuration options 5 -image bogus radiobutton} -body { + .m1 entryconfigure 5 -image bogus +} -returnCodes error -result {image "bogus" doesn't exist} + +test menu-2.133 {entry configuration options 0 -image {} tearoff} -body { + .m1 entryconfigure 0 -image +} -returnCodes error -result {unknown option "-image"} + +test menu-2.134 {entry configuration options 1 -image {} command} -setup { + .m1 entryconfigure 1 -image {} +} -body { + .m1 entryconfigure 1 -image + lindex [.m1 entryconfigure 1 -image] 4 +} -result {} + +test menu-2.135 {entry configuration options 2 -image {} cascade} -setup { + .m1 entryconfigure 2 -image {} +} -body { + .m1 entryconfigure 2 -image + lindex [.m1 entryconfigure 2 -image] 4 +} -result {} + +test menu-2.136 {entry configuration options 3 -image {} separator} -body { + .m1 entryconfigure 3 -image +} -returnCodes error -result {unknown option "-image"} + +test menu-2.137 {entry configuration options 4 -image {} checkbutton} -body { + .m1 entryconfigure 4 -image + lindex [.m1 entryconfigure 4 -image] 4 +} -result {} + +test menu-2.138 {entry configuration options 5 -image {} radiobutton} -body { + .m1 entryconfigure 5 -image + lindex [.m1 entryconfigure 5 -image] 4 +} -result {} + +test menu-2.139 {entry configuration options 0 -indicatoron 1 tearoff} -body { + .m1 entryconfigure 0 -indicatoron 1 +} -returnCodes error -result {unknown option "-indicatoron"} + +test menu-2.140 {entry configuration options 1 -indicatoron 1 command} -body { + .m1 entryconfigure 1 -indicatoron 1 +} -returnCodes error -result {unknown option "-indicatoron"} + +test menu-2.141 {entry configuration options 2 -indicatoron 1 cascade} -body { + .m1 entryconfigure 2 -indicatoron 1 +} -returnCodes error -result {unknown option "-indicatoron"} + +test menu-2.142 {entry configuration options 3 -indicatoron 1 separator} -body { + .m1 entryconfigure 3 -indicatoron 1 +} -returnCodes error -result {unknown option "-indicatoron"} + +test menu-2.143 {entry configuration options 4 -indicatoron 1 checkbutton} -body { + .m1 entryconfigure 4 -indicatoron 1 + lindex [.m1 entryconfigure 4 -indicatoron] 4 +} -result {1} + +test menu-2.144 {entry configuration options 5 -indicatoron 1 radiobutton} -body { + .m1 entryconfigure 5 -indicatoron 1 + lindex [.m1 entryconfigure 5 -indicatoron] 4 +} -result {1} + +test menu-2.145 {entry configuration options 0 -label test tearoff} -body { + .m1 entryconfigure 0 -label test +} -returnCodes error -result {unknown option "-label"} + +test menu-2.146 {entry configuration options 1 -label test command} -body { + .m1 entryconfigure 1 -label test + lindex [.m1 entryconfigure 1 -label] 4 +} -result {test} + +test menu-2.147 {entry configuration options 2 -label test cascade} -body { + .m1 entryconfigure 2 -label test + lindex [.m1 entryconfigure 2 -label] 4 +} -result {test} + +test menu-2.148 {entry configuration options 3 -label test separator} -body { + .m1 entryconfigure 3 -label test +} -returnCodes error -result {unknown option "-label"} + +test menu-2.149 {entry configuration options 4 -label test checkbutton} -body { + .m1 entryconfigure 4 -label test + lindex [.m1 entryconfigure 4 -label] 4 +} -result {test} + +test menu-2.150 {entry configuration options 5 -label test radiobutton} -body { + .m1 entryconfigure 5 -label test + lindex [.m1 entryconfigure 5 -label] 4 +} -result {test} + +test menu-2.151 {entry configuration options 0 -menu .m2 tearoff} -body { + .m1 entryconfigure 0 -menu .m2 +} -returnCodes error -result {unknown option "-menu"} + +test menu-2.152 {entry configuration options 1 -menu .m2 command} -body { + .m1 entryconfigure 1 -menu .m2 +} -returnCodes error -result {unknown option "-menu"} + +test menu-2.153 {entry configuration options 2 -menu .m2 cascade} -body { + .m1 entryconfigure 2 -menu .m2 + lindex [.m1 entryconfigure 2 -menu] 4 +} -result {.m2} + +test menu-2.154 {entry configuration options 3 -menu .m2 separator} -body { + .m1 entryconfigure 3 -menu .m2 +} -returnCodes error -result {unknown option "-menu"} + +test menu-2.155 {entry configuration options 4 -menu .m2 checkbutton} -body { + .m1 entryconfigure 4 -menu .m2 +} -returnCodes error -result {unknown option "-menu"} + +test menu-2.156 {entry configuration options 5 -menu .m2 radiobutton} -body { + .m1 entryconfigure 5 -menu .m2 +} -returnCodes error -result {unknown option "-menu"} + +test menu-2.157 {entry configuration options 0 -offvalue off tearoff} -body { + .m1 entryconfigure 0 -offvalue off +} -returnCodes error -result {unknown option "-offvalue"} + +test menu-2.158 {entry configuration options 1 -offvalue off command} -body { + .m1 entryconfigure 1 -offvalue off +} -returnCodes error -result {unknown option "-offvalue"} + +test menu-2.159 {entry configuration options 2 -offvalue off cascade} -body { + .m1 entryconfigure 2 -offvalue off +} -returnCodes error -result {unknown option "-offvalue"} + +test menu-2.160 {entry configuration options 3 -offvalue off separator} -body { + .m1 entryconfigure 3 -offvalue off +} -returnCodes error -result {unknown option "-offvalue"} + +test menu-2.161 {entry configuration options 4 -offvalue off checkbutton} -body { + .m1 entryconfigure 4 -offvalue off + lindex [.m1 entryconfigure 4 -offvalue] 4 +} -result {off} + +test menu-2.162 {entry configuration options 5 -offvalue off radiobutton} -body { + .m1 entryconfigure 5 -offvalue off +} -returnCodes error -result {unknown option "-offvalue"} + +test menu-2.163 {entry configuration options 0 -onvalue on tearoff} -body { + .m1 entryconfigure 0 -onvalue on +} -returnCodes error -result {unknown option "-onvalue"} + +test menu-2.164 {entry configuration options 1 -onvalue on command} -body { + .m1 entryconfigure 1 -onvalue on +} -returnCodes error -result {unknown option "-onvalue"} + +test menu-2.165 {entry configuration options 2 -onvalue on cascade} -body { + .m1 entryconfigure 2 -onvalue on +} -returnCodes error -result {unknown option "-onvalue"} + +test menu-2.166 {entry configuration options 3 -onvalue on separator} -body { + .m1 entryconfigure 3 -onvalue on +} -returnCodes error -result {unknown option "-onvalue"} + +test menu-2.167 {entry configuration options 4 -onvalue on checkbutton} -body { + .m1 entryconfigure 4 -onvalue on + lindex [.m1 entryconfigure 4 -onvalue] 4 +} -result {on} + +test menu-2.168 {entry configuration options 5 -onvalue on radiobutton} -body { + .m1 entryconfigure 5 -onvalue on +} -returnCodes error -result {unknown option "-onvalue"} + +test menu-2.169 {entry configuration options 0 -selectcolor #110022 tearoff} -body { + .m1 entryconfigure 0 -selectcolor #110022 +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.170 {entry configuration options 1 -selectcolor #110022 command} -body { + .m1 entryconfigure 1 -selectcolor #110022 +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.171 {entry configuration options 2 -selectcolor #110022 cascade} -body { + .m1 entryconfigure 2 -selectcolor #110022 +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.172 {entry configuration options 3 -selectcolor #110022 separator} -body { + .m1 entryconfigure 3 -selectcolor #110022 +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.173 {entry configuration options 4 -selectcolor #110022 checkbutton} -body { + .m1 entryconfigure 4 -selectcolor #110022 + lindex [.m1 entryconfigure 4 -selectcolor] 4 +} -result {#110022} + +test menu-2.174 {entry configuration options 5 -selectcolor #110022 radiobutton} -body { + .m1 entryconfigure 5 -selectcolor #110022 + lindex [.m1 entryconfigure 5 -selectcolor] 4 +} -result {#110022} + +test menu-2.175 {entry configuration options 0 -selectcolor non-existent tearoff} -body { + .m1 entryconfigure 0 -selectcolor non-existent +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.176 {entry configuration options 1 -selectcolor non-existent command} -body { + .m1 entryconfigure 1 -selectcolor non-existent +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.177 {entry configuration options 2 -selectcolor non-existent cascade} -body { + .m1 entryconfigure 2 -selectcolor non-existent +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.178 {entry configuration options 3 -selectcolor non-existent separator} -body { + .m1 entryconfigure 3 -selectcolor non-existent +} -returnCodes error -result {unknown option "-selectcolor"} + +test menu-2.179 {entry configuration options 4 -selectcolor non-existent checkbutton} -body { + .m1 entryconfigure 4 -selectcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.180 {entry configuration options 5 -selectcolor non-existent radiobutton} -body { + .m1 entryconfigure 5 -selectcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} + +test menu-2.181 {entry configuration options 0 -selectimage image1 tearoff} -constraints { + hasEarthPhoto +} -body { + .m1 entryconfigure 0 -selectimage image1 +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.182 {entry configuration options 1 -selectimage image1 command} -constraints { + hasEarthPhoto +} -body { + .m1 entryconfigure 1 -selectimage image1 +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.183 {entry configuration options 2 -selectimage image1 cascade} -constraints { + hasEarthPhoto +} -body { + .m1 entryconfigure 2 -selectimage image1 +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.184 {entry configuration options 3 -selectimage image1 separator} -constraints { + hasEarthPhoto +} -body { + .m1 entryconfigure 3 -selectimage image1 +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.185 {entry configuration options 4 -selectimage image1 checkbutton} -constraints { + hasEarthPhoto +} -setup { + .m1 entryconfigure 4 -selectimage {} +} -body { + .m1 entryconfigure 4 -selectimage image1 + lindex [.m1 entryconfigure 4 -selectimage] 4 +} -cleanup { + .m1 entryconfigure 4 -selectimage {} +} -result {image1} + +test menu-2.186 {entry configuration options 5 -selectimage image1 radiobutton} -constraints { + hasEarthPhoto +} -setup { + .m1 entryconfigure 5 -selectimage {} +} -body { + .m1 entryconfigure 5 -selectimage image1 + lindex [.m1 entryconfigure 5 -selectimage] 4 +} -cleanup { + .m1 entryconfigure 5 -selectimage {} +} -result {image1} + +test menu-2.187 {entry configuration options 0 -selectimage bogus tearoff} -body { + .m1 entryconfigure 0 -selectimage bogus +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.188 {entry configuration options 1 -selectimage bogus command} -body { + .m1 entryconfigure 1 -selectimage bogus +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.189 {entry configuration options 2 -selectimage bogus cascade} -body { + .m1 entryconfigure 2 -selectimage bogus +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.190 {entry configuration options 3 -selectimage bogus separator} -body { + .m1 entryconfigure 3 -selectimage bogus +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.191 {entry configuration options 4 -selectimage bogus checkbutton} -body { + .m1 entryconfigure 4 -selectimage bogus +} -returnCodes error -result {image "bogus" doesn't exist} + +test menu-2.192 {entry configuration options 5 -selectimage bogus radiobutton} -body { + .m1 entryconfigure 5 -selectimage bogus +} -returnCodes error -result {image "bogus" doesn't exist} + +test menu-2.193 {entry configuration options 0 -selectimage {} tearoff} -body { + .m1 entryconfigure 0 -selectimage +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.194 {entry configuration options 1 -selectimage {} command} -body { + .m1 entryconfigure 1 -selectimage +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.195 {entry configuration options 2 -selectimage {} cascade} -body { + .m1 entryconfigure 2 -selectimage +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.196 {entry configuration options 3 -selectimage {} separator} -body { + .m1 entryconfigure 3 -selectimage +} -returnCodes error -result {unknown option "-selectimage"} + +test menu-2.197 {entry configuration options 4 -selectimage {} checkbutton} -body { + .m1 entryconfigure 4 -selectimage + lindex [.m1 entryconfigure 4 -selectimage] 4 +} -result {} + +test menu-2.198 {entry configuration options 5 -selectimage {} radiobutton} -body { + .m1 entryconfigure 5 -selectimage + lindex [.m1 entryconfigure 5 -selectimage] 4 +} -result {} + +test menu-2.199 {entry configuration options 0 -state normal tearoff} -body { + .m1 entryconfigure 0 -state normal + lindex [.m1 entryconfigure 0 -state] 4 +} -result {normal} + +test menu-2.200 {entry configuration options 1 -state normal command} -body { + .m1 entryconfigure 1 -state normal + lindex [.m1 entryconfigure 1 -state] 4 +} -result {normal} + +test menu-2.201 {entry configuration options 2 -state normal cascade} -body { + .m1 entryconfigure 2 -state normal + lindex [.m1 entryconfigure 2 -state] 4 +} -result {normal} + +test menu-2.202 {entry configuration options 3 -state normal separator} -body { + .m1 entryconfigure 3 -state normal +} -returnCodes error -result {unknown option "-state"} + +test menu-2.203 {entry configuration options 4 -state normal checkbutton} -body { + .m1 entryconfigure 4 -state normal + lindex [.m1 entryconfigure 4 -state] 4 +} -result {normal} + +test menu-2.204 {entry configuration options 5 -state normal radiobutton} -body { + .m1 entryconfigure 5 -state normal + lindex [.m1 entryconfigure 5 -state] 4 +} -result {normal} + +test menu-2.205 {entry configuration options 0 -value {any string} tearoff} -body { + .m1 entryconfigure 0 -value {any string} +} -returnCodes error -result {unknown option "-value"} + +test menu-2.206 {entry configuration options 1 -value {any string} command} -body { + .m1 entryconfigure 1 -value {any string} +} -returnCodes error -result {unknown option "-value"} + +test menu-2.207 {entry configuration options 2 -value {any string} cascade} -body { + .m1 entryconfigure 2 -value {any string} +} -returnCodes error -result {unknown option "-value"} + +test menu-2.208 {entry configuration options 3 -value {any string} separator} -body { + .m1 entryconfigure 3 -value {any string} +} -returnCodes error -result {unknown option "-value"} + +test menu-2.209 {entry configuration options 4 -value {any string} checkbutton} -body { + .m1 entryconfigure 4 -value {any string} +} -returnCodes error -result {unknown option "-value"} + +test menu-2.210 {entry configuration options 5 -value {any string} radiobutton} -body { + .m1 entryconfigure 5 -value {any string} + lindex [.m1 entryconfigure 5 -value] 4 +} -result {any string} + +test menu-2.211 {entry configuration options 0 -variable {any string} tearoff} -body { + .m1 entryconfigure 0 -variable {any string} +} -returnCodes error -result {unknown option "-variable"} + +test menu-2.212 {entry configuration options 1 -variable {any string} command} -body { + .m1 entryconfigure 1 -variable {any string} +} -returnCodes error -result {unknown option "-variable"} + +test menu-2.213 {entry configuration options 2 -variable {any string} cascade} -body { + .m1 entryconfigure 2 -variable {any string} +} -returnCodes error -result {unknown option "-variable"} + +test menu-2.214 {entry configuration options 3 -variable {any string} separator} -body { + .m1 entryconfigure 3 -variable {any string} +} -returnCodes error -result {unknown option "-variable"} + +test menu-2.215 {entry configuration options 4 -variable {any string} checkbutton} -body { + .m1 entryconfigure 4 -variable {any string} + lindex [.m1 entryconfigure 4 -variable] 4 +} -result {any string} + +test menu-2.216 {entry configuration options 5 -variable {any string} radiobutton} -body { + .m1 entryconfigure 5 -variable {any string} + lindex [.m1 entryconfigure 5 -variable] 4 +} -result {any string} + +test menu-2.217 {entry configuration options 0 -underline 0 tearoff} -body { + .m1 entryconfigure 0 -underline 0 +} -returnCodes error -result {unknown option "-underline"} + +test menu-2.218 {entry configuration options 1 -underline 0 command} -body { + .m1 entryconfigure 1 -underline 0 + lindex [.m1 entryconfigure 1 -underline] 4 +} -result {0} + +test menu-2.219 {entry configuration options 2 -underline 0 cascade} -body { + .m1 entryconfigure 2 -underline 0 + lindex [.m1 entryconfigure 2 -underline] 4 +} -result {0} + +test menu-2.220 {entry configuration options 3 -underline 0 separator} -body { + .m1 entryconfigure 3 -underline 0 +} -returnCodes error -result {unknown option "-underline"} + +test menu-2.221 {entry configuration options 4 -underline 0 checkbutton} -body { + .m1 entryconfigure 4 -underline 0 + lindex [.m1 entryconfigure 4 -underline] 4 +} -result {0} + +test menu-2.222 {entry configuration options 5 -underline 0 radiobutton} -body { + .m1 entryconfigure 5 -underline 0 + lindex [.m1 entryconfigure 5 -underline] 4 +} -result {0} + +test menu-2.223 {entry configuration options 0 -underline 3p tearoff} -body { + .m1 entryconfigure 0 -underline 3p +} -returnCodes error -result {unknown option "-underline"} + +test menu-2.224 {entry configuration options 1 -underline 3p command} -body { + .m1 entryconfigure 1 -underline 3p +} -returnCodes error -result {expected integer but got "3p"} + +test menu-2.225 {entry configuration options 2 -underline 3p cascade} -body { + .m1 entryconfigure 2 -underline 3p +} -returnCodes error -result {expected integer but got "3p"} + +test menu-2.226 {entry configuration options 3 -underline 3p separator} -body { + .m1 entryconfigure 3 -underline 3p +} -returnCodes error -result {unknown option "-underline"} + +test menu-2.227 {entry configuration options 4 -underline 3p checkbutton} -body { + .m1 entryconfigure 4 -underline 3p +} -returnCodes error -result {expected integer but got "3p"} + +test menu-2.228 {entry configuration options 5 -underline 3p radiobutton} -body { + .m1 entryconfigure 5 -underline 3p +} -returnCodes error -result {expected integer but got "3p"} + +deleteWindows if {[testConstraint hasEarthPhoto]} { image delete image1 } -destroy .m1 -destroy .m2 -test menu-3.1 {MenuWidgetCmd procedure} { - catch {destroy .m1} + + +test menu-3.1 {MenuWidgetCmd procedure} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 option ?arg arg ...?"} {}} -test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} {nonUnixUserInteraction } { - catch {destroy .m1} + .m1 +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 option ?arg ...?"} +test menu-3.2 {MenuWidgetCmd, Tcl_Preserve and Tcl_Release} -constraints { + nonUnixUserInteraction +} -setup { + destroy .m1 +} -body { menu .m1 -postcommand "destroy .m1" .m1 add command -label "menu-3.2: Hit Escape" - list [catch {.m1 post 40 40} msg] $msg -} {0 {}} -test menu-3.3 {MenuWidgetCmd procedure, "activate" option} { - catch {destroy .m1} + .m1 post 40 40 +} -cleanup { + destroy .m1 +} -returnCodes ok -result {} +test menu-3.3 {MenuWidgetCmd procedure, "activate" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 activate} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 activate index"} {}} -test menu-3.4 {MenuWidgetCmd procedure, "activate" option} { - catch {destroy .m1} + .m1 activate +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 activate index"} +test menu-3.4 {MenuWidgetCmd procedure, "activate" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 activate "foo"} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.5 {MenuWidgetCmd procedure, "activate" option} { - catch {destroy .m1} + .m1 activate "foo" +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.5 {MenuWidgetCmd procedure, "activate" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 add separator - list [catch {.m1 activate 2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.6 {MenuWidgetCmd procedure, "activate" option} { - catch {destroy .m1} + .m1 activate 2 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.6 {MenuWidgetCmd procedure, "activate" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 entryconfigure 1 -state disabled - list [catch {.m1 activate 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.7 {MenuWidgetCmd procedure, "activate" option} { - catch {destroy .m1} + .m1 activate 1 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.7 {MenuWidgetCmd procedure, "activate" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 activate 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.8 {MenuWidgetCmd procedure, "add" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 add type ?options?"} {}} -test menu-3.9 {MenuWidgetCmd procedure, "add" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add foo} msg] $msg [destroy .m1] -} {1 {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator} {}} -test menu-3.10 {MenuWidgetCmd procedure, "add" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add separator} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.11 {MenuWidgetCmd procedure, "cget" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 cget} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 cget option"} {}} -test menu-3.12 {MenuWidgetCmd procedure, "cget" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 cget -gorp} msg] $msg [destroy .m1] -} {1 {unknown option "-gorp"} {}} -test menu-3.13 {MenuWidgetCmd procedure, "cget" option} { - catch {destroy .m1} + .m1 activate 1 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.8 {MenuWidgetCmd procedure, "add" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 add +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 add type ?-option value ...?"} +test menu-3.9 {MenuWidgetCmd procedure, "add" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 add foo +} -cleanup { + destroy .m1 +} -returnCodes error -result {bad menu entry type "foo": must be cascade, checkbutton, command, radiobutton, or separator} +test menu-3.10 {MenuWidgetCmd procedure, "add" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 add separator +} -cleanup { + destroy .m1 +} -result {} +test menu-3.11 {MenuWidgetCmd procedure, "cget" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 cget +} -returnCodes error -result {wrong # args: should be ".m1 cget option"} +test menu-3.12 {MenuWidgetCmd procedure, "cget" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test menu-3.13 {MenuWidgetCmd procedure, "cget" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 configure -postcommand "Some string" - list [catch {.m1 cget -postcommand} msg] $msg [destroy .m1] -} {0 {Some string} {}} -test menu-3.14 {MenuWidgetCmd procedure, "clone" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 clone} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}} -test menu-3.15 {MenuWidgetCmd procedure, "clone" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 clone a b c d} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 clone newMenuName ?menuType?"} {}} -test menu-3.16 {MenuWidgetCmd procedure, "clone" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 clone .m1.clone1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.17 {MenuWidgetCmd procedure, "clone" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 clone .m1.clone1 tearoff} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.18 {MenuWidgetCmd procedure, "configure" option} { - catch {destroy .m1} - menu .m1 - list [catch {llength [.m1 configure]} msg] $msg [destroy .m1] -} {0 20 {}} -test menu-3.19 {MenuWidgetCmd procedure, "configure" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 configure -gorp} msg] $msg [destroy .m1] -} {1 {unknown option "-gorp"} {}} -test menu-3.20 {MenuWidgetCmd procedure, "configure" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 configure -postcommand "A random String"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.21 {MenuWidgetCmd procedure, "configure" option} { - catch {destroy .m1} + .m1 cget -postcommand +} -cleanup { + destroy .m1 +} -result {Some string} +test menu-3.14 {MenuWidgetCmd procedure, "clone" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 clone +} -returnCodes error -result {wrong # args: should be ".m1 clone newMenuName ?menuType?"} +test menu-3.15 {MenuWidgetCmd procedure, "clone" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 clone a b c d +} -returnCodes error -result {wrong # args: should be ".m1 clone newMenuName ?menuType?"} +test menu-3.16 {MenuWidgetCmd procedure, "clone" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 clone .m1.clone1 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.17 {MenuWidgetCmd procedure, "clone" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 clone .m1.clone1 tearoff +} -cleanup { + destroy .m1 +} -result {} +test menu-3.18 {MenuWidgetCmd procedure, "configure" option} -setup { + destroy .m1 +} -body { + menu .m1 + llength [.m1 configure] +} -cleanup { + destroy .m1 +} -result {20} +test menu-3.19 {MenuWidgetCmd procedure, "configure" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test menu-3.20 {MenuWidgetCmd procedure, "configure" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 configure -postcommand "A random String" +} -cleanup { + destroy .m1 +} -result {} +test menu-3.21 {MenuWidgetCmd procedure, "configure" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 configure -postcommand "Another string" - list [catch {lindex [.m1 configure -postcommand] 4} msg] $msg [destroy .m1] -} {0 {Another string} {}} -test menu-3.22 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 delete} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 delete first ?last?"} {}} -test menu-3.23 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 delete foo} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.24 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 delete 0 "foo"} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.25 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 delete 0} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.26 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} + lindex [.m1 configure -postcommand] 4 +} -cleanup { + destroy .m1 +} -result {Another string} +test menu-3.22 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 delete +} -returnCodes error -result {wrong # args: should be ".m1 delete first ?last?"} +test menu-3.23 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 delete foo +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.24 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 delete 0 "foo" +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.25 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 delete 0 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.26 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "foo" - list [catch {.m1 delete 1 0} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.27 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} + .m1 delete 1 0 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.27 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "1" .m1 add command -label "2" .m1 add command -label "3" - list [catch {.m1 delete 1 3} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.28 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} + .m1 delete 1 3 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.28 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "1" .m1 add command -label "2" .m1 add command -label "3" .m1 activate 2 - list [catch {.m1 delete 1 3} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.29 {MenuWidgetCmd procedure, "delete" option} { - catch {destroy .m1} + .m1 delete 1 3 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.29 {MenuWidgetCmd procedure, "delete" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "1" .m1 add command -label "2" .m1 add command -label "3" .m1 activate 3 - list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} + .m1 delete 1 +} -cleanup { + destroy .m1 +} -result {} test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup { destroy .m1 } -body { @@ -690,224 +1464,328 @@ test menu-3.29+1 {MenuWidgetCmd, "delete", Bug 220950} -setup { } -cleanup { destroy .m1 } -result ok -test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} { - catch {destroy .m1} +test menu-3.30 {MenuWidgetCmd procedure, "entrycget" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 entrycget} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 entrycget index option"} {}} -test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} { - catch {destroy .m1} + .m1 entrycget +} -returnCodes error -result {wrong # args: should be ".m1 entrycget index option"} +test menu-3.31 {MenuWidgetCmd procedure, "entrycget" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 entrycget index option foo} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 entrycget index option"} {}} -test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} { - catch {destroy .m1} + .m1 entrycget index option foo +} -returnCodes error -result {wrong # args: should be ".m1 entrycget index option"} +test menu-3.32 {MenuWidgetCmd procedure, "entrycget" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 entrycget foo -label} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} { - catch {destroy .m1} + .m1 entrycget foo -label +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.33 {MenuWidgetCmd procedure, "entrycget" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] -} {0 test {}} -test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} { - catch {destroy .m1} + .m1 entrycget 1 -label +} -cleanup { + destroy .m1 +} -result {test} +test menu-3.34 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 entryconfigure} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 entryconfigure index ?option value ...?"} {}} -test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} { - catch {destroy .m1} + .m1 entryconfigure +} -returnCodes error -result {wrong # args: should be ".m1 entryconfigure index ?-option value ...?"} +test menu-3.35 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 entryconfigure foo} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} { - catch {destroy .m1} + .m1 entryconfigure foo +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.36 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {llength [.m1 entryconfigure 1]} msg] $msg [destroy .m1] -} {0 15 {}} -test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} { - catch {destroy .m1} + llength [.m1 entryconfigure 1] +} -cleanup { + destroy .m1 +} -result {15} +test menu-3.37 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1] -} {0 test {}} -test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} { - catch {destroy .m1} + lindex [.m1 entryconfigure 1 -label] 4 +} -cleanup { + destroy .m1 +} -result {test} +test menu-3.38 {MenuWidgetCmd procedure, "entryconfigure" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 entryconfigure 1 -label "changed" - list [catch {lindex [.m1 entryconfigure 1 -label] 4} msg] $msg [destroy .m1] -} {0 changed {}} -test menu-3.39 {MenuWidgetCmd procedure, "index" option} { - catch {destroy .m1} + lindex [.m1 entryconfigure 1 -label] 4 +} -cleanup { + destroy .m1 +} -result {changed} +test menu-3.39 {MenuWidgetCmd procedure, "index" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 index} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 index string"} {}} -test menu-3.40 {MenuWidgetCmd procedure, "index" option} { - catch {destroy .m1} + .m1 index +} -returnCodes error -result {wrong # args: should be ".m1 index string"} +test menu-3.40 {MenuWidgetCmd procedure, "index" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 index foo} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.41 {MenuWidgetCmd procedure, "index" option} { - catch {destroy .m1} + .m1 index foo +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.41 {MenuWidgetCmd procedure, "index" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 index "test"} msg] $msg [destroy .m1] -} {0 1 {}} -test menu-3.42 {MenuWidgetCmd procedure, "insert" option} { - catch {destroy .m1} + .m1 index "test" +} -cleanup { + destroy .m1 +} -result {1} +test menu-3.42 {MenuWidgetCmd procedure, "insert" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 insert} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 insert index type ?options?"} {}} -test menu-3.43 {MenuWidgetCmd procedure, "insert" option} { - catch {destroy .m1} + .m1 insert +} -returnCodes error -result {wrong # args: should be ".m1 insert index type ?-option value ...?"} +test menu-3.43 {MenuWidgetCmd procedure, "insert" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 insert 1 command -label "test" - list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] -} {0 test {}} -test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 invoke} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 invoke index"} {}} -test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 invoke foo} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} { - catch {destroy .m1} + .m1 entrycget 1 -label +} -cleanup { + destroy .m1 +} -result {test} +test menu-3.44 {MenuWidgetCmd procedure, "invoke" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 invoke +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 invoke index"} +test menu-3.45 {MenuWidgetCmd procedure, "invoke" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 invoke foo +} -cleanup { + destroy .m1 +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.46 {MenuWidgetCmd procedure, "invoke" option} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add command -label "set foo" -command "set foo hello" - list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 hello 0 hello 0 {} {}} -test menu-3.47 {MenuWidgetCmd procedure, "post" option} { - catch {destroy .m1} + list [.m1 invoke 1] [set foo] [unset foo] +} -cleanup { + destroy .m1 +} -returnCodes ok -result {hello hello {}} +test menu-3.47 {MenuWidgetCmd procedure, "post" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "On Windows, hit Escape to get this menu to go away" - list [catch {.m1 post} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 post x y"} {}} -test menu-3.48 {MenuWidgetCmd procedure, "post" option} { - catch {destroy .m1} + .m1 post +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 post x y"} +test menu-3.48 {MenuWidgetCmd procedure, "post" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 post foo 40} msg] $msg [destroy .m1] -} {1 {expected integer but got "foo"} {}} -test menu-3.49 {MenuWidgetCmd procedure, "post" option} { - catch {destroy .m1} + .m1 post foo 40 +} -cleanup { + destroy .m1 +} -returnCodes error -result {expected integer but got "foo"} +test menu-3.49 {MenuWidgetCmd procedure, "post" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 post 40 bar} msg] $msg [destroy .m1] -} {1 {expected integer but got "bar"} {}} -test menu-3.50 {MenuWidgetCmd procedure, "post" option} {nonUnixUserInteraction } { - catch {destroy .m1} + .m1 post 40 bar +} -cleanup { + destroy .m1 +} -returnCodes error -result {expected integer but got "bar"} +test menu-3.50 {MenuWidgetCmd procedure, "post" option} -constraints { + nonUnixUserInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "menu-3.53: hit Escape" -command "puts hello" - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 postcascade} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 postcascade index"} {}} -test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 postcascade foo} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} {nonUnixUserInteraction } { - catch {destroy .m1} - catch {destroy .m2} + .m1 post 40 40 +} -cleanup { + destroy .m1 +} -result {} +test menu-3.51 {MenuWidgetCmd procedure, "postcascade" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 postcascade +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 postcascade index"} +test menu-3.52 {MenuWidgetCmd procedure, "postcascade" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 postcascade foo +} -cleanup { + destroy .m1 +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.53 {MenuWidgetCmd procedure, "postcascade" option} -constraints { + nonUnixUserInteraction +} -setup { + destroy .m1 .m2 +} -body { menu .m1 .m1 add command -label "menu-3.56 - hit Escape" menu .m2 .m1 post 40 40 .m1 add cascade -menu .m2 - list [catch {.m1 postcascade 1} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} { - catch {destroy .m1} - catch {destroy .m2} + .m1 postcascade 1 +} -cleanup { + destroy .m1 .m2 +} -result {} +test menu-3.54 {MenuWidgetCmd procedure, "postcascade" option} -setup { + destroy .m1 .m2 +} -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 -label "menu-3.57 - hit Escape" .m1 postcascade 1 - list [catch {.m1 postcascade none} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-3.55 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 postcascade none +} -cleanup { + destroy .m1 .m2 +} -result {} +test menu-3.55 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 type} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 type index"} {}} -test menu-3.56 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 type index"} +test menu-3.56 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 type foo} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-3.57 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type foo +} -cleanup { + destroy .m1 +} -returnCodes error -result {bad menu entry index "foo"} +test menu-3.57 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 type 1} msg] $msg [destroy .m1] -} {0 command {}} -test menu-3.58 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type 1 +} -cleanup { + destroy .m1 +} -result {command} +test menu-3.58 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator - list [catch {.m1 type 1} msg] $msg [destroy .m1] -} {0 separator {}} -test menu-3.59 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type 1 +} -cleanup { + destroy .m1 +} -result {separator} +test menu-3.59 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label "test" - list [catch {.m1 type 1} msg] $msg [destroy .m1] -} {0 checkbutton {}} -test menu-3.60 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type 1 +} -cleanup { + destroy .m1 +} -result {checkbutton} +test menu-3.60 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label "test" - list [catch {.m1 type 1} msg] $msg [destroy .m1] -} {0 radiobutton {}} -test menu-3.61 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type 1 +} -cleanup { + destroy .m1 +} -result {radiobutton} +test menu-3.61 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label "test" - list [catch {.m1 type 1} msg] $msg [destroy .m1] -} {0 cascade {}} -test menu-3.62 {MenuWidgetCmd procedure, "type" option} { - catch {destroy .m1} + .m1 type 1 +} -cleanup { + destroy .m1 +} -result {cascade} +test menu-3.62 {MenuWidgetCmd procedure, "type" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 type 0} msg] $msg [destroy .m1] -} {0 tearoff {}} -test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} { - catch {destroy .m1} + .m1 type 0 +} -cleanup { + destroy .m1 +} -result {tearoff} +test menu-3.63 {MenuWidgetCmd procedure, "unpost" option} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 unpost foo} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 unpost"} {}} -test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} {nonUnixUserInteraction } { - catch {destroy .m1} + .m1 unpost foo +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 unpost"} +test menu-3.64 {MenuWidgetCmd procedure, "unpost" option} -constraints { + nonUnixUserInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "menu-3.68 - hit Escape" .m1 post 40 40 - list [catch {.m1 unpost} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 yposition} msg] $msg [destroy .m1] -} {1 {wrong # args: should be ".m1 yposition index"} {}} -test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 yposition 1}] [destroy .m1] -} {0 {}} -test menu-3.67 {MenuWidgetCmd procedure, bad option} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 foo} msg] $msg [destroy .m1] -} {1 {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} {}} -test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { + .m1 unpost +} -cleanup { + destroy .m1 +} -result {} +test menu-3.65 {MenuWidgetCmd procedure, "yposition" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 yposition +} -cleanup { + destroy .m1 +} -returnCodes error -result {wrong # args: should be ".m1 yposition index"} +test menu-3.66 {MenuWidgetCmd procedure, "yposition" option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 yposition 1 +} -cleanup { + destroy .m1 +} -result {1} +test menu-3.67 {MenuWidgetCmd procedure, bad option} -setup { + destroy .m1 +} -body { + menu .m1 + .m1 foo +} -cleanup { + destroy .m1 +} -returnCodes error -result {bad option "foo": must be activate, add, cget, clone, configure, delete, entrycget, entryconfigure, index, insert, invoke, post, postcascade, type, unpost, xposition, or yposition} +test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} -setup { + deleteWindows +} -body { set t .t set m1 .t.m1 set c1 .t.c1 @@ -922,12 +1800,12 @@ test menu-3.68 {MenuWidgetCmd procedure, fix for bug#508988} { $t configure -menu $m1 $m1 entryconfigure 1 -menu $c2 -label c2 $t configure -menu "" - set l [list [winfo exists $c1] [winfo exists $c2]] - destroy $t; - set l; -} {1 1} + list [winfo exists $c1] [winfo exists $c2] +} -cleanup { + deleteWindows +} -result {1 1} test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup { - catch {destroy .m1} + destroy .m1 menu .m1 } -body { .m1 xposition @@ -935,7 +1813,7 @@ test menu-3.69 {MenuWidgetCmd procedure, "xposition" option} -setup { destroy .m1 } -returnCodes error -result {wrong # args: should be ".m1 xposition index"} test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup { - catch {destroy .m1} + destroy .m1 menu .m1 } -body { .m1 xposition 1 @@ -944,126 +1822,162 @@ test menu-3.70 {MenuWidgetCmd procedure, "xposition" option} -setup { destroy .m1 } -result {} -test menu-4.1 {TkInvokeMenu: disabled} { - catch {destroy .m1} + +test menu-4.1 {TkInvokeMenu: disabled} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off \ -state disabled - list [catch {.m1 invoke 1} msg] [destroy .m1] $foo -} {0 {} off} -test menu-4.2 {TkInvokeMenu: tearoff} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 invoke 0} msg] [destroy .m1] -} {0 {}} -test menu-4.3 {TkInvokeMenu: checkbutton -on} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $foo +} -cleanup { + destroy .m1 +} -result {0 off} +test menu-4.2 {TkInvokeMenu: tearoff} -setup { + destroy .m1 +} -body { + menu .m1 + catch {.m1 invoke 0} +} -cleanup { + deleteWindows +} -result {0} +test menu-4.3 {TkInvokeMenu: checkbutton -on} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off - list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 on 0 {} {}} -test menu-4.4 {TkInvokeMenu: checkbutton -off} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 \ + [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 on 0 {}} +test menu-4.4 {TkInvokeMenu: checkbutton -off} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -label "test" -variable foo -onvalue on -offvalue off .m1 invoke 1 - list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 off 0 {} {}} -test menu-4.5 {TkInvokeMenu: checkbutton array element} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 off 0 {}} +test menu-4.5 {TkInvokeMenu: checkbutton array element} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -label "test" -variable foo(1) -onvalue on - list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 on 0 {} {}} -test menu-4.6 {TkInvokeMenu: radiobutton} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $msg [catch {set foo(1)} msg2] $msg2 [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 on 0 {}} +test menu-4.6 {TkInvokeMenu: radiobutton} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add radiobutton -label "1" -variable foo -value one .m1 add radiobutton -label "2" -variable foo -value two .m1 add radiobutton -label "3" -variable foo -value three - list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 one 0 {} {}} -test menu-4.7 {TkInvokeMenu: radiobutton} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 one 0 {}} +test menu-4.7 {TkInvokeMenu: radiobutton} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add radiobutton -label "1" -variable foo -value one .m1 add radiobutton -label "2" -variable foo -value two .m1 add radiobutton -label "3" -variable foo -value three - list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 two 0 {} {}} -test menu-4.8 {TkInvokeMenu: radiobutton} { - catch {destroy .m1} + list [catch {.m1 invoke 2} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 two 0 {}} +test menu-4.8 {TkInvokeMenu: radiobutton} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add radiobutton -label "1" -variable foo -value one .m1 add radiobutton -label "2" -variable foo -value two .m1 add radiobutton -label "3" -variable foo -value three - list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 three 0 {} {}} -test menu-4.9 {TkInvokeMenu: radiobutton array element} { - catch {destroy .m1} + list [catch {.m1 invoke 3} msg] $msg [catch {set foo} msg2] $msg2 [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 three 0 {}} +test menu-4.9 {TkInvokeMenu: radiobutton array element} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add radiobutton -label "1" -variable foo(2) -value one .m1 add radiobutton -label "2" -variable foo(2) -value two .m1 add radiobutton -label "3" -variable foo(2) -value three - list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3 [destroy .m1] -} {0 {} 0 three 0 {} {}} -test menu-4.10 {TkInvokeMenu} { - catch {destroy .m1} - catch {unset menu_test} + list [catch {.m1 invoke 3} msg] $msg [catch {set foo(2)} msg2] $msg2 [catch {unset foo} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 {} 0 three 0 {}} +test menu-4.10 {TkInvokeMenu} -setup { + destroy .m1 +} -body { + catch {unset foo} menu .m1 .m1 add command -label "test" -command "set menu_test menu-4.8" - list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 [destroy .m1] -} {0 menu-4.8 0 menu-4.8 0 {} {}} -test menu-4.11 {TkInvokeMenu} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $msg [catch {set menu_test} msg2] $msg2 [catch {unset menu_test} msg3] $msg3 +} -cleanup { + destroy .m1 +} -result {0 menu-4.8 0 menu-4.8 0 {}} +test menu-4.11 {TkInvokeMenu} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label "test" -menu .m1.m2 - list [catch {.m1 invoke 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-4.12 {TkInvokeMenu} { - catch {destroy .m1} + list [catch {.m1 invoke 1} msg] $msg +} -cleanup { + destroy .m1 +} -result {0 {}} +test menu-4.12 {TkInvokeMenu} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -command ".m1 delete 1" - list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2 [destroy .m1] -} {0 {} 1 {bad menu entry index "test"} {}} + list [catch {.m1 invoke 1} msg] $msg [catch {.m1 type "test"} msg2] $msg2 +} -cleanup { + destroy .m1 +} -result {0 {} 1 {bad menu entry index "test"}} -test menu-5.1 {DestroyMenuInstance} { - catch {destroy .m1} +test menu-5.1 {DestroyMenuInstance} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-5.2 {DestroyMenuInstance - cascade menu} { - catch {destroy .m1} - catch {destroy .m2} + destroy .m1 +} -returnCodes ok +test menu-5.2 {DestroyMenuInstance - cascade menu} -setup { + destroy .m1 .m2 +} -body { menu .m1 .m1 add cascade -menu .m2 menu .m2 - list [catch {destroy .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-5.3 {DestroyMenuInstance - multiple cascade parents} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + destroy .m1 .m2 +} -returnCodes ok +test menu-5.3 {DestroyMenuInstance - multiple cascade parents} -setup { + destroy .m1 .m2 .m3 +} -body { menu .m1 .m1 add cascade -menu .m3 menu .m2 .m2 add cascade -menu .m3 menu .m3 - list [catch {destroy .m3} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-5.4 {DestroyMenuInstance - multiple cascade parents} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} + list [destroy .m3] [destroy .m1 .m2] +} -returnCodes ok -result {{} {}} +test menu-5.4 {DestroyMenuInstance - multiple cascade parents} -setup { + destroy .m1 .m2 .m3 .m4 +} -body { menu .m1 .m1 add cascade -menu .m4 menu .m2 @@ -1071,21 +1985,20 @@ test menu-5.4 {DestroyMenuInstance - multiple cascade parents} { menu .m3 .m3 add cascade -menu .m4 menu .m4 - list [catch {destroy .m4} msg] $msg [destroy .m1 .m2 .m3] -} {0 {} {}} -test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} { - catch {destroy .m1} - catch {destroy .m2} + list [destroy .m4] [destroy .m1 .m2 .m3] +} -returnCodes ok -result {{} {}} +test menu-5.5 {DestroyMenuInstance - cascades of cloned menus} -setup { + destroy .m1 .m2 +} -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 . configure -menu .m1 - list [catch {destroy .m2} msg] $msg [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1] -} {0 {} .m2 {} {}} -test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .t2} + list [destroy .m2] [.m1 entrycget 1 -menu] [. configure -menu ""] [destroy .m1] +} -returnCodes ok -result {{} .m2 {} {}} +test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m2 menu .m2 @@ -1093,190 +2006,190 @@ test menu-5.6 {DestroyMenuInstance - cascades of cloned menus} { toplevel .t2 wm geometry .t2 +0+0 .t2 configure -menu .m1 - list [catch {destroy .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1] -} {0 {} {} {}} -test menu-5.7 {DestroyMenuInstance - basic clones} { - catch {destroy .m1} + list [destroy .m2] [. configure -menu ""] [destroy .t2 .m1] +} -returnCodes ok -result {{} {} {}} +test menu-5.7 {DestroyMenuInstance - basic clones} -setup { + destroy .m1 +} -body { menu .m1 set tearoff [tk::TearOffMenu .m1] - list [catch {destroy $tearoff} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-5.8 {DestroyMenuInstance - multiple clones} { - catch {destroy .m1} + list [destroy $tearoff] [destroy .m1] +} -result {{} {}} +test menu-5.8 {DestroyMenuInstance - multiple clones} -setup { + destroy .m1 +} -body { menu .m1 set tearoff1 [tk::TearOffMenu .m1] set tearoff2 [tk::TearOffMenu .m1] - list [catch {destroy $tearoff1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-5.9 {DestroyMenuInstace - master menu} { - catch {destroy .m1} + list [destroy $tearoff1] [destroy .m1] +} -returnCodes ok -result {{} {}} +test menu-5.9 {DestroyMenuInstace - master menu} -setup { + destroy .m1 +} -body { menu .m1 tk::TearOffMenu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-5.10 {DestroyMenuInstance - freeing entries} { - catch {destroy .m1} + destroy .m1 +} -returnCodes ok +test menu-5.10 {DestroyMenuInstance - freeing entries} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "foo" - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-5.11 {DestroyMenuInstace - no entries} { - catch {destroy .m1} + destroy .m1 +} -returnCodes ok +test menu-5.11 {DestroyMenuInstace - no entries} -setup { + destroy .m1 +} -body { menu .m1 .m1 configure -tearoff 0 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-5.12 {DestroyMenuInstance - platform data} { - catch {destroy .m1} + destroy .m1 +} -returnCodes ok +test menu-5.12 {DestroyMenuInstance - platform data} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} { - catch {destroy .m1} - catch {destroy .m2} + destroy .m1 +} -returnCodes ok +test menu-5.13 {DestroyMenuInstance - clones when mismatched tearoffs} -setup { + destroy .m1 .m2 +} -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 set tearoff [tk::TearOffMenu .m1 40 40] list [destroy .m2] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test menu-6.1 {TkDestroyMenu} { - catch {destroy .m1} +test menu-6.1 {TkDestroyMenu} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-6.2 {TkDestroyMenu - reentrancy} { - catch {destroy .m1} - catch {destroy .m2} + destroy .m1 +} -returnCodes ok +test menu-6.2 {TkDestroyMenu - reentrancy} -setup { + destroy .m1 .m2 +} -body { menu .m1 bind .m1 <Destroy> {destroy .m1} menu .m2 bind .m2 <Destroy> {destroy .m2} - list [catch {destroy .m1} msg] $msg [destroy .m2] -} {0 {} {}} -test menu-6.3 {TkDestroyMenu - reentrancy} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [destroy .m1] [destroy .m2] +} -returnCodes ok -result {{} {}} +test menu-6.3 {TkDestroyMenu - reentrancy} -setup { + destroy .m1 .m2 .m3 +} -body { menu .m1 bind .m1 <Destroy> {destroy .m2} .m1 clone .m2 .m1 clone .m3 - list [catch {destroy .m1} msg] $msg [winfo exists .m2] -} {0 {} 0} -test menu-6.4 {TkDestroyMenu - reentrancy - clones} { - catch {destroy .m1} - catch {destroy .m2} + list [destroy .m1] [winfo exists .m2] +} -returnCodes ok -result {{} 0} +test menu-6.4 {TkDestroyMenu - reentrancy - clones} -setup { + destroy .m1 .m2 +} -body { menu .m1 .m1 clone .m2 .m1 clone .m1.m3 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-6.5 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} + destroy .m1 +} -cleanup { + deleteWindows +} -returnCodes ok +test menu-6.5 {TkDestroyMenu} -setup { + destroy .m1 .m2 +} -body { menu .m1 .m1 clone .m2 destroy .m1 winfo exists .m2 -} {0} -test menu-6.6 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} +} -result {0} +test menu-6.6 {TkDestroyMenu} -setup { + destroy .m1 .m2 +} -body { menu .m1 .m1 clone .m2 tearoff - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-6.7 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} + destroy .m1 +} -result {} +test menu-6.7 {TkDestroyMenu} -setup { + destroy .m1 .m2 +} -body { menu .m1 .m1 clone .m2 destroy .m2 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-6.8 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + destroy .m1 +} -returnCodes ok -result {} +test menu-6.8 {TkDestroyMenu} -setup { + destroy .m1 .m2 .m3 +} -body { menu .m1 .m1 clone .m2 .m1 clone .m3 destroy .m1 list [winfo exists .m2] [winfo exists .m3] -} {0 0} -test menu-6.9 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} +} -result {0 0} +test menu-6.9 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m1 clone .m3 - list [catch {destroy .m2} msg] $msg [catch {destroy .m3} msg2] $msg2 [catch {destroy .m1} msg3] $msg3 -} {0 {} 0 {} 0 {}} -test menu-6.10 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [destroy .m2] [destroy .m3] [destroy .m1] +} -returnCodes ok -result {{} {} {}} +test menu-6.10 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m1 clone .m3 - list [catch {destroy .m3} msg] $msg [catch {destroy .m1} msg2] $msg2 -} {0 {} 0 {}} -test menu-6.11 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} + list [destroy .m3] [destroy .m1] +} -returnCodes ok -result {{} {}} +test menu-6.11 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m1 clone .m3 .m1 clone .m4 - list [catch {destroy .m2} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 -} {0 {} 0 {}} -test menu-6.12 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} + list [destroy .m2] [destroy .m1] +} -returnCodes ok -result {{} {}} +test menu-6.12 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m1 clone .m3 .m1 clone .m4 - list [catch {destroy .m3} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 -} {0 {} 0 {}} -test menu-6.13 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} + list [destroy .m3] [destroy .m1] +} -returnCodes ok -result {{} {}} +test menu-6.13 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m1 clone .m3 .m1 clone .m4 - list [catch {destroy .m4} msg1] $msg1 [catch {destroy .m1} msg2] $msg2 -} {0 {} 0 {}} -test menu-6.14 {TkDestroyMenu} { - catch {destroy .m1} + list [destroy .m4] [destroy .m1] +} -returnCodes ok -result {{} {}} +test menu-6.14 {TkDestroyMenu} -setup { + destroy .m1 +} -body { menu .m1 . configure -menu .m1 - list [catch {destroy .m1} msg] $msg [. configure -menu ""] -} {0 {} {}} -test menu-6.15 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .t2} + list [destroy .m1] [. configure -menu ""] +} -returnCodes ok -result {{} {}} +test menu-6.15 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 toplevel .t2 wm geometry .t2 +0+0 . configure -menu .m1 .t2 configure -menu .m1 - list [catch {destroy .m1} msg] $msg [destroy .t2] [. configure -menu ""] -} {0 {} {} {}} -test menu-6.16 {TkDestroyMenu} { - catch {destroy .m1} - catch {destroy .t2} - catch {destroy .t3} + list [destroy .m1] [destroy .t2] [. configure -menu ""] +} -result {{} {} {}} +test menu-6.16 {TkDestroyMenu} -setup { + deleteWindows +} -body { menu .m1 toplevel .t2 wm geometry .t2 +0+0 @@ -1285,298 +2198,367 @@ test menu-6.16 {TkDestroyMenu} { . configure -menu .m1 .t2 configure -menu .m1 .t3 configure -menu .m1 - list [catch {destroy .m1} msg] $msg [destroy .t2] [destroy .t3] [. configure -menu ""] -} {0 {} {} {} {}} + list [destroy .m1] [destroy .t2] [destroy .t3] [. configure -menu ""] +} -result {{} {} {} {}} -test menu-7.1 {UnhookCascadeEntry} { - catch {destroy .m1} +test menu-7.1 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-7.2 {UnhookCascadeEntry} { - catch {destroy .m1} + destroy .m1 +} -returnCodes ok +test menu-7.2 {UnhookCascadeEntry} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -menu .m2 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-7.3 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} + destroy .m1 +} -returnCodes ok +test menu-7.3 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m2 add cascade -menu .cascade .m1 add cascade -menu .cascade - list [catch {destroy .m1} msg] $msg [destroy .m2] -} {0 {} {}} -test menu-7.4 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} + list [destroy .m1] [destroy .m2] +} -returnCodes ok -result {{} {}} +test menu-7.4 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m1 add cascade -menu .cascade .m2 add cascade -menu .cascade - list [catch {destroy .m1} msg] $msg [destroy .m2] -} {0 {} {}} -test menu-7.5 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [destroy .m1] [destroy .m2] +} -returnCodes ok -result {{} {}} +test menu-7.5 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 menu .m3 .m1 add cascade -menu .cascade .m2 add cascade -menu .cascade .m3 add cascade -menu .cascade - list [catch {destroy .m1} msg] $msg [destroy .m2 .m3] -} {0 {} {}} -test menu-7.6 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [destroy .m1] [destroy .m2 .m3] +} -returnCodes ok -result {{} {}} +test menu-7.6 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 menu .m3 .m1 add cascade -menu .cascade .m2 add cascade -menu .cascade .m3 add cascade -menu .cascade - list [catch {destroy .m2} msg] $msg [destroy .m1 .m3] -} {0 {} {}} -test menu-7.7 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [destroy .m2] [destroy .m1 .m3] +} -returnCodes ok -result {{} {}} +test menu-7.7 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 menu .m3 .m1 add cascade -menu .cascade .m2 add cascade -menu .cascade .m3 add cascade -menu .cascade - list [catch {destroy .m3} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-7.8 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} + list [destroy .m3] [destroy .m1 .m2] +} -returnCodes ok -result {{} {}} +test menu-7.8 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 - list [catch {destroy .m1} msg] $msg [destroy .m2] -} {0 {} {}} -test menu-7.9 {UnhookCascadeEntry} { - catch {destroy .m1} - catch {destroy .m2} + list [destroy .m1] [destroy .m2] +} -returnCodes ok -result {{} {}} +test menu-7.9 {UnhookCascadeEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 destroy .m1 - list [catch {destroy .m2} msg] $msg -} {0 {}} + destroy .m2 +} -returnCodes ok -test menu-8.1 {DestroyMenuEntry} { - catch {destroy .m1} - catch {destroy .m2} +test menu-8.1 {DestroyMenuEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m1 add cascade -menu .m2 - list [catch {.m1 delete 1} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-8.2 {DestroyMenuEntry} hasEarthPhoto { + list [.m1 delete 1] [destroy .m1 .m2] +} -result {{} {}} +test menu-8.2 {DestroyMenuEntry} -constraints hasEarthPhoto -setup { + deleteWindows catch {image delete image1a} - catch {destroy .m1} +} -body { image create photo image1a -file $earthPhotoFile menu .m1 .m1 add command -image image1a - list [catch {.m1 delete 1} msg] $msg [destroy .m1] [image delete image1a] -} {0 {} {} {}} -test menu-8.3 {DestroyMenuEntry} testImageType { - catch {eval image delete [image names]} - catch {destroy .m1} + list [.m1 delete 1] [destroy .m1] [image delete image1a] +} -result {{} {} {}} +test menu-8.3 {DestroyMenuEntry} -constraints testImageType -setup { + deleteWindows + imageCleanup +} -body { image create test image1 image create test image2 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 .m1 invoke 1 - list [catch {.m1 delete 1} msg] $msg [destroy .m1] [eval image delete [image names]] -} {0 {} {} {}} -test menu-8.4 {DestroyMenuEntry} { - catch {destroy .m1} + list [.m1 delete 1] [destroy .m1] +} -cleanup { + imageCleanup + deleteWindows +} -result {{} {}} +test menu-8.4 {DestroyMenuEntry} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -variable foo - list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-8.5 {DestroyMenuEntry} { - catch {destroy .m1} + list [.m1 delete 1] [destroy .m1] +} -result {{} {}} +test menu-8.5 {DestroyMenuEntry} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-8.6 {DestroyMenuEntry} { - catch {destroy .m1} + list [.m1 delete 1] [destroy .m1] +} -result {{} {}} +test menu-8.6 {DestroyMenuEntry} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" - list [catch {.m1 delete 1} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] -} {0 {} two {}} -test menu-8.7 {DestroyMenuEntry} { - catch {destroy .m1} - catch {destroy .m2} + list [.m1 delete 1] [.m1 entrycget 1 -label] [destroy .m1] +} -result {{} two {}} +test menu-8.7 {DestroyMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "one" .m1 clone .m2 tearoff - list [catch {.m2 delete 0} msg] $msg [destroy .m1] -} {0 {} {}} + list [.m2 delete 1] [destroy .m1] +} -result {{} {}} + # test menu-9 - Can only change when fonts change on system, which cannot # be done from tcl. - -test menu-9.1 {ConfigureMenu} { - catch {destroy .m1} +test menu-9.1 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1] -} {0 {} beep {}} -test menu-9.2 {ConfigureMenu} { - catch {destroy .m1} + list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] +} -cleanup { + deleteWindows +} -result {{} beep} +test menu-9.2 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 configure -tearoff 0} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] -} {0 {} test {}} -test menu-9.3 {ConfigureMenu} { - catch {destroy .m1} + list [.m1 configure -tearoff 0] [.m1 entrycget 1 -label] +} -cleanup { + deleteWindows +} -result {{} test} +test menu-9.3 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {.m1 configure -postcommand "beep"} msg] $msg [.m1 cget -postcommand] [destroy .m1] -} {0 {} beep {}} -test menu-9.4 {ConfigureMenu} { - catch {destroy .m1} + list [.m1 configure -postcommand "beep"] [.m1 cget -postcommand] +} -cleanup { + deleteWindows +} -result {{} beep} +test menu-9.4 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-9.5 {ConfigureMenu} { - catch {destroy .m1} + .m1 configure -fg red +} -cleanup { + deleteWindows +} -result {} +test menu-9.5 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "two" - list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-9.6 {ConfigureMenu} { - catch {destroy .m1} + .m1 configure -fg red +} -cleanup { + deleteWindows +} -result {} +test menu-9.6 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "two" .m1 add command -label "three" - list [catch {.m1 configure -fg red} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-9.7 {ConfigureMenu} { - catch {destroy .m1} - catch {destroy .m2} + .m1 configure -fg red +} -cleanup { + deleteWindows +} -result {} +test menu-9.7 {ConfigureMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 tearoff - list [catch {.m1 configure -fg red} msg] $msg [.m2 cget -fg] [destroy .m1] -} {0 {} red {}} -test menu-9.8 {ConfigureMenu} { - catch {destroy .m1} - catch {destroy .m2} + list [.m1 configure -fg red] [.m2 cget -fg] +} -cleanup { + deleteWindows +} -result {{} red} +test menu-9.8 {ConfigureMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 tearoff - list [catch {.m2 configure -fg red} msg] $msg [.m1 cget -fg] [destroy .m1] -} {0 {} red {}} -test menu-9.9 {ConfigureMenu} { - catch {destroy .m1} + list [.m2 configure -fg red] [.m1 cget -fg] +} -cleanup { + deleteWindows +} -result {{} red} +test menu-9.9 {ConfigureMenu} -setup { + destroy .m1 +} -body { menu .m1 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} + -test menu-10.1 {PostProcessEntry: array variable} { - catch {destroy .m1} +test menu-10.1 {PostProcessEntry: array variable} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 set foo(1) on .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" - list [catch {set foo(1)} msg] $msg [destroy .m1] -} {0 on {}} -test menu-10.2 {PostProcessEntry: array variable} { - catch {destroy .m1} + set foo(1) +} -cleanup { + deleteWindows +} -result {on} +test menu-10.2 {PostProcessEntry: array variable} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -variable foo(1) -onvalue on -offvalue off -label "Nonsense" - list [catch {set foo(1)} msg] $msg [destroy .m1] -} {0 off {}} + set foo(1) +} -cleanup { + deleteWindows +} -result {off} -test menu-11.1 {ConfigureMenuEntry} { - catch {destroy .m1} + +test menu-11.1 {ConfigureMenuEntry} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -onvalue on -offvalue off -label "Nonsense" - list [catch {.m1 entryconfigure 1 -variable bar} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] -} {0 {} bar {}} -test menu-11.2 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 entryconfigure 1 -variable bar] [.m1 entrycget 1 -variable] +} -cleanup { + deleteWindows +} -result {{} bar} +test menu-11.2 {ConfigureMenuEntry} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 entryconfigure 1 -label ""} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] -} {0 {} {} {}} -test menu-11.3 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 entryconfigure 1 -label ""] [.m1 entrycget 1 -label] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-11.3 {ConfigureMenuEntry} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command - list [catch {.m1 entryconfigure 1 -label "test"} cmd] $cmd [.m1 entrycget 1 -label] [destroy .m1] -} {0 {} test {}} -test menu-11.4 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label] +} -cleanup { + deleteWindows +} -result {{} test} +test menu-11.4 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command - list [catch {.m1 entryconfigure 1 -accel "S"} msg] $msg [.m1 entrycget 1 -accel] [destroy .m1] -} {0 {} S {}} -test menu-11.5 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 entryconfigure 1 -accel "S"] [.m1 entrycget 1 -accel] +} -cleanup { + deleteWindows +} -result {{} S} +test menu-11.5 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command - list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [.m1 entrycget 1 -label] [destroy .m1] -} {0 {} test {}} -test menu-11.6 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 entryconfigure 1 -label "test"] [.m1 entrycget 1 -label] +} -cleanup { + deleteWindows +} -result {{} test} +test menu-11.6 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command - list [catch {.m1 entryconfigure 1 -label "test"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-11.7 {ConfigureMenuEntry} { - catch {destroy .m1} - catch {destroy .m2} + .m1 entryconfigure 1 -label "test" +} -cleanup { + deleteWindows +} -result {} +test menu-11.7 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m2 menu .m1 .m1 add cascade - list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-11.8 {ConfigureMenuEntry} { - catch {destroy .m1} + .m1 entryconfigure 1 -label "test" -menu .m2 +} -cleanup { + deleteWindows +} -result {} +test menu-11.8 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade - list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-11.9 {ConfigureMenuEntry} { - catch {destroy .m1} + .m1 entryconfigure 1 -label "test" -menu .m2 +} -cleanup { + deleteWindows +} -result {} +test menu-11.9 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m3 - list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-11.10 {ConfigureMenuEntry} { - catch {destroy .m1} + .m1 entryconfigure 1 -label "test" -menu .m2 +} -cleanup { + deleteWindows +} -result {} +test menu-11.10 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade - list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-11.11 {ConfigureMenuEntry} { - catch {destroy .m1} + .m1 entryconfigure 1 -label "test" -menu .m2 +} -cleanup { + deleteWindows +} -result {} +test menu-11.11 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m2 - list [catch {.m1 entryconfigure 1 -label "test" -menu .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-11.12 {ConfigureMenuEntry} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} - catch {destroy .m5} + .m1 entryconfigure 1 -label "test" -menu .m2 +} -cleanup { + deleteWindows +} -result {} +test menu-11.12 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m2 add cascade -menu .m1 @@ -1586,13 +2568,13 @@ test menu-11.12 {ConfigureMenuEntry} { .m4 add cascade -menu .m1 menu .m5 .m5 add cascade - list [catch {.m5 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4 .m5] -} {0 {} {}} -test menu-11.13 {ConfigureMenuEntry} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} + .m5 entryconfigure 1 -label "test" -menu .m1 +} -cleanup { + deleteWindows +} -result {} +test menu-11.13 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 menu .m2 .m2 add cascade -menu .m1 @@ -1600,360 +2582,489 @@ test menu-11.13 {ConfigureMenuEntry} { .m3 add cascade -menu .m1 menu .m4 .m4 add cascade -menu .m1 - list [catch {.m3 entryconfigure 1 -label "test" -menu .m1} msg] $msg [destroy .m1 .m2 .m3 .m4] -} {0 {} {}} -test menu-11.14 {ConfigureMenuEntry} { - catch {destroy .m1} + .m3 entryconfigure 1 -label "test" -menu .m1 +} -cleanup { + deleteWindows +} -result {} +test menu-11.14 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add checkbutton - list [catch {.m1 entryconfigure 1 -variable "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] -} {0 {} test {}} -test menu-11.15 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 entryconfigure 1 -variable "test"] [.m1 entrycget 1 -variable] +} -cleanup { + deleteWindows +} -result {{} test} +test menu-11.15 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 add checkbutton -label "test"} msg] $msg [.m1 entrycget 1 -variable] [destroy .m1] -} {0 {} test {}} -test menu-11.16 {ConfigureMenuEntry} { - catch {destroy .m1} + list [.m1 add checkbutton -label "test"] [.m1 entrycget 1 -variable] +} -cleanup { + deleteWindows +} -result {{} test} +test menu-11.16 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 add radiobutton -label "test"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-11.17 {ConfigureMenuEntry} { - catch {destroy .m1} + .m1 add radiobutton -label "test" +} -cleanup { + deleteWindows +} -result {} +test menu-11.17 {ConfigureMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add checkbutton - list [catch {.m1 entryconfigure 1 -onvalue "test"} msg] $msg [.m1 entrycget 1 -onvalue] [destroy .m1] -} {0 {} test {}} -test menu-11.18 {ConfigureMenuEntry} testImageType { - catch {destroy .m1} - catch {image delete image1} + list [.m1 entryconfigure 1 -onvalue "test"] [.m1 entrycget 1 -onvalue] +} -cleanup { + deleteWindows +} -result {{} test} +test menu-11.18 {ConfigureMenuEntry} -constraints testImageType -setup { + deleteWindows + imageCleanup +} -body { menu .m1 .m1 add command image create test image1 - list [catch {.m1 entryconfigure 1 -image image1} msg] $msg [destroy .m1] [image delete image1] -} {0 {} {} {}} -test menu-11.19 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { - catch {destroy .m1} - catch {image delete image1} - catch {image delete image2} + .m1 entryconfigure 1 -image image1 +} -cleanup { + deleteWindows + imageCleanup +} -result {} +test menu-11.19 {ConfigureMenuEntry} -constraints { + testImageType hasEarthPhoto +} -setup { + deleteWindows + imageCleanup +} -body { image create test image1 image create photo image2 -file $earthPhotoFile menu .m1 .m1 add command -image image1 - list [catch {.m1 entryconfigure 1 -image image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] -} {0 {} {} {} {}} -test menu-11.20 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { - catch {destroy .m1} - catch {image delete image1} - catch {image delete image2} + .m1 entryconfigure 1 -image image2 +} -cleanup { + deleteWindows + imageCleanup +} -result {} +test menu-11.20 {ConfigureMenuEntry} -constraints { + testImageType hasEarthPhoto +} -setup { + deleteWindows + imageCleanup +} -body { image create photo image1 -file $earthPhotoFile image create test image2 menu .m1 .m1 add checkbutton -image image1 - list [catch {.m1 entryconfigure 1 -selectimage image2} msg] $msg [destroy .m1] [image delete image1] [image delete image2] -} {0 {} {} {} {}} -test menu-11.21 {ConfigureMenuEntry} {testImageType hasEarthPhoto} { - catch {destroy .m1} - catch {image delete image1} - catch {image delete image2} - catch {image delete image3} + .m1 entryconfigure 1 -selectimage image2 +} -cleanup { + deleteWindows + imageCleanup +} -result {} +test menu-11.21 {ConfigureMenuEntry} -constraints { + testImageType hasEarthPhoto +} -setup { + deleteWindows + imageCleanup +} -body { image create photo image1 -file $earthPhotoFile image create test image2 image create test image3 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 - list [catch {.m1 entryconfigure 1 -selectimage image3} msg] $msg [destroy .m1] [image delete image1] [image delete image2] [image delete image3] -} {0 {} {} {} {} {}} + .m1 entryconfigure 1 -selectimage image3 +} -cleanup { + deleteWindows + imageCleanup +} -result {} -test menu-12.1 {ConfigureMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + +test menu-12.1 {ConfigureMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m2 configure -tearoff 0 .m1 clone .m3 .m1 add command -label "test" .m1 add command -label "test2" - list [list [catch {.m1 entryconfigure 1 -gork "foo"} msg] $msg] [destroy .m1] -} {{1 {unknown option "-gork"}} {}} -test menu-12.2 {ConfigureMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} - catch {destroy .m4} + .m1 entryconfigure 1 -gork "foo" +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-gork"} +test menu-12.2 {ConfigureMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 menu .m3 .m1 add cascade -menu .m3 menu .m4 - list [catch {.m1 entryconfigure 1 -menu .m4} msg] $msg [destroy .m1] [destroy .m3] [destroy .m4] -} {0 {} {} {} {}} -test menu-12.3 {ConfigureMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} + .m1 entryconfigure 1 -menu .m4 +} -cleanup { + deleteWindows +} -result {} +test menu-12.3 {ConfigureMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m1 add cascade -label dummy - list [catch {.m1 entryconfigure dummy -menu .m3} msg] $msg [destroy .m1] -} {0 {} {}} - -test menu-12.4 {ConfigureMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} + .m1 entryconfigure dummy -menu .m3 +} -cleanup { + deleteWindows +} -result {} +test menu-12.4 {ConfigureMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label File -menu .m1.foo menu .m1.foo .m1.foo add command -label bar .m1 clone .m2 - list [catch {.m1 entryconfigure File -state disabled} msg1] $msg1 [destroy .m1] -} {0 {} {}} + .m1 entryconfigure File -state disabled +} -cleanup { + deleteWindows +} -result {} -test menu-13.1 {TkGetMenuIndex} { - catch {destroy .m1} + +test menu-13.1 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "active" .m1 add command -label "test2" .m1 add command -label "test3" .m1 activate 2 - list [catch {.m1 entrycget active -label} msg] $msg [destroy .m1] -} {0 test2 {}} -test menu-13.2 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget active -label +} -cleanup { + deleteWindows +} -result {test2} +test menu-13.2 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "last" .m1 add command -label "test2" .m1 add command -label "test3" .m1 activate 2 - list [catch {.m1 entrycget last -label} msg] $msg [destroy .m1] -} {0 test3 {}} -test menu-13.3 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget last -label +} -cleanup { + deleteWindows +} -result {test3} +test menu-13.3 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "last" .m1 add command -label "test2" .m1 add command -label "test3" .m1 activate 2 - list [catch {.m1 entrycget end -label} msg] $msg [destroy .m1] -} {0 test3 {}} -test menu-13.4 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget end -label +} -cleanup { + deleteWindows +} -result {test3} +test menu-13.4 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 insert last command -label "test2"} msg] $msg [.m1 entrycget last -label] [destroy .m1] -} {0 {} test2 {}} -test menu-13.5 {TkGetMenuIndex} { - catch {destroy .m1} + list [.m1 insert last command -label "test2"] [.m1 entrycget last -label] +} -cleanup { + deleteWindows +} -result {{} test2} +test menu-13.5 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 insert end command -label "test2"} msg] $msg [.m1 entrycget end -label] [destroy .m1] -} {0 {} test2 {}} -test menu-13.6 {TkGetMenuIndex} { - catch {destroy .m1} + list [.m1 insert end command -label "test2"] [.m1 entrycget end -label] +} -cleanup { + deleteWindows +} -result {{} test2} +test menu-13.6 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "active" .m1 add command -label "test2" .m1 add command -label "test3" .m1 activate 2 - list [catch {.m1 entrycget none -label} msg] $msg [destroy .m1] -} {0 {} {}} + .m1 entrycget none -label +} -cleanup { + deleteWindows +} -result {} #test menu-13.7 - Need to add @test here. -test menu-13.7 {TkGetMenuIndex} { - catch {destroy .m1} +test menu-13.7 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "active" .m1 add command -label "test2" .m1 add command -label "test3" - list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] -} {0 active {}} -test menu-13.8 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget 1 -label +} -cleanup { + deleteWindows +} -result {active} +test menu-13.8 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "active" - list [catch {.m1 entrycget -1 -label} msg] $msg [destroy .m1] -} {1 {bad menu entry index "-1"} {}} -test menu-13.9 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget -1 -label +} -returnCodes error -result {bad menu entry index "-1"} +test menu-13.9 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" - list [catch {.m1 entrycget 999 -label} msg] $msg [destroy .m1] -} {0 test2 {}} -test menu-13.10 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget 999 -label +} -cleanup { + deleteWindows +} -result {test2} +test menu-13.10 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 insert 999 command -label "test" - list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] -} {0 test {}} -test menu-13.11 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget 1 -label +} -cleanup { + deleteWindows +} -result {test} +test menu-13.11 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "1test" - list [catch {.m1 entrycget 1test -label} msg] $msg [destroy .m1] -} {0 1test {}} -test menu-13.12 {TkGetMenuIndex} { - catch {destroy .m1} + .m1 entrycget 1test -label +} -cleanup { + deleteWindows +} -result {1test} +test menu-13.12 {TkGetMenuIndex} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" -command "beep" .m1 add command -label "test3" - list [catch {.m1 entrycget test2 -command} msg] $msg [destroy .m1] -} {0 beep {}} + .m1 entrycget test2 -command +} -cleanup { + deleteWindows +} -result {beep} -test menu-14.1 {MenuCmdDeletedProc} { - catch {destroy .m1} +test menu-14.1 {MenuCmdDeletedProc} -setup { + deleteWindows +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-14.2 {MenuCmdDeletedProc} { - catch {destroy .m1} + destroy .m1 +} -cleanup { + deleteWindows +} -returnCodes ok +test menu-14.2 {MenuCmdDeletedProc} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 - list [catch {destroy .m1} msg] $msg -} {0 {}} + destroy .m1 +} -cleanup { + deleteWindows +} -returnCodes ok -test menu-15.1 {MenuNewEntry} { - catch {destroy .m1} +test menu-15.1 {MenuNewEntry} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-15.2 {MenuNewEntry} { - catch {destroy .m1} + .m1 add command -label "test" +} -cleanup { + deleteWindows +} -result {} +test menu-15.2 {MenuNewEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test3" - list [catch {.m1 insert 2 command -label "test2"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-15.3 {MenuNewEntry} { - catch {destroy .m1} + .m1 insert 2 command -label "test2" +} -cleanup { + deleteWindows +} -result {} +test menu-15.3 {MenuNewEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 add command -label "test2"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-15.4 {MenuNewEntry} { - catch {destroy .m1} + .m1 add command -label "test2" +} -cleanup { + deleteWindows +} -result {} +test menu-15.4 {MenuNewEntry} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 add command -label "test"} msg] $msg [destroy .m1] -} {0 {} {}} + .m1 add command -label "test" +} -cleanup { + deleteWindows +} -result {} -test menu-16.1 {MenuAddOrInsert} { - catch {destroy .m1} +test menu-16.1 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 insert foo command -label "test"} msg] $msg [destroy .m1] -} {1 {bad menu entry index "foo"} {}} -test menu-16.2 {MenuAddOrInsert} { - catch {destroy .m1} + .m1 insert foo command -label "test" +} -returnCodes error -result {bad menu entry index "foo"} +test menu-16.2 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 insert test command -label "foo"} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.3 {MenuAddOrInsert} { - catch {destroy .m1} + .m1 insert test command -label "foo" +} -cleanup { + deleteWindows +} -result {} +test menu-16.3 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 insert -1 command -label "test"} msg] $msg [destroy .m1] -} {1 {bad menu entry index "-1"} {}} -test menu-16.4 {MenuAddOrInsert} { - catch {destroy .m1} + .m1 insert -1 command -label "test" +} -returnCodes error -result {bad menu entry index "-1"} +test menu-16.4 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 insert 0 command -label "test2" - list [catch {.m1 entrycget 1 -label} msg] $msg [destroy .m1] -} {0 test2 {}} -test menu-16.5 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add cascade} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.6 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add checkbutton} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.7 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.8 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add radiobutton} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.9 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add separator} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.10 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add blork} msg] $msg [destroy .m1] -} {1 {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} {}} -test menu-16.11 {MenuAddOrInsert} { - catch {destroy .m1} - menu .m1 - list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-16.12 {MenuAddOrInsert} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + .m1 entrycget 1 -label +} -cleanup { + deleteWindows +} -result {test2} +test menu-16.5 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add cascade +} -cleanup { + deleteWindows +} -result {} +test menu-16.6 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add checkbutton +} -cleanup { + deleteWindows +} -result {} +test menu-16.7 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command +} -cleanup { + deleteWindows +} -result {} +test menu-16.8 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add radiobutton +} -cleanup { + deleteWindows +} -result {} +test menu-16.9 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add separator +} -cleanup { + deleteWindows +} -result {} +test menu-16.10 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add blork +} -returnCodes error -result {bad menu entry type "blork": must be cascade, checkbutton, command, radiobutton, or separator} +test menu-16.11 {MenuAddOrInsert} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command +} -cleanup { + deleteWindows +} -result {} +test menu-16.12 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m2 clone .m3 - list [catch {.m2 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m3 entrycget 1 -label} msg3] $msg3 [destroy .m1] -} {0 {} 0 test 0 test {}} -test menu-16.13 {MenuAddOrInsert} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [.m2 add command -label "test"] [.m1 entrycget 1 -label] [.m3 entrycget 1 -label] +} -cleanup { + deleteWindows +} -result {{} test test} +test menu-16.13 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 .m2 clone .m3 - list [catch {.m3 add command -label "test"} msg1] $msg1 [catch {.m1 entrycget 1 -label} msg2] $msg2 [catch {.m2 entrycget 1 -label} msg3] $msg3 [destroy .m1] -} {0 {} 0 test 0 test {}} -test menu-16.14 {MenuAddOrInsert} { - catch {destroy .m1} + list [.m3 add command -label "test"] [.m1 entrycget 1 -label] [.m2 entrycget 1 -label] +} -cleanup { + deleteWindows +} -result {{} test test} +test menu-16.14 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 add command -blork} msg] $msg [destroy .m1] -} {1 {unknown option "-blork"} {}} -test menu-16.15 {MenuAddOrInsert} { - catch {destroy .m1} - catch {destroy .container} + .m1 add command -blork +} -returnCodes error -result {unknown option "-blork"} +test menu-16.15 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "File" menu .container . configure -menu .container - list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .container .m1] -} {0 {} {} {}} -test menu-16.16 {MenuAddOrInsert} { - catch {destroy .m1} - catch {destroy .m2} + list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-16.16 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 menu .m2 set tearoff [tk::TearOffMenu .m2] - list [catch {.m2 add cascade -menu .m1} msg] $msg [$tearoff unpost] [catch {destroy .m1} msg2] $msg2 [catch {destroy .m2} msg3] $msg3 -} {0 {} {} 0 {} 0 {}} -test menu-16.17 {MenuAddOrInsert} { - catch {destroy .m1} - catch {destroy .container} + list [.m2 add cascade -menu .m1] [$tearoff unpost] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-16.17 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 menu .container . configure -menu .container set tearoff [tk::TearOffMenu .container] - list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] -} {0 {} {} {}} -test menu-16.18 {MenuAddOrInsert} { - catch {destroy .m1} - catch {destroy .container} + list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-16.18 {MenuAddOrInsert} -setup { + deleteWindows +} -body { menu .m1 menu .container .container add cascade -menu .m1 . configure -menu .container - list [catch {.container add cascade -label "File" -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .container] -} {0 {} {} {}} -test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { - catch {destroy .menubar} + list [.container add cascade -label "File" -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} -setup { + deleteWindows +} -body { menu .menubar menu .menubar.test -tearoff 0 .menubar add cascade -label Test -underline 0 -menu .menubar.test @@ -1961,198 +3072,270 @@ test menu-16.19 {MenuAddOrInsert - Insert a cascade deep into the tree} { .menubar.test.cascade add command -label SubItem -command "puts SubItemSelected" . configure -menu .menubar list [catch {.menubar.test add cascade -label SubMenu \ - -menu .menubar.test.cascade} msg] \ - [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \ - [. configure -menu ""] [destroy .menubar] -} {0 .#menubar.#menubar#test.#menubar#test#cascade {} {}} + -menu .menubar.test.cascade}] \ + [info commands .\#menubar.\#menubar\#test.\#menubar\#test\#cascade] \ + [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {0 .#menubar.#menubar#test.#menubar#test#cascade {}} -test menu-17.1 {MenuVarProc} { - catch {destroy .m1} + +test menu-17.1 {MenuVarProc} -setup { + deleteWindows +} -body { catch {unset foo} menu .m1 set foo "hello" - list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [catch {unset foo} msg2] $msg2 [destroy .m1] -} {0 {} 0 {} {}} + list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ + [unset foo] +} -cleanup { + deleteWindows +} -result {{} {}} # menu-17.2 - Don't know how to generate the flags in the if -test menu-17.2 {MenuVarProc} { - catch {destroy .m1} +test menu-17.2 {MenuVarProc} -setup { + deleteWindows +} -body { catch {unset foo} menu .m1 - list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo ""] [destroy .m1] -} {0 {} {} {}} -test menu-17.3 {MenuVarProc} { - catch {destroy .m1} + list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ + [set foo ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-17.3 {MenuVarProc} -setup { + deleteWindows +} -body { catch {unset foo} menu .m1 set foo "hello" - list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 -} {0 {} hello {} 0 {}} -test menu-17.4 {MenuVarProc} { - catch {destroy .m1} + list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ + [set foo "hello"] [unset foo] +} -cleanup { + deleteWindows +} -result {{} hello {}} +test menu-17.4 {MenuVarProc} -setup { + deleteWindows +} -body { menu .m1 set foo "goodbye" - list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "hello"] [destroy .m1] [catch {unset foo} msg2] $msg2 -} {0 {} hello {} 0 {}} -test menu-17.5 {MenuVarProc} { - catch {destroy .m1} + list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ + [set foo "hello"] [unset foo] +} -cleanup { + deleteWindows +} -result {{} hello {}} +test menu-17.5 {MenuVarProc} -setup { + deleteWindows +} -body { menu .m1 set foo "hello" - list [catch {.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye} msg] $msg [set foo "goodbye"] [destroy .m1] [catch {unset foo} msg2] $msg2 -} {0 {} goodbye {} 0 {}} + list [.m1 add checkbutton -variable foo -onvalue hello -offvalue goodbye] \ + [set foo "goodbye"] [unset foo] +} -cleanup { + deleteWindows +} -result {{} goodbye {}} + -test menu-18.1 {TkActivateMenuEntry} { - catch {destroy .m1} +test menu-18.1 {TkActivateMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 activate 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-18.2 {TkActivateMenuEntry} { - catch {destroy .m1} + .m1 activate 1 +} -cleanup { + deleteWindows +} -result {} +test menu-18.2 {TkActivateMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" - list [catch {.m1 activate 0} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-18.3 {TkActivateMenuEntry} { - catch {destroy .m1} + .m1 activate 0 +} -cleanup { + deleteWindows +} -result {} +test menu-18.3 {TkActivateMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" .m1 activate 1 - list [catch {.m1 activate 2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-18.4 {TkActivateMenuEntry} { - catch {destroy .m1} + .m1 activate 2 +} -cleanup { + deleteWindows +} -result {} +test menu-18.4 {TkActivateMenuEntry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test2" .m1 activate 1 - list [catch {.m1 activate 1} msg] $msg [destroy .m1] -} {0 {} {}} + .m1 activate 1 +} -cleanup { + deleteWindows +} -result {} -test menu-19.1 {TkPostCommand} {nonUnixUserInteraction } { - catch {destroy .m1} + +test menu-19.1 {TkPostCommand} -constraints nonUnixUserInteraction -setup { + deleteWindows +} -body { menu .m1 -postcommand "set menu_test menu-19.1" .m1 add command -label "menu-19.1 - hit Escape" - list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [set menu_test] [destroy .m1] -} {0 menu-19.1 {} menu-19.1 {}} -test menu-19.2 {TkPostCommand} {nonUnixUserInteraction } { - catch {destroy .m1} + list [.m1 post 40 40] [.m1 unpost] [set menu_test] +} -cleanup { + deleteWindows +} -result {menu-19.1 {} menu-19.1} +test menu-19.2 {TkPostCommand} -constraints nonUnixUserInteraction -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "menu-19.2 - hit Escape" - list [catch {.m1 post 40 40} msg] $msg [.m1 unpost] [destroy .m1] -} {0 {} {} {}} - -test menu-20.1 {CloneMenu} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2} msg1] $msg1 [destroy .m1] -} {0 {} {}} -test menu-20.2 {CloneMenu} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2 normal} msg1] $msg1 [destroy .m1] -} {0 {} {}} -test menu-20.3 {CloneMenu} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2 tearoff} msg1] $msg1 [destroy .m1] -} {0 {} {}} -test menu-20.4 {CloneMenu} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2 menubar} msg1] $msg1 [destroy .m1] -} {0 {} {}} -test menu-20.5 {CloneMenu} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2 foo} msg1] $msg1 [destroy .m1] -} {1 {bad menu type "foo": must be normal, tearoff, or menubar} {}} -test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [.m1 post 40 40] [.m1 unpost] +} -cleanup { + deleteWindows +} -result {{} {}} + +test menu-20.1 {CloneMenu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 clone .m2] +} -cleanup { + deleteWindows +} -result {} +test menu-20.2 {CloneMenu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 clone .m2 normal + deleteWindows +} -result {} +test menu-20.3 {CloneMenu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 clone .m2 tearoff +} -cleanup { + deleteWindows +} -result {} +test menu-20.4 {CloneMenu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 clone .m2 menubar +} -cleanup { + deleteWindows +} -result {} +test menu-20.5 {CloneMenu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 clone .m2 foo +} -returnCodes error -result {bad menu type "foo": must be normal, tearoff, or menubar} +test menu-20.6 {CloneMenu - hooking up bookeeping ptrs} -setup { + deleteWindows +} -body { menu .m1 .m1 clone .m2 - list [catch {.m1 clone .m3} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-20.8 {CloneMenu - cascade entries} { - catch {destroy .m1} - catch {destroy .foo} +} -cleanup { + deleteWindows +} -result {} +test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} -setup { + deleteWindows +} -body { + menu .m1 + .m1 clone .m2 + .m1 clone .m3 +} -cleanup { + deleteWindows +} -result {} +test menu-20.8 {CloneMenu - cascade entries} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m2 - list [catch {.m1 clone .foo} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-20.9 {CloneMenu - cascades entries} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .foo} + .m1 clone .foo +} -cleanup { + deleteWindows +} -result {} +test menu-20.9 {CloneMenu - cascades entries} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m2 menu .m2 - list [catch {.m1 clone .foo} msg] $msg [destroy .m1 .m2] -} {0 {} {}} -test menu-20.10 {CloneMenu - tearoff fields} { - catch {destroy .m1} - catch {destroy .m2} - menu .m1 - list [catch {.m1 clone .m2 normal} msg1] $msg1 [catch {.m2 cget -tearoff} msg2] $msg2 [destroy .m1] -} {0 {} 0 1 {}} -test menu-20.11 {CloneMenu} { - catch {destroy .m1} - catch {destroy .m2} + .m1 clone .foo +} -cleanup { + deleteWindows +} -result {} +test menu-20.10 {CloneMenu - tearoff fields} -setup { + deleteWindows +} -body { + menu .m1 + list [.m1 clone .m2 normal] [.m2 cget -tearoff] +} -cleanup { + deleteWindows +} -result {{} 1} +test menu-20.11 {CloneMenu} -setup { + deleteWindows +} -body { menu .m1 menu .m2 - list [catch {.m1 clone .m2} msg] $msg [destroy .m1 .m2] -} {1 {window name "m2" already exists in parent} {}} + .m1 clone .m2 +} -returnCodes error -result {window name "m2" already exists in parent} -test menu-21.1 {MenuDoYPosition} { - catch {destroy .m1} +test menu-21.1 {MenuDoYPosition} -setup { + deleteWindows +} -body { menu .m1 - list [catch {.m1 yposition glorp} msg] $msg [destroy .m1] -} {1 {bad menu entry index "glorp"} {}} -test menu-21.2 {MenuDoYPosition} { - catch {destroy .m1} + .m1 yposition glorp +} -returnCodes error -result {bad menu entry index "glorp"} +test menu-21.2 {MenuDoYPosition} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "Test" - list [catch {.m1 yposition 1}] [destroy .m1] -} {0 {}} + .m1 yposition 1 +} -cleanup { + deleteWindows +} -returnCodes ok -match glob -result {*} -test menu-22.1 {GetIndexFromCoords} { - catch {destroy .m1} +test menu-22.1 {GetIndexFromCoords} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 - list [catch {.m1 index @5} msg] $msg [destroy .m1] -} {0 0 {}} -test menu-22.2 {GetIndexFromCoords} { - catch {destroy .m1} + .m1 index @5 +} -cleanup { + deleteWindows +} -result {0} +test menu-22.2 {GetIndexFromCoords} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 - list [catch {.m1 index @5,5} msg] $msg [destroy .m1] -} {0 0 {}} -test menu-22.3 {GetIndexFromCoords: mapped window, y only} unix { - catch {destroy .m1} + .m1 index @5,5 +} -cleanup { + deleteWindows +} -result {0} +test menu-22.3 {GetIndexFromCoords: mapped window, y only} -setup { + deleteWindows +} -constraints {unix} -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 tk_popup .m1 0 0 tkwait visibility .m1 - list [catch {.m1 index @5} msg] $msg [destroy .m1] -} {0 0 {}} -test menu-22.4 {GetIndexFromCoords: mapped window x,y} unix { - catch {destroy .m1} + .m1 index @5 +} -cleanup { + deleteWindows +} -result {0} +test menu-22.4 {GetIndexFromCoords: mapped window x,y} -setup { + deleteWindows +} -constraints {unix} -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 @@ -2160,10 +3343,13 @@ test menu-22.4 {GetIndexFromCoords: mapped window x,y} unix { tkwait visibility .m1 update set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] - list [catch {.m1 index @$x,5} msg] $msg [destroy .m1] -} {0 0 {}} -test menu-22.5 {GetIndexFromCoords: mapped wide window} unix { - catch {destroy .m1} + .m1 index @$x,5 +} -cleanup { + deleteWindows +} -result {0} +test menu-22.5 {GetIndexFromCoords: mapped wide window} -setup { + deleteWindows +} -constraints {unix} -body { menu .m1 .m1 add command -label "test" .m1 configure -tearoff 0 @@ -2172,105 +3358,137 @@ test menu-22.5 {GetIndexFromCoords: mapped wide window} unix { wm geometry .m1 200x100 update set x [expr {[winfo width .m1] - [.m1 cget -borderwidth] - 1}] - list [catch {.m1 index @$x,5} msg] $msg [destroy .m1] -} {0 0 {}} + .m1 index @$x,5 +} -cleanup { + deleteWindows +} -result {0} -test menu-23.1 {RecursivelyDeleteMenu} { - catch {destroy .m1} +test menu-23.1 {RecursivelyDeleteMenu} -setup { + deleteWindows +} -body { menu .m1 . configure -menu .m1 - list [catch {. configure -menu ""} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-23.2 {RecursivelyDeleteMenu} { - catch {destroy .m1} - catch {destroy .m2} + . configure -menu "" +} -cleanup { + deleteWindows +} -result {} +test menu-23.2 {RecursivelyDeleteMenu} -setup { + deleteWindows +} -body { menu .m2 .m2 add command -label "test2" menu .m1 .m1 add cascade -label "test1" -menu .m2 . configure -menu .m1 - list [catch {. configure -menu ""} msg] $msg [destroy .m1 .m2] -} {0 {} {}} + . configure -menu "" +} -cleanup { + deleteWindows +} -result {} -test menu-24.1 {TkNewMenuName} { - catch {destroy .m1} +test menu-24.1 {TkNewMenuName} -setup { + deleteWindows +} -body { menu .m1 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test menu-24.2 {TkNewMenuName} { - catch {destroy .m1} - catch {destroy .m1\#0} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-24.2 {TkNewMenuName} -setup { + deleteWindows +} -body { menu .m1 menu .m1\#0 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test menu-24.3 {TkNewMenuName} { - catch {destroy .#m} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-24.3 {TkNewMenuName} -setup { + deleteWindows +} -body { menu .#m rename .#m hideme - list [catch {. configure -menu [menu .m]} $msg] [. configure -menu ""] [destroy .#m] [destroy .m] [destroy hideme] -} {0 {} {} {} {}} + list [catch {. configure -menu [menu .m]}] [. configure -menu ""] [destroy .#m] \ + [destroy .m] [destroy hideme] +} -result {0 {} {} {} {}} -test menu-25.1 {TkSetWindowMenuBar} { + +test menu-25.1 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] -} {0 {} {}} -test menu-25.2 {TkSetWindowMenuBar} { + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.2 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] -} {0 {} {}} -test menu-25.3 {TkSetWindowMenuBar} { + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.3 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" - catch {destroy .m1} + destroy .m1 menu .m1 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test menu-25.4 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.4 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 . configure -menu .m1 menu .m2 - list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .m1 .m2] -} {0 {} {} {}} -test menu-25.5 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [. configure -menu .m2] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.5 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 . configure -menu .m1 .m1 clone .m2 menu .m3 - list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] -} {0 {} {} {}} -test menu-25.6 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + list [. configure -menu .m3] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.6 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 .m1 clone .m2 . configure -menu .m2 menu .m3 - list [catch {. configure -menu .m3} msg] $msg [. configure -menu ""] [destroy .m1 .m3] -} {0 {} {} {}} -test menu-25.7 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} + list [. configure -menu .m3] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.7 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 menu .m2 . configure -menu .m1 toplevel .t2 .t2 configure -menu .m1 - list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] -} {0 {} {} {}} -test menu-25.8 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .t2} + list [.t2 configure -menu .m2] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.8 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 menu .m2 @@ -2278,13 +3496,13 @@ test menu-25.8 {TkSetWindowMenuBar} { toplevel .t2 wm geometry .t2 +0+0 .t2 configure -menu .m1 - list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .m1 .m2] -} {0 {} {} {}} -test menu-25.9 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .t2} - catch {destroy .t3} + list [. configure -menu .m2] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.9 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 menu .m2 @@ -2293,13 +3511,13 @@ test menu-25.9 {TkSetWindowMenuBar} { wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 - list [catch {.t3 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] -} {0 {} {} {}} -test menu-25.10 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .t2} - catch {destroy .t3} + list [.t3 configure -menu .m2] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.10 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 menu .m2 @@ -2308,13 +3526,13 @@ test menu-25.10 {TkSetWindowMenuBar} { wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 - list [catch {.t2 configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] -} {0 {} {} {}} -test menu-25.11 {TkSetWindowMenuBar} { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .t2} - catch {destroy .t3} + list [.t2 configure -menu .m2] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.11 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 menu .m2 @@ -2323,128 +3541,188 @@ test menu-25.11 {TkSetWindowMenuBar} { wm geometry .t2 +0+0 toplevel .t3 -menu .m1 wm geometry .t3 +0+0 - list [catch {. configure -menu .m2} msg] $msg [. configure -menu ""] [destroy .t2 .t3 .m1 .m2] -} {0 {} {} {}} -test menu-25.12 {TkSetWindowMenuBar} { - catch {destroy .m1} + list [. configure -menu .m2] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.12 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test menu-25.13 {TkSetWindowMenuBar} { + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.13 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] -} {0 {} {}} -test menu-25.14 {TkSetWindowMenuBar} { - catch {destroy .m1} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.14 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test menu-25.15 {TkSetWindowMenuBar} { + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.15 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] -} {0 {} {}} -test menu-25.16 {TkSetWindowMenuBar} { - catch {destroy .m1} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menu-25.16 {TkSetWindowMenuBar} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 . configure -menu .m1 - list [catch {toplevel .t2 -menu m1} msg] $msg [. configure -menu ""] [destroy .t2 .m1] -} {0 .t2 {} {}} + list [toplevel .t2 -menu m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {.t2 {}} + -test menu-26.1 {DestroyMenuHashTable} { - catch {interp destroy testinterp} +test menu-26.1 {DestroyMenuHashTable} -setup { + catch {interp delete testinterp} + deleteWindows +} -body { interp create testinterp load {} Tk testinterp interp eval testinterp {menu .m1} - list [catch {interp delete testinterp} msg] $msg -} {0 {}} + interp delete testinterp +} -returnCodes ok -result {} + -test menu-27.1 {GetMenuHashTable} { - catch {interp destroy testinterp} +test menu-27.1 {GetMenuHashTable} -setup { + catch {interp delete testinterp} + deleteWindows +} -body { interp create testinterp load {} Tk testinterp list [catch {interp eval testinterp {menu .m1}} msg] $msg [interp delete testinterp] -} {0 .m1 {}} +} -cleanup { + deleteWindows +} -result {0 .m1 {}} -test menu-28.1 {TkCreateMenuReferences - not there before} { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test menu-28.2 {TkCreateMenuReferences - there already} { - catch {destroy .m1} - catch {destroy .m2} + +test menu-28.1 {TkCreateMenuReferences - not there before} -setup { + deleteWindows +} -body { + menu .m1 +} -cleanup { + deleteWindows +} -result {.m1} +test menu-28.2 {TkCreateMenuReferences - there already} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m2 - list [catch {menu .m2} msg] $msg [destroy .m1 .m2] -} {0 .m2 {}} + menu .m2 +} -cleanup { + deleteWindows +} -result {.m2} -test menu-29.1 {TkFindMenuReferences - not there} { - catch {destroy .m1} + +test menu-29.1 {TkFindMenuReferences - not there} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 .m1 add cascade -menu .m2 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test menu-30.1 {TkFindMenuReferences - there already} { - catch {destroy .m1} - catch {destroy .m2} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} + + +test menu-30.1 {TkFindMenuReferences - there already} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 menu .m2 .m1 add cascade -menu .m2 - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1 .m2] -} {0 {} {} {}} + list [. configure -menu .m1] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} + -test menu-31.1 {TkFreeMenuReferences - menuPtr} { - catch {destroy .m1} +test menu-31.1 {TkFreeMenuReferences - menuPtr} -setup { + deleteWindows +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test menu-31.2 {TkFreeMenuReferences - cascadePtr} { - catch {destroy .m1} + destroy .m1 +} -cleanup { + deleteWindows +} -result {} +test menu-31.2 {TkFreeMenuReferences - cascadePtr} -setup { + deleteWindows +} -body { . configure -menu "" menu .m1 .m1 add cascade -menu .m2 - list [catch {.m1 entryconfigure 1 -menu .m3} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} { + .m1 entryconfigure 1 -menu .m3 +} -cleanup { + deleteWindows +} -result {} +test menu-31.3 {TkFreeMenuReferences - topLevelListPtr} -setup { + deleteWindows +} -body { . configure -menu .m1 - list [catch {. configure -menu ""} msg] $msg -} {0 {}} -test menu-31.4 {TkFreeMenuReferences - not empty} { - catch {destroy .m1} - catch {destroy .m2} + . configure -menu "" +} -cleanup { + deleteWindows +} -returnCodes ok -result {} +test menu-31.4 {TkFreeMenuReferences - not empty} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -menu .m3 menu .m2 .m2 add cascade -menu .m3 - list [catch {.m2 entryconfigure 1 -menu ".foo"} msg] $msg [destroy .m1 .m2] -} {0 {} {}} + .m2 entryconfigure 1 -menu ".foo" +} -cleanup { + deleteWindows +} -result {} + -test menu-32.1 {DeleteMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} +test menu-32.1 {DeleteMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label foo .m1 clone .m2 - list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.2 {DeleteMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} + .m1 delete 1 +} -cleanup { + deleteWindows +} -result {} +test menu-32.2 {DeleteMenuCloneEntries} -setup { + deleteWindows +} -body { + menu .m1 .m1 add command -label one .m1 add command -label two .m1 add command -label three .m1 add command -label four .m1 clone .m2 - list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.3 {DeleteMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} + .m1 delete 2 3 +} -cleanup { + deleteWindows +} -result {} +test menu-32.3 {DeleteMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two @@ -2452,11 +3730,13 @@ test menu-32.3 {DeleteMenuCloneEntries} { .m1 add command -label four .m1 clone .m2 .m2 configure -tearoff 1 - list [catch {.m1 delete 1 2} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.4 {DeleteMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} + .m1 delete 1 2 +} -cleanup { + deleteWindows +} -result {} +test menu-32.4 {DeleteMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label one .m1 add command -label two @@ -2464,49 +3744,62 @@ test menu-32.4 {DeleteMenuCloneEntries} { .m1 add command -label four .m1 clone .m2 .m2 configure -tearoff 0 - list [catch {.m1 delete 2 3} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.5 {DeleteMenuCloneEntries} { - catch {destroy .m1} - catch {destroy .m2} + .m1 delete 2 3 +} -cleanup { + deleteWindows +} -result {} +test menu-32.5 {DeleteMenuCloneEntries} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label one .m1 add command -label two .m1 clone .m2 .m1 activate one - list [catch {.m1 delete one} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} { - catch {destroy .m1} - menu .m1 - .m1 add command -label test -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" - list [catch {.m1 invoke test} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.7 {DeleteMenuCloneEntries - one entry} { - catch {destroy .m1} + .m1 delete one +} -cleanup { + deleteWindows +} -result {} +test menu-32.6 {DeleteMenuCloneEntries - reentrancy - crashes tk8.0} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label test \ + -command ".m1 delete test ; .m1 add command -label test -command \".m1 delete test\"; .m1 delete test" + .m1 invoke test +} -cleanup { + deleteWindows +} -result {} +test menu-32.7 {DeleteMenuCloneEntries - one entry} -setup { + deleteWindows +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello - list [catch {.m1 delete Hello} msg] $msg [destroy .m1] -} {0 {} {}} -test menu-32.8 {Ensure all menu clone commands are deleted} { + .m1 delete Hello +} -cleanup { + deleteWindows +} -result {} +test menu-32.8 {Ensure all menu clone commands are deleted} -setup { + deleteWindows +} -body { # SF bug #465324 - catch {destroy .menubar} - catch {destroy .menubar.test} menu .menubar . configure -menu .menubar menu .menubar.test .menubar.test add command -label "hi" for {set i 0} {$i < 10} {incr i} { - .menubar add cascade -menu .menubar.test -label "Test" - .menubar delete Test + .menubar add cascade -menu .menubar.test -label "Test" + .menubar delete Test } info commands .#menubar*test* -} {} -test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} { - catch {destroy .menubar} - catch {destroy .menubar.test} - +} -cleanup { + deleteWindows +} -result {} +test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} -setup { + set res {} + deleteWindows +} -body { menu .menubar . configure -menu .menubar menu .menubar.test @@ -2514,7 +3807,6 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} { menu .menubar.cascade .menubar.test add cascade -menu .menubar.cascade -label "Cascade" - set res {} lappend res [.menubar.test entrycget 1 -menu] lappend res [.#menubar.#menubar#test entrycget 1 -menu] destroy .menubar.test @@ -2522,46 +3814,60 @@ test menu-32.9 {Ensure deleting of clones doesn't corrupt menu refs} { .menubar.test add cascade -menu .menubar.cascade -label "Cascade" lappend res [.menubar.test entrycget 1 -menu] lappend res [.#menubar.#menubar#test entrycget 1 -menu] - set res -} {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade} + return $res +} -cleanup { + deleteWindows +} -result {.menubar.cascade .#menubar.#menubar#test.#menubar#cascade .menubar.cascade .#menubar.#menubar#test.#menubar#cascade} -set l [interp hidden] -deleteWindows -test menu-33.1 {menu vs command hiding} { - catch {destroy .m} +test menu-33.1 {menu vs command hiding} -setup { + deleteWindows +} -body { + set l [interp hidden] menu .m interp hide {} .m destroy .m - list [winfo children .] [interp hidden] -} [list {} $l] + set result [list [winfo children .] [interp hidden]] + expr {$result eq [list {} $l]} +} -result 1 # menu-34 MenuInit only called at boot time # creating menus on two different screens then deleting the # menu from the first screen crashes Tk8.3.1 # -test menu-35.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} \ - {altDisplay} { +test menu-34.1 {menus on multiple screens - crashes tk8.3.1, Bug 5454} -constraints { + altDisplay +} -setup { + deleteWindows +} -body { toplevel .one menu .one.m toplevel .two -screen $::env(TK_ALT_DISPLAY) menu .two.m destroy .one destroy .two -} {} +} -result {} -test menu-36.1 {menu -underline string overruns Bug 1599877} {} { +test menu-35.1 {menu -underline string overruns Bug 1599877} -setup { + destroy .m +} -body { # ensure that -underline does not do string overruns [Bug 1599877] - catch {destroy .m} menu .m .m add command -label "File" -underline [expr {1<<30}] . configure -menu .m update tk::TraverseToMenu . "e" -} {} +} -cleanup { + deleteWindows +} -result {} # cleanup +imageFinish deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/menuDraw.test b/tests/menuDraw.test index 225223c..bb632c6 100644 --- a/tests/menuDraw.test +++ b/tests/menuDraw.test @@ -5,173 +5,260 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test +imageInit -test menuDraw-1.1 {TkMenuInitializeDrawingFields} { - catch {destroy .m1} - list [menu .m1] [destroy .m1] -} {.m1 {}} - -test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} { - catch {destroy .m1} +test menuDraw-1.1 {TkMenuInitializeDrawingFields} -setup { + deleteWindows +} -body { menu .m1 - list [.m1 add command] [destroy .m1] -} {{} {}} +} -cleanup { + deleteWindows +} -result {.m1} + + +test menuDraw-2.1 {TkIntializeMenuEntryDrawingFields} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command +} -cleanup { + deleteWindows +} -result {} + -test menuDraw-3.1 {TkMenuFreeDrawOptions} { - catch {destroy .m1} +test menuDraw-3.1 {TkMenuFreeDrawOptions} -setup { + deleteWindows +} -body { menu .m1 - list [destroy .m1] -} {{}} + destroy .m1 +} -result {} -test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} { - catch {destroy .m1} + +test menuDraw-4.1 {TkMenuEntryFreeDrawOptions} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "This is a test" - list [destroy .m1] -} {{}} -test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} { - catch {destroy .m1} - menu .m1 - .m1 add checkbutton -label "This is a test." -font "Courier 12" -activeforeground red -background green -selectcolor purple - list [destroy .m1] -} {{}} - -test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} { - catch {destroy .m1} - list [menu .m1] [destroy .m1] -} {.m1 {}} -test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} { - catch {destroy .m1} - menu .m1 - list [.m1 configure -fg red] [destroy .m1] -} {{} {}} -test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} { - catch {destroy .m1} - list [menu .m1 -disabledforeground ""] [destroy .m1] -} {.m1 {}} - -test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo"] [destroy .m1] -} {{} {}} -test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1] -} {{} {}} -test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} { - catch {destroy .m1} + destroy .m1 +} -result {} +test menuDraw-4.2 {TkMenuEntryFreeDrawOptions} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add checkbutton -label "This is a test." -font "Courier 12" \ + -activeforeground red -background green -selectcolor purple + destroy .m1 +} -result {} + + +test menuDraw-5.1 {TkMenuConfigureDrawOptions - new menu} -setup { + deleteWindows +} -body { + menu .m1 +} -cleanup { + deleteWindows +} -result {.m1} +test menuDraw-5.2 {TkMenuConfigureDrawOptions - old menu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 configure -fg red +} -cleanup { + deleteWindows +} -result {} +test menuDraw-5.3 {TkMenuConfigureDrawOptions - no disabledFg} -setup { + deleteWindows +} -body { + menu .m1 -disabledforeground "" +} -cleanup { + deleteWindows +} -result {.m1} + + +test menuDraw-6.1 {TkMenuConfigureEntryDrawOptions - no tkfont specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.2 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" -font "Courier 12" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.3 {TkMenuConfigureEntryDrawOptions - active state - wrong entry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" - list [.m1 entryconfigure 1 -state active] [destroy .m1] -} {{} {}} -test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} { - catch {destroy .m1} + .m1 entryconfigure 1 -state active +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.4 {TkMenuConfigureEntryDrawOptions - active state - correct entry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" .m1 activate 1 - list [.m1 entryconfigure 1 -state active] [destroy .m1] -} {{} {}} -test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} { - catch {destroy .m1} + .m1 entryconfigure 1 -state active +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.5 {TkMenuConfigureEntryDrawOptions - deactivate entry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" .m1 activate 1 - list [.m1 entryconfigure 1 -state normal] [destroy .m1] -} {{} {}} -test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} { - catch {destroy .m1} + .m1 entryconfigure 1 -state normal +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.6 {TkMenuConfigureEntryDrawOptions - bad state} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" - list [catch {.m1 entryconfigure 1 -state foo} msg] $msg [destroy .m1] -} {1 {bad state "foo": must be active, normal, or disabled} {}} -test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo" -font "Courier 12"] [destroy .m1] -} {{} {}} -test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo" -background "red"] [destroy .m1] -} {{} {}} -test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo" -foreground "red"] [destroy .m1] -} {{} {}} -test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo" -activebackground "red"] [destroy .m1] -} {{} {}} -test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add command -label "foo" -activeforeground "red"] [destroy .m1] -} {{} {}} -test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} { - catch {destroy .m1} - menu .m1 - list [.m1 add radiobutton -label "foo" -selectcolor "red"] [destroy .m1] -} {{} {}} -test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} { - catch {destroy .m1} + .m1 entryconfigure 1 -state foo +} -cleanup { + deleteWindows +} -returnCodes error -result {bad state "foo": must be active, normal, or disabled} +test menuDraw-6.7 {TkMenuConfigureEntryDrawOptions - tkfont specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" -font "Courier 12" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.8 {TkMenuConfigureEntryDrawOptions - border specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" -background "red" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.9 {TkMenuConfigureEntryDrawOptions - foreground specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" -foreground "red" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.10 {TkMenuConfigureEntryDrawOptions - activeBorder specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" -activebackground "red" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.11 {TkMenuConfigureEntryDrawOptions - activeforeground specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add command -label "foo" -activeforeground "red" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.12 {TkMenuConfigureEntryDrawOptions - selectcolor specified} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add radiobutton -label "foo" -selectcolor "red" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.13 {TkMenuConfigureEntryDrawOptions - textGC disposal} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" -font "Helvetica 12" - list [.m1 entryconfigure 1 -font "Courier 12"] [destroy .m1] -} {{} {}} -test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} { - catch {destroy .m1} + .m1 entryconfigure 1 -font "Courier 12" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.14 {TkMenuConfigureEntryDrawOptions - activeGC disposal} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" -activeforeground "red" - list [.m1 entryconfigure 1 -activeforeground "green"] [destroy .m1] -} {{} {}} -test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} { - catch {destroy .m1} + .m1 entryconfigure 1 -activeforeground "green" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.15 {TkMenuConfigureEntryDrawOptions - disabledGC disposal} -setup { + deleteWindows +} -body { menu .m1 -disabledforeground "red" .m1 add command -label "foo" - list [.m1 configure -disabledforeground "green"] [destroy .m1] -} {{} {}} -test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} { - catch {destroy .m1} + .m1 configure -disabledforeground "green" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-6.16 {TkMenuConfigureEntryDrawOptions - indicatorGC disposal} -setup { + deleteWindows +} -body { menu .m1 .m1 add radiobutton -label "foo" -selectcolor "red" - list [.m1 entryconfigure 1 -selectcolor "green"] [destroy .m1] -} {{} {}} + .m1 entryconfigure 1 -selectcolor "green" +} -cleanup { + deleteWindows +} -result {} -test menuDraw-7.1 {TkEventuallyRecomputeMenu} { - catch {destroy .m1} + +test menuDraw-7.1 {TkEventuallyRecomputeMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "This is a long label" set tearoff [tk::TearOffMenu .m1] update idletasks - list [.m1 entryconfigure 1 -label "foo"] [destroy .m1] -} {{} {}} -test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} { - catch {destroy .m1} + .m1 entryconfigure 1 -label "foo" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-7.2 {TkEventuallyRecomputeMenu - update pending} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "This is a long label" set tearoff [tk::TearOffMenu .m1] - list [.m1 entryconfigure 1 -label "foo"] [destroy .m1] -} {{} {}} + .m1 entryconfigure 1 -label "foo" +} -cleanup { + deleteWindows +} -result {} -test menuDraw-8.1 {TkRecomputeMenu} {win userInteraction} { - catch {destroy .m1} +test menuDraw-8.1 {TkRecomputeMenu} -constraints { + win userInteraction +} -setup { + deleteWindows +} -body { menu .m1 .m1 configure -postcommand [.m1 add command -label foo] .m1 add command -label "Hit ESCAPE to make this menu go away." - list [.m1 post 0 0] [destroy .m1] -} {{} {}} + .m1 post 0 0 +} -cleanup { + deleteWindows +} -result {} -test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} { - catch {destroy .m1} +test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} -setup { + deleteWindows +} -body { catch {unset foo} menu .m1 set foo 0 @@ -179,46 +266,66 @@ test menuDraw-9.1 {TkEventuallyRedrawMenu - entry test} { tk::TearOffMenu .m1 update idletasks list [set foo test] [destroy .m1] [unset foo] -} {test {} {}} -test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} { - catch {destroy .m1} +} -result {test {} {}} +test menuDraw-9.2 {TkEventuallyRedrawMenu - whole menu} -setup { + deleteWindows +} -body { menu .m1 - list [catch {tk::TearOffMenu .m1}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 +} -cleanup { + deleteWindows +} -returnCodes ok -match glob -result * + # Don't know how to test when window has been deleted and ComputeMenuGeometry # gets called. -test menuDraw-10.1 {ComputeMenuGeometry - menubar} { - catch {destroy .m1} +test menuDraw-10.1 {ComputeMenuGeometry - menubar} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label test . configure -menu .m1 - list [update idletasks] [. configure -menu ""] [destroy .m1] -} {{} {} {}} -test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} { - catch {destroy .m1} + list [update idletasks] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menuDraw-10.2 {ComputeMenuGeometry - non-menubar} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label test - list [update idletasks] [destroy .m1] -} {{} {}} -test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} { - catch {destroy .m1} + update idletasks +} -cleanup { + deleteWindows +} -result {} +test menuDraw-10.3 {ComputeMenuGeometry - Resize necessary} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label test - list [update idletasks] [destroy .m1] -} {{} {}} -test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} { - catch {destroy .m1} + update idletasks +} -cleanup { + deleteWindows +} -result {} +test menuDraw-10.4 {ComputeMenuGeometry - resize not necessary} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label test update idletasks .m1 entryconfigure 1 -label test - list [update idletasks] [destroy .m1] -} {{} {}} + update idletasks +} -cleanup { + deleteWindows +} -result {} -test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} testImageType { - catch {destroy .m1} - catch {eval image delete [image names]} + +test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} -constraints { + testImageType +} -setup { + deleteWindows + imageCleanup +} -body { image create test image1 image create test image2 menu .m1 @@ -226,80 +333,111 @@ test menuDraw-11.1 {TkMenuSelectImageProc - entry selected; redraw not pending} .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] update idletasks - list [image delete image2] [destroy .m1] [eval image delete [image names]] -} {{} {} {}} -test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} testImageType { - catch {destroy .m1} - catch {eval image delete [image names]} + list [image delete image2] [destroy .m1] +} -cleanup { + imageCleanup +} -result {{} {}} +test menuDraw-11.2 {TkMenuSelectImageProc - entry selected; redraw pending} -constraints { + testImageType +} -setup { + deleteWindows + imageCleanup +} -body { image create test image1 image create test image2 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] - list [image delete image2] [destroy .m1] [eval image delete [image names]] -} {{} {} {}} -test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} testImageType { - catch {destroy .m1} - catch {eval image delete [image names]} + list [image delete image2] [destroy .m1] +} -cleanup { + imageCleanup +} -result {{} {}} +test menuDraw-11.3 {TkMenuSelectImageProc - entry not selected} -constraints { + testImageType +} -setup { + deleteWindows + imageCleanup +} -body { image create test image1 image create test image2 menu .m1 .m1 add checkbutton -image image1 -selectimage image2 set tearoff [tk::TearOffMenu .m1 40 40] update idletasks - list [image delete image2] [destroy .m1] [eval image delete [image names]] -} {{} {} {}} + list [image delete image2] [destroy .m1] +} -cleanup { + imageCleanup +} -result {{} {}} #Don't know how to test missing tkwin in DisplayMenu -test menuDraw-12.1 {DisplayMenu - menubar background} unix { - catch {destroy .m1} +test menuDraw-12.1 {DisplayMenu - menubar background} -constraints unix -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label foo -menu .m2 . configure -menu .m1 - list [update] [. configure -menu ""] [destroy .m1] -} {{} {} {}} -test menuDraw-12.2 {Display menu - no entries} { - catch {destroy .m1} + list [update] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menuDraw-12.2 {Display menu - no entries} -setup { + deleteWindows +} -body { menu .m1 set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test menuDraw-12.3 {DisplayMenu - one entry} { - catch {destroy .m1} + update +} -cleanup { + deleteWindows +} -result {} +test menuDraw-12.3 {DisplayMenu - one entry} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test menuDraw-12.4 {DisplayMenu - two entries} { - catch {destroy .m1} + update +} -cleanup { + deleteWindows +} -result {} +test menuDraw-12.4 {DisplayMenu - two entries} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test menuDraw.12.5 {DisplayMenu - two columns - first bigger} { - catch {destroy .m1} + update +} -cleanup { + deleteWindows +} -result {} +test menuDraw.12.5 {DisplayMenu - two columns - first bigger} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" .m1 add command -label "three" -columnbreak 1 set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test menuDraw-12.5 {DisplayMenu - two column - second bigger} { - catch {destroy .m1} + update +} -cleanup { + deleteWindows +} -result {} +test menuDraw-12.5 {DisplayMenu - two column - second bigger} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" -columnbreak 1 .m1 add command -label "three" set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test menuDraw.12.7 {DisplayMenu - three columns} { - catch {destroy .m1} + update +} -cleanup { + deleteWindows +} -result {} +test menuDraw.12.7 {DisplayMenu - three columns} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" -columnbreak 1 @@ -308,133 +446,175 @@ test menuDraw.12.7 {DisplayMenu - three columns} { .m1 add command -label "five" .m1 add command -label "six" set tearoff [tk::TearOffMenu .m1 40 40] - list [update] [destroy .m1] -} {{} {}} -test menuDraw-12.6 {Display menu - testing for extra space and menubars} unix { - catch {destroy .m1} + update +} -cleanup { + deleteWindows +} -result {} +test menuDraw-12.6 {Display menu - testing for extra space and menubars} -constraints { + unix +} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label foo . configure -menu .m1 - list [update] [. configure -menu ""] [destroy .m1] -} {{} {} {}} -test menuDraw-12.7 {Display menu - extra space at end of menu} { - catch {destroy .m1} + update + . configure -menu "" +} -cleanup { + deleteWindows +} -result {} +test menuDraw-12.7 {Display menu - extra space at end of menu} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] wm geometry $tearoff 200x100 - list [update] [destroy .m1] -} {{} {}} + update +} -cleanup { + deleteWindows +} -result {} + -test menuDraw-13.1 {TkMenuEventProc - Expose} { - catch {destroy .m1} - catch {destroy .m2} +test menuDraw-13.1 {TkMenuEventProc - Expose} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "one" menu .m2 .m2 add command -label "two" set tearoff1 [tk::TearOffMenu .m1 40 40] set tearoff2 [tk::TearOffMenu .m2 40 40] - list [raise $tearoff2] [update] [destroy .m1] [destroy .m2] -} {{} {} {} {}} -test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} { - catch {destroy .m1} + list [raise $tearoff2] [update] +} -cleanup { + deleteWindows +} -result {{} {}} +test menuDraw-13.2 {TkMenuEventProc - ConfigureNotify} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" set tearoff [tk::TearOffMenu .m1 40 40] - list [wm geometry $tearoff 200x100] [update] [destroy .m1] -} {{} {} {}} + list [wm geometry $tearoff 200x100] [update] +} -cleanup { + deleteWindows +} -result {{} {}} # Testing deletes is hard, and I am going to do my best. Don't know how # to test the case where we have already cleared the tkwin field in the # menuPtr. -test menuDraw-13.4 {TkMenuEventProc - simple delete} { - catch {destroy .m1} +test menuDraw-13.4 {TkMenuEventProc - simple delete} -setup { + deleteWindows +} -body { menu .m1 - list [destroy .m1] -} {{}} -test menuDraw-13.5 {TkMenuEventProc - nothing pending} { - catch {destroy .m1} + destroy .m1 +} -result {} +test menuDraw-13.5 {TkMenuEventProc - nothing pending} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label foo update idletasks - list [destroy .m1] -} {{}} + destroy .m1 +} -result {} -test menuDraw-14.1 {TkMenuImageProc} testImageType { - catch {destroy .m1} + +test menuDraw-14.1 {TkMenuImageProc} -constraints testImageType -setup { + deleteWindows +} -body { catch {image delete image1} menu .m1 image create test image1 .m1 add command -image image1 update idletasks - list [image delete image1] [destroy .m1] -} {{} {}} -test menuDraw-14.2 {TkMenuImageProc} testImageType { - catch {destroy .m1} + image delete image1 +} -cleanup { + deleteWindows +} -result {} +test menuDraw-14.2 {TkMenuImageProc} -constraints testImageType -setup { + deleteWindows +} -body { catch {image delete image1} menu .m1 image create test image1 .m1 add command -image image1 - list [image delete image1] [destroy .m1] -} {{} {}} + image delete image1 +} -cleanup { + deleteWindows +} -result {} + -test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} { - catch {destroy .m1} +test menuDraw-15.1 {TkPostTearoffMenu - Basic posting} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 +} -cleanup { + deleteWindows +} -returnCodes ok -match glob -result * +test menuDraw-15.2 {TkPostTearoffMenu - Deactivation} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" -state active set tearoff [tk::TearOffMenu .m1 40 40] - list [$tearoff index active] [destroy .m1] -} {none {}} -test menuDraw-15.3 {TkPostTearoffMenu - post command} { - catch {destroy .m1} + $tearoff index active +} -cleanup { + deleteWindows +} -result {none} +test menuDraw-15.3 {TkPostTearoffMenu - post command} -setup { + deleteWindows +} -body { catch {unset foo} menu .m1 -postcommand "set foo .m1" .m1 add command -label "foo" list [catch {tk::TearOffMenu .m1 40 40}] [set foo] [unset foo] [destroy .m1] -} {0 .m1 {} {}} -test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} { - catch {destroy .m1} +} -result {0 .m1 {} {}} +test menuDraw-15.4 {TkPostTearoffMenu - post command deleting the menu} -setup { + deleteWindows +} -body { menu .m1 -postcommand "destroy .m1" .m1 add command -label "foo" list [catch {tk::TearOffMenu .m1 40 40} msg] $msg [winfo exists .m1] -} {0 {} 0} -test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} { - catch {destroy .m1} +} -result {0 {} 0} +test menuDraw-15.5 {TkPostTearoffMenu - tearoff at edge of screen} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" set height [winfo screenheight .m1] - list [catch {tk::TearOffMenu .m1 40 $height}] [destroy .m1] -} {0 {}} -test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} { - catch {destroy .m1} + tk::TearOffMenu .m1 40 $height +} -cleanup { + deleteWindows +} -returnCodes ok -match glob -result * +test menuDraw-15.6 {TkPostTearoffMenu - tearoff off right} -setup { + deleteWindows +} -body { menu .m1 .m1 add command -label "foo" set width [winfo screenwidth .m1] - list [catch {tk::TearOffMenu .m1 $width 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 $width 40 +} -cleanup { + deleteWindows +} -returnCodes ok -match glob -result * -test menuDraw-16.1 {TkPostSubmenu} nonUnixUserInteraction { - catch {destroy .m1} - catch {destroy .m2} +test menuDraw-16.1 {TkPostSubmenu} -constraints nonUnixUserInteraction -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 .m2 add command -label "Hit ESCAPE to make this menu go away." set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 - list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] -} {{} {} {}} -test menuDraw-16.2 {TkPostSubMenu} nonUnixUserInteraction { - catch {destroy .m1} - catch {destroy .m2} - catch {destroy .m3} + $tearoff postcascade 0 +} -cleanup { + deleteWindows +} -result {} +test menuDraw-16.2 {TkPostSubMenu} -constraints nonUnixUserInteraction -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label "two" -menu .m2 .m1 add cascade -label "three" -menu .m3 @@ -444,68 +624,94 @@ test menuDraw-16.2 {TkPostSubMenu} nonUnixUserInteraction { .m3 add command -label "three" set tearoff [tk::TearOffMenu .m1 40 40] $tearoff postcascade 0 - list [$tearoff postcascade 1] [destroy .m1] [destroy .m2] [destroy .m3] -} {{} {} {} {}} -test menuDraw-16.3 {TkPostSubMenu} { - catch {destroy .m1} + $tearoff postcascade 1 +} -cleanup { + deleteWindows +} -result {} +test menuDraw-16.3 {TkPostSubMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label test -menu .m2 - list [.m1 postcascade 1] [destroy .m1] -} {{} {}} -test menuDraw-16.4 {TkPostSubMenu} { - catch {destroy .m1} + .m1 postcascade 1 +} -cleanup { + deleteWindows +} -result {} +test menuDraw-16.4 {TkPostSubMenu} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label test set tearoff [tk::TearOffMenu .m1 40 40] - list [$tearoff postcascade 0] [destroy .m1] -} {{} {}} -test menuDraw-16.5 {TkPostSubMenu} unix { - catch {destroy .m1} - catch {destroy .m2} + $tearoff postcascade 0 +} -cleanup { + deleteWindows +} -result {} +test menuDraw-16.5 {TkPostSubMenu} -constraints unix -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 -postcommand "glorp" set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {$tearoff postcascade test} msg] $msg [destroy .m1] [destroy .m2] -} {1 {invalid command name "glorp"} {} {}} -test menuDraw-16.6 {TkPostSubMenu} {win userInteraction} { - catch {destroy .m1} - catch {destroy .m2} + $tearoff postcascade test +} -cleanup { + deleteWindows +} -returnCodes error -result {invalid command name "glorp"} +test menuDraw-16.6 {TkPostSubMenu} -constraints { + win userInteraction +} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 .m2 add command -label "Hit ESCAPE to get rid of this menu" set tearoff [tk::TearOffMenu .m1 40 40] - list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] -} {{} {} {}} + $tearoff postcascade 0 +} -cleanup { + deleteWindows +} -result {} -test menuDraw-17.1 {AdjustMenuCoords - menubar} unix { - catch {destroy .m1} - catch {destroy .m2} + +test menuDraw-17.1 {AdjustMenuCoords - menubar} -constraints unix -setup { + deleteWindows +} -body { menu .m1 -tearoff 0 .m1 add cascade -label test -menu .m2 menu .m2 -tearoff 0 .m2 add command -label foo . configure -menu .m1 foreach w [winfo children .] { - if {[$w cget -type] == "menubar"} { - break - } + if {[$w cget -type] == "menubar"} { + break + } } - list [$w postcascade 0] [. configure -menu ""] [destroy .m1] [destroy .m2] -} {{} {} {} {}} -test menuDraw-17.2 {AdjustMenuCoords - menu} {win userInteraction} { - catch {destroy .m1} - catch {destroy .m2} + list [$w postcascade 0] [. configure -menu ""] +} -cleanup { + deleteWindows +} -result {{} {}} +test menuDraw-17.2 {AdjustMenuCoords - menu} -constraints { + win userInteraction +} -setup { + deleteWindows +} -body { menu .m1 .m1 add cascade -label test -menu .m2 menu .m2 .m2 add command -label "Hit ESCAPE to make this menu go away" set tearoff [tk::TearOffMenu .m1 40 40] - list [$tearoff postcascade 0] [destroy .m1] [destroy .m2] -} {{} {} {}} + $tearoff postcascade 0 +} -cleanup { + deleteWindows +} -result {} # cleanup +imageFinish deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/menubut.test b/tests/menubut.test index 3dfa1b5..6efdb0f 100644 --- a/tests/menubut.test +++ b/tests/menubut.test @@ -10,9 +10,11 @@ # XXX of a procedure has tests then the whole procedure has tests, # XXX but many procedures have no tests. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test +imageInit # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -24,318 +26,737 @@ option add *Button.borderWidth 2 option add *Button.highlightThickness 2 option add *Button.font {Helvetica -12 bold} -eval image delete [image names] -if {[testConstraint testImageType]} { + +menubutton .mb -text "Test" +pack .mb +update +test menubutton-1.1 {configuration options} -body { + .mb configure -activebackground #012345 + .mb cget -activebackground +} -cleanup { + .mb configure -activebackground [lindex [.mb configure -activebackground] 3] +} -result {#012345} +test menubutton-1.2 {configuration options} -body { + .mb configure -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.3 {configuration options} -body { + .mb configure -activeforeground #ff0000 + .mb cget -activeforeground +} -cleanup { + .mb configure -activeforeground [lindex [.mb configure -activeforeground] 3] +} -result {#ff0000} +test menubutton-1.4 {configuration options} -body { + .mb configure -activeforeground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.5 {configuration options} -body { + .mb configure -anchor nw + .mb cget -anchor +} -cleanup { + .mb configure -anchor [lindex [.mb configure -anchor] 3] +} -result {nw} +test menubutton-1.6 {configuration options} -body { + .mb configure -anchor bogus +} -returnCodes error -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} +test menubutton-1.7 {configuration options} -body { + .mb configure -background #ff0000 + .mb cget -background +} -cleanup { + .mb configure -background [lindex [.mb configure -background] 3] +} -result {#ff0000} +test menubutton-1.8 {configuration options} -body { + .mb configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.9 {configuration options} -body { + .mb configure -bd 4 + .mb cget -bd +} -cleanup { + .mb configure -bd [lindex [.mb configure -bd] 3] +} -result {4} +test menubutton-1.10 {configuration options} -body { + .mb configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test menubutton-1.11 {configuration options} -body { + .mb configure -bg #ff0000 + .mb cget -bg +} -cleanup { + .mb configure -bg [lindex [.mb configure -bg] 3] +} -result {#ff0000} +test menubutton-1.12 {configuration options} -body { + .mb configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test menubutton-1.13 {configuration options} -body { + .mb configure -bitmap questhead + .mb cget -bitmap +} -cleanup { + .mb configure -bitmap [lindex [.mb configure -bitmap] 3] +} -result {questhead} +test menubutton-1.14 {configuration options} -body { + .mb configure -bitmap badValue +} -returnCodes error -result {bitmap "badValue" not defined} +test menubutton-1.15 {configuration options} -body { + .mb configure -borderwidth 1.3 + .mb cget -borderwidth +} -cleanup { + .mb configure -borderwidth [lindex [.mb configure -borderwidth] 3] +} -result {1} +test menubutton-1.16 {configuration options} -body { + .mb configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test menubutton-1.17 {configuration options} -body { + .mb configure -cursor arrow + .mb cget -cursor +} -cleanup { + .mb configure -cursor [lindex [.mb configure -cursor] 3] +} -result {arrow} +test menubutton-1.18 {configuration options} -body { + .mb configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test menubutton-1.19 {configuration options} -body { + .mb configure -direction below + .mb cget -direction +} -cleanup { + .mb configure -direction [lindex [.mb configure -direction] 3] +} -result {below} +test menubutton-1.20 {configuration options} -body { + .mb configure -direction badValue +} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} +test menubutton-1.21 {configuration options} -body { + .mb configure -disabledforeground #00ff00 + .mb cget -disabledforeground +} -cleanup { + .mb configure -disabledforeground [lindex [.mb configure -disabledforeground] 3] +} -result {#00ff00} +test menubutton-1.22 {configuration options} -body { + .mb configure -disabledforeground xyzzy +} -returnCodes error -result {unknown color name "xyzzy"} +test menubutton-1.23 {configuration options} -body { + .mb configure -fg #110022 + .mb cget -fg +} -cleanup { + .mb configure -fg [lindex [.mb configure -fg] 3] +} -result {#110022} +test menubutton-1.24 {configuration options} -body { + .mb configure -fg bogus +} -returnCodes error -result {unknown color name "bogus"} +test menubutton-1.25 {configuration options} -body { + .mb configure -font {Helvetica 12} + .mb cget -font +} -cleanup { + .mb configure -font [lindex [.mb configure -font] 3] +} -result {Helvetica 12} +test menubutton-1.26 {configuration options} -body { + .mb configure -foreground #110022 + .mb cget -foreground +} -cleanup { + .mb configure -foreground [lindex [.mb configure -foreground] 3] +} -result {#110022} +test menubutton-1.27 {configuration options} -body { + .mb configure -foreground bogus +} -returnCodes error -result {unknown color name "bogus"} +test menubutton-1.28 {configuration options} -body { + .mb configure -height 18 + .mb cget -height +} -cleanup { + .mb configure -height [lindex [.mb configure -height] 3] +} -result {18} +test menubutton-1.29 {configuration options} -body { + .mb configure -height 20.0 +} -returnCodes error -result {expected integer but got "20.0"} +test menubutton-1.30 {configuration options} -body { + .mb configure -highlightbackground #112233 + .mb cget -highlightbackground +} -cleanup { + .mb configure -highlightbackground [lindex [.mb configure -highlightbackground] 3] +} -result {#112233} +test menubutton-1.31 {configuration options} -body { + .mb configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test menubutton-1.32 {configuration options} -body { + .mb configure -highlightcolor #110022 + .mb cget -highlightcolor +} -cleanup { + .mb configure -highlightcolor [lindex [.mb configure -highlightcolor] 3] +} -result {#110022} +test menubutton-1.33 {configuration options} -body { + .mb configure -highlightcolor bogus +} -returnCodes error -result {unknown color name "bogus"} +test menubutton-1.34 {configuration options} -body { + .mb configure -highlightthickness 18 + .mb cget -highlightthickness +} -cleanup { + .mb configure -highlightthickness [lindex [.mb configure -highlightthickness] 3] +} -result {18} +test menubutton-1.35 {configuration options} -body { + .mb configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test menubutton-1.36 {configuration options} -constraints { + testImageType +} -setup { + catch {image delete image1} + image create test image1 +} -body { + .mb configure -image image1 + .mb cget -image +} -cleanup { + .mb configure -image [lindex [.mb configure -image] 3] image create test image1 -} +} -result {image1} +test menubutton-1.37 {configuration options} -setup { + catch {image delete bogus} +} -body { + .mb configure -image bogus +} -cleanup { + .mb configure -image [lindex [.mb configure -image] 3] +} -returnCodes error -result {image "bogus" doesn't exist} +test menubutton-1.38 {configuration options} -body { + .mb configure -indicatoron yes + .mb cget -indicatoron +} -cleanup { + .mb configure -indicatoron [lindex [.mb configure -indicatoron] 3] +} -result {1} +test menubutton-1.39 {configuration options} -body { + .mb configure -indicatoron no_way +} -returnCodes error -result {expected boolean value but got "no_way"} +test menubutton-1.40 {configuration options} -body { + .mb configure -justify right + .mb cget -justify +} -cleanup { + .mb configure -justify [lindex [.mb configure -justify] 3] +} -result {right} +test menubutton-1.41 {configuration options} -body { + .mb configure -justify bogus +} -returnCodes error -result {bad justification "bogus": must be left, right, or center} +test menubutton-1.42 {configuration options} -body { + .mb configure -menu {any old string} + .mb cget -menu +} -cleanup { + .mb configure -menu [lindex [.mb configure -menu] 3] +} -result {any old string} +test menubutton-1.43 {configuration options} -body { + .mb configure -padx 12 + .mb cget -padx +} -cleanup { + .mb configure -padx [lindex [.mb configure -padx] 3] +} -result {12} +test menubutton-1.44 {configuration options} -body { + .mb configure -padx 420x +} -returnCodes error -result {bad screen distance "420x"} +test menubutton-1.45 {configuration options} -body { + .mb configure -pady 12 + .mb cget -pady +} -cleanup { + .mb configure -pady [lindex [.mb configure -pady] 3] +} -result {12} +test menubutton-1.46 {configuration options} -body { + .mb configure -pady 420x +} -returnCodes error -result {bad screen distance "420x"} +test menubutton-1.47 {configuration options} -body { + .mb configure -relief groove + .mb cget -relief +} -cleanup { + .mb configure -relief [lindex [.mb configure -relief] 3] +} -result {groove} +test menubutton-1.48 {configuration options} -body { + .mb configure -relief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test menubutton-1.49 {configuration options} -body { + .mb configure -state normal + .mb cget -state +} -cleanup { + .mb configure -state [lindex [.mb configure -state] 3] +} -result {normal} +test menubutton-1.50 {configuration options} -body { + .mb configure -state bogus +} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal} +test menubutton-1.51 {configuration options} -body { + .mb configure -takefocus {any string} + .mb cget -takefocus +} -cleanup { + .mb configure -takefocus [lindex [.mb configure -takefocus] 3] +} -result {any string} +test menubutton-1.52 {configuration options} -body { + .mb configure -text {Sample text} + .mb cget -text +} -cleanup { + .mb configure -text [lindex [.mb configure -text] 3] +} -result {Sample text} +test menubutton-1.53 {configuration options} -body { + .mb configure -textvariable i + .mb cget -textvariable +} -cleanup { + .mb configure -textvariable [lindex [.mb configure -textvariable] 3] +} -result {i} +test menubutton-1.54 {configuration options} -body { + .mb configure -underline 5 + .mb cget -underline +} -cleanup { + .mb configure -underline [lindex [.mb configure -underline] 3] +} -result {5} +test menubutton-1.55 {configuration options} -body { + .mb configure -underline 3p +} -returnCodes error -result {expected integer but got "3p"} +test menubutton-1.56 {configuration options} -body { + .mb configure -width 402 + .mb cget -width +} -cleanup { + .mb configure -width [lindex [.mb configure -width] 3] +} -result {402} +test menubutton-1.57 {configuration options} -body { + .mb configure -width 3p +} -returnCodes error -result {expected integer but got "3p"} +test menubutton-1.58 {configuration options} -body { + .mb configure -wraplength 100 + .mb cget -wraplength +} -cleanup { + .mb configure -wraplength [lindex [.mb configure -wraplength] 3] +} -result {100} +test menubutton-1.59 {configuration options} -body { + .mb configure -wraplength 6x +} -returnCodes error -result {bad screen distance "6x"} + + +deleteWindows menubutton .mb -text "Test" pack .mb update -set i 1 -foreach test { - {-activebackground #012345 #012345 non-existent - {unknown color name "non-existent"}} - {-activeforeground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-anchor nw nw bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-bitmap questhead questhead badValue {bitmap "badValue" not defined}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-direction below below badValue {bad direction "badValue": must be above, below, flush, left, or right}} - {-disabledforeground #00ff00 #00ff00 xyzzy {unknown color name "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font {Helvetica 12} {Helvetica 12} {} {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-height 18 18 20.0 {expected integer but got "20.0"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #110022 #110022 bogus {unknown color name "bogus"}} - {-highlightthickness 18 18 badValue {bad screen distance "badValue"}} - {-image image1 image1 bogus {image "bogus" doesn't exist}} - {-indicatoron yes 1 no_way {expected boolean value but got "no_way"}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-menu "any old string" "any old string" {} {}} - {-padx 12 12 420x {bad screen distance "420x"}} - {-pady 12 12 420x {bad screen distance "420x"}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-state normal normal bogus {bad state "bogus": must be active, disabled, or normal}} - {-takefocus "any string" "any string" {} {}} - {-text "Sample text" {Sample text} {} {}} - {-textvariable i i {} {}} - {-underline 5 5 3p {expected integer but got "3p"}} - {-width 402 402 3p {expected integer but got "3p"}} - {-wraplength 100 100 6x {bad screen distance "6x"}} -} { - set name [lindex $test 0] - test menubutton-1.$i {configuration options} testImageType { - .mb configure $name [lindex $test 1] - lindex [.mb configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test menubutton-1.$i {configuration options} { - list [catch {.mb configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .mb configure $name [lindex [.mb configure $name] 3] - incr i -} - -test menubutton-2.1 {Tk_MenubuttonCmd procedure} { - list [catch {menubutton} msg] $msg -} {1 {wrong # args: should be "menubutton pathName ?options?"}} -test menubutton-2.2 {Tk_MenubuttonCmd procedure} { - list [catch {menubutton foo} msg] $msg -} {1 {bad window path name "foo"}} -test menubutton-2.3 {Tk_MenubuttonCmd procedure} { +test menubutton-2.1 {Tk_MenubuttonCmd procedure} -body { + menubutton +} -returnCodes error -result {wrong # args: should be "menubutton pathName ?-option value ...?"} +test menubutton-2.2 {Tk_MenubuttonCmd procedure} -body { + menubutton foo +} -returnCodes error -result {bad window path name "foo"} +test menubutton-2.3 {Tk_MenubuttonCmd procedure} -body { catch {destroy .mb} menubutton .mb winfo class .mb -} {Menubutton} -test menubutton-2.4 {Tk_ButtonCmd procedure} { - catch {destroy .mb} - list [catch {menubutton .mb -gorp foo} msg] $msg [winfo exists .mb] -} {1 {unknown option "-gorp"} 0} +} -result {Menubutton} +test menubutton-2.4 {Tk_ButtonCmd procedure} -setup { + destroy .mb +} -body { + menubutton .mb -gorp foo +} -returnCodes error -result {unknown option "-gorp"} +test menubutton-2.5 {Tk_ButtonCmd procedure} -setup { + destroy .mb +} -body { + catch {menubutton .mb -gorp foo} + winfo exists .mb +} -result 0 -catch {destroy .mb} + +deleteWindows menubutton .mb -text "Test Menu" pack .mb -test menubutton-3.1 {MenuButtonWidgetCmd procedure} { - list [catch {.mb} msg] $msg -} {1 {wrong # args: should be ".mb option ?arg arg ...?"}} -test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb c} msg] $msg -} {1 {ambiguous option "c": must be cget or configure}} -test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb cget} msg] $msg -} {1 {wrong # args: should be ".mb cget option"}} -test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb cget a b} msg] $msg -} {1 {wrong # args: should be ".mb cget option"}} -test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} { - list [catch {.mb cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} { +test menubutton-3.1 {MenuButtonWidgetCmd procedure} -body { + .mb +} -returnCodes error -result {wrong # args: should be ".mb option ?arg ...?"} +test menubutton-3.2 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb c +} -returnCodes error -result {ambiguous option "c": must be cget or configure} +test menubutton-3.3 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb cget +} -returnCodes error -result {wrong # args: should be ".mb cget option"} +test menubutton-3.4 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb cget a b +} -returnCodes error -result {wrong # args: should be ".mb cget option"} +test menubutton-3.5 {ButtonWidgetCmd procedure, "cget" option} -body { + .mb cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test menubutton-3.6 {ButtonWidgetCmd procedure, "cget" option} -body { .mb configure -highlightthickness 3 .mb cget -highlightthickness -} {3} -test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} { +} -result {3} +test menubutton-3.7 {ButtonWidgetCmd procedure, "configure" option} -body { llength [.mb configure] -} {33} -test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.mb configure -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.mb co -bg #ffffff -fg} msg] $msg -} {1 {value for "-fg" missing}} -test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} { +} -result {33} +test menubutton-3.8 {ButtonWidgetCmd procedure, "configure" option} -body { + .mb configure -gorp +} -returnCodes error -result {unknown option "-gorp"} +test menubutton-3.9 {ButtonWidgetCmd procedure, "configure" option} -body { + .mb co -bg #ffffff -fg +} -returnCodes error -result {value for "-fg" missing} +test menubutton-3.10 {ButtonWidgetCmd procedure, "configure" option} -body { .mb configure -fg #123456 .mb configure -bg #654321 lindex [.mb configure -fg] 4 -} {#123456} -test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} { - list [catch {.mb foobar} msg] $msg -} {1 {bad option "foobar": must be cget or configure}} +} -result {#123456} +test menubutton-3.11 {ButtonWidgetCmd procedure, "configure" option} -body { + .mb foobar +} -returnCodes error -result {bad option "foobar": must be cget or configure} +deleteWindows # XXX Need to add tests for several procedures here. The tests for XXX # XXX ConfigureMenuButton aren't complete either. XXX -test menubutton-4.1 {ConfigureMenuButton procedure} { - catch {destroy .mb1} +test menubutton-4.1 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { + button .mb1 -text "Menubutton 1" + .mb1 configure -width 1i +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "1i"} +test menubutton-4.2 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { button .mb1 -text "Menubutton 1" - list [catch {.mb1 configure -width 1i} msg] $msg $errorInfo -} {1 {expected integer but got "1i"} {expected integer but got "1i" + catch {.mb1 configure -width 1i} + return $errorInfo +} -cleanup { + deleteWindows +} -result {expected integer but got "1i" (processing -width option) invoked from within -".mb1 configure -width 1i"}} -test menubutton-4.2 {ConfigureMenuButton procedure} { - catch {destroy .mb1} +".mb1 configure -width 1i"} + +test menubutton-4.3 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { button .mb1 -text "Menubutton 1" - list [catch {.mb1 configure -height 0.5c} msg] $msg $errorInfo -} {1 {expected integer but got "0.5c"} {expected integer but got "0.5c" + .mb1 configure -height 0.5c +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "0.5c"} +test menubutton-4.4 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { + button .mb1 -text "Menubutton 1" + catch {.mb1 configure -height 0.5c} + return $errorInfo +} -cleanup { + deleteWindows +} -result {expected integer but got "0.5c" (processing -height option) invoked from within -".mb1 configure -height 0.5c"}} -test menubutton-4.3 {ConfigureMenuButton procedure} { - catch {destroy .mb1} +".mb1 configure -height 0.5c"} + +test menubutton-4.5 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { + button .mb1 -bitmap questhead + .mb1 configure -width abc +} -cleanup { + deleteWindows +} -returnCodes error -result {bad screen distance "abc"} +test menubutton-4.6 {ConfigureMenuButton procedure} -setup { + deleteWindows +} -body { button .mb1 -bitmap questhead - list [catch {.mb1 configure -width abc} msg] $msg $errorInfo -} {1 {bad screen distance "abc"} {bad screen distance "abc" + catch {.mb1 configure -width abc} + return $errorInfo +} -cleanup { + deleteWindows +} -result {bad screen distance "abc" (processing -width option) invoked from within -".mb1 configure -width abc"}} -test menubutton-4.4 {ConfigureMenuButton procedure} testImageType { - catch {destroy .mb1} - eval image delete [image names] +".mb1 configure -width abc"} + +test menubutton-4.7 {ConfigureMenuButton procedure} -constraints { + testImageType +} -setup { + deleteWindows + imageCleanup +} -body { image create test image1 button .mb1 -image image1 - list [catch {.mb1 configure -height 0.5x} msg] $msg $errorInfo -} {1 {bad screen distance "0.5x"} {bad screen distance "0.5x" + .mb1 configure -height 0.5x +} -cleanup { + deleteWindows + imageCleanup +} -returnCodes error -result {bad screen distance "0.5x"} +test menubutton-4.8 {ConfigureMenuButton procedure} -constraints { + testImageType +} -setup { + deleteWindows + imageCleanup +} -body { + image create test image1 + button .mb1 -image image1 + catch {.mb1 configure -height 0.5x} + return $errorInfo +} -cleanup { + deleteWindows + imageCleanup +} -result {bad screen distance "0.5x" (processing -height option) invoked from within -".mb1 configure -height 0.5x"}} -test menubutton-4.5 {ConfigureMenuButton procedure} {nonPortable fonts} { - catch {destroy .mb1} +".mb1 configure -height 0.5x"} + +test menubutton-4.9 {ConfigureMenuButton procedure} -constraints { + nonPortable fonts +} -setup { + deleteWindows +} -body { button .mb1 -text "Sample text" -width 10 -height 2 pack .mb1 set result "[winfo reqwidth .mb1] [winfo reqheight .mb1]" .mb1 configure -bitmap questhead lappend result [winfo reqwidth .mb1] [winfo reqheight .mb1] -} {102 46 20 12} -test menubutton-4.6 {ConfigureMenuButton procedure - bad direction} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {102 46 20 12} + +test menubutton-4.10 {ConfigureMenuButton procedure - bad direction} -setup { + deleteWindows +} -body { + menubutton .mb -text "Test" + .mb configure -direction badValue +} -cleanup { + deleteWindows +} -returnCodes error -result {bad direction "badValue": must be above, below, flush, left, or right} +test menubutton-4.11 {ConfigureMenuButton procedure - bad direction} -setup { + deleteWindows +} -body { menubutton .mb -text "Test" - list [catch {.mb configure -direction badValue} msg] $msg \ - [.mb cget -direction] [destroy .mb] -} {1 {bad direction "badValue": must be above, below, flush, left, or right} below {}} + catch {.mb configure -direction badValue} + list [.mb cget -direction] [destroy .mb] +} -cleanup { + deleteWindows +} -result {below {}} + + # XXX Need to add tests for several procedures here. XXX -test menubutton-5.1 {MenuButtonEventProc procedure} { +test menubutton-5.1 {MenuButtonEventProc procedure} -setup { deleteWindows + set x {} +} -body { menubutton .mb1 -bg #543210 rename .mb1 .mb2 - set x {} lappend x [winfo children .] lappend x [.mb2 cget -bg] destroy .mb1 lappend x [info command .mb*] [winfo children .] -} {.mb1 #543210 {} {}} +} -cleanup { + deleteWindows +} -result {.mb1 #543210 {} {}} + -test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} { +test menubutton-6.1 {MenuButtonCmdDeletedProc procedure} -setup { deleteWindows +} -body { menubutton .mb1 rename .mb1 {} list [info command .mb*] [winfo children .] -} {{} {}} +} -cleanup { + deleteWindows +} -result {{} {}} -test menubutton-7.1 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} + +test menubutton-7.1 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 4 -highlightthickness 0 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {38 23} -test menubutton-7.2 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + imageCleanup +} -result {38 23} +test menubutton-7.2 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 1 -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {36 21} -test menubutton-7.3 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + imageCleanup +} -result {36 21} +test menubutton-7.3 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 0 -highlightthickness 2 -padx 5 -pady 5 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {34 19} -test menubutton-7.4 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + imageCleanup +} -result {34 19} +test menubutton-7.4 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 2 -relief raised -width 40 \ - -highlightthickness 2 + -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {48 23} -test menubutton-7.5 {ComputeMenuButtonGeometry procedure} testImageType { - catch {destroy .mb} +} -cleanup { + deleteWindows + imageCleanup +} -result {48 23} +test menubutton-7.5 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType +} -setup { + deleteWindows + image create test image1 +} -body { menubutton .mb -image image1 -bd 2 -relief raised -height 30 \ - -highlightthickness 2 + -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {38 38} -test menubutton-7.6 {ComputeMenuButtonGeometry procedure} { - catch {destroy .mb} +} -cleanup { + deleteWindows + imageCleanup +} -result {38 38} +test menubutton-7.6 {ComputeMenuButtonGeometry procedure} -setup { + deleteWindows +} -body { menubutton .mb -bitmap question -bd 2 -relief raised \ - -highlightthickness 2 + -highlightthickness 2 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {25 35} -test menubutton-7.7 {ComputeMenuButtonGeometry procedure} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {25 35} +test menubutton-7.7 {ComputeMenuButtonGeometry procedure} -setup { + deleteWindows +} -body { menubutton .mb -bitmap question -bd 2 -relief raised -width 40 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {46 33} -test menubutton-7.8 {ComputeMenuButtonGeometry procedure} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {46 33} +test menubutton-7.8 {ComputeMenuButtonGeometry procedure} -setup { + deleteWindows +} -body { menubutton .mb -bitmap question -bd 2 -relief raised -height 50 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {23 56} -test menubutton-7.9 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {23 56} +test menubutton-7.9 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -padx 0 -pady 0 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {42 20} -test menubutton-7.10 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {42 20} +test menubutton-7.10 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -width 20 \ - -padx 0 -pady 0 -highlightthickness 1 + -padx 0 -pady 0 -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {146 20} -test menubutton-7.11 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {146 20} +test menubutton-7.11 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -height 2 \ - -padx 0 -pady 0 -highlightthickness 1 + -padx 0 -pady 0 -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {42 34} -test menubutton-7.12 {ComputeMenuButtonGeometry procedure} {fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {42 34} +test menubutton-7.12 {ComputeMenuButtonGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised -padx 10 -pady 5 \ - -highlightthickness 1 + -highlightthickness 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {62 30} -test menubutton-7.13 {ComputeMenuButtonGeometry procedure} {nonPortable fonts} { - catch {destroy .mb} +} -cleanup { + deleteWindows +} -result {62 30} +test menubutton-7.13 {ComputeMenuButtonGeometry procedure} -constraints { + nonPortable fonts +} -setup { + deleteWindows +} -body { menubutton .mb -text String -bd 2 -relief raised \ - -highlightthickness 1 -indicatoron 1 + -highlightthickness 1 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {78 28} -test menubutton-7.14 {ComputeMenuButtonGeometry procedure} {testImageType unix nonPortable} { +} -cleanup { + deleteWindows +} -result {78 28} +test menubutton-7.14 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType unix nonPortable +} -setup { + deleteWindows + image create test image1 +} -body { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. - catch {destroy .mb} menubutton .mb -image image1 -bd 2 -relief raised \ - -highlightthickness 2 -indicatoron 1 + -highlightthickness 2 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {64 23} -test menubutton-7.15 {ComputeMenuButtonGeometry procedure} {testImageType win nonPortable} { +} -cleanup { + deleteWindows + imageCleanup +} -result {64 23} +test menubutton-7.15 {ComputeMenuButtonGeometry procedure} -constraints { + testImageType win nonPortable +} -setup { + deleteWindows + image create test image1 +} -body { # The following test is non-portable because the indicator's pixel # size varies to maintain constant absolute size. - catch {destroy .mb} menubutton .mb -image image1 -bd 2 -relief raised \ - -highlightthickness 2 -indicatoron 1 + -highlightthickness 2 -indicatoron 1 pack .mb list [winfo reqwidth .mb] [winfo reqheight .mb] -} {65 23} +} -cleanup { + deleteWindows + imageCleanup +} -result {65 23} -set l [interp hidden] -deleteWindows -test menubutton-8.1 {menubutton vs hidden commands} { - catch {destroy .mb} +test menubutton-8.1 {menubutton vs hidden commands} -body { + set l [interp hidden] + deleteWindows menubutton .mb interp hide {} .mb destroy .mb - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -result 1 + + -eval image delete [image names] deleteWindows option clear +imageFinish # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/message.test b/tests/message.test index 93344c4..dcffc72 100644 --- a/tests/message.test +++ b/tests/message.test @@ -6,115 +6,469 @@ # Copyright (c) 1998-2000 by Ajuba Solutions. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* tcltest::loadTestedCommands +eval tcltest::configure $argv + + +test message-1.1 {configuration option: "anchor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -anchor w + .m cget -anchor +} -cleanup { + destroy .m +} -result {w} +test message-1.2 {configuration option: "anchor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -anchor bogus +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center} + +test message-1.3 {configuration option: "aspect"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -aspect 3 + .m cget -aspect +} -cleanup { + destroy .m +} -result {3} +test message-1.4 {configuration option: "aspect"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -aspect bogus +} -cleanup { + destroy .m +} -returnCodes {error} -result {expected integer but got "bogus"} + +test message-1.5 {configuration option: "background"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -background #ff0000 + .m cget -background +} -cleanup { + destroy .m +} -result {#ff0000} +test message-1.6 {configuration option: "background"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -background non-existent +} -cleanup { + destroy .m +} -returnCodes {error} -result {unknown color name "non-existent"} + +test message-1.7 {configuration option: "bd"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -bd 4 + .m cget -bd +} -cleanup { + destroy .m +} -result {4} +test message-1.8 {configuration option: "bd"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -bd badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad screen distance "badValue"} + +test message-1.9 {configuration option: "bg"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -bg #ff0000 + .m cget -bg +} -cleanup { + destroy .m +} -result {#ff0000} +test message-1.10 {configuration option: "bg"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -bg non-existent +} -cleanup { + destroy .m +} -returnCodes {error} -result {unknown color name "non-existent"} + +test message-1.11 {configuration option: "borderwidth"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -borderwidth 1.3 + .m cget -borderwidth +} -cleanup { + destroy .m +} -result {1} +test message-1.12 {configuration option: "borderwidth"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -borderwidth badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad screen distance "badValue"} + +test message-1.13 {configuration option: "cursor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -cursor arrow + .m cget -cursor +} -cleanup { + destroy .m +} -result {arrow} +test message-1.14 {configuration option: "cursor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -cursor badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad cursor spec "badValue"} + +test message-1.15 {configuration option: "fg"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -fg #00ff00 + .m cget -fg +} -cleanup { + destroy .m +} -result {#00ff00} +test message-1.16 {configuration option: "fg"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -fg badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {unknown color name "badValue"} + +test message-1.17 {configuration option: "font"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -font fixed + .m cget -font +} -cleanup { + destroy .m +} -result {fixed} +test message-1.18 {configuration option: "font"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -font {} +} -cleanup { + destroy .m +} -returnCodes {error} -result {font "" doesn't exist} + +test message-1.19 {configuration option: "-foreground"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -foreground green + .m cget -foreground +} -cleanup { + destroy .m +} -result {green} +test message-1.20 {configuration option: "-foreground"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -foreground badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {unknown color name "badValue"} -option add *Message.borderWidth 2 -option add *Message.highlightThickness 2 -option add *Message.font {Helvetica -12 bold} - -message .m -pack .m -update -set i 0 -foreach test { - {-anchor w w bogus {bad anchor "bogus": must be n, ne, e, se, s, sw, w, nw, or center}} - {-aspect 3 3 bogus {expected integer but got "bogus"}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}} - {-font fixed fixed {} {font "" doesn't exist}} - {-foreground green green badValue {unknown color name "badValue"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 2 2 badValue {bad screen distance "badValue"}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-padx 12m 12m 420x {bad screen distance "420x"}} - {-pady 12m 12m 420x {bad screen distance "420x"}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-text "Sample text" {Sample text} {} {} {1 1 1 1}} - {-textvariable i i {} {} {1 1 1 1}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - set name [lindex $test 0] - test message-1.$i {configuration options} { - .m configure $name [lindex $test 1] - lindex [.m configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test message-1.$i {configuration options} { - list [catch {.m configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .m configure $name [lindex [.m configure $name] 3] - incr i -} -destroy .m - -test message-2.1 {Tk_MessageObjCmd procedure} { - list [catch {message} msg] $msg -} {1 {wrong # args: should be "message pathName ?options?"}} -test message-2.2 {Tk_MessageObjCmd procedure} { - list [catch {message foo} msg] $msg [winfo child .] -} {1 {bad window path name "foo"} {}} -test message-2.3 {Tk_MessageObjCmd procedure} { - list [catch {message .s -gorp dumb} msg] $msg [winfo child .] -} {1 {unknown option "-gorp"} {}} - -test message-3.1 {MessageWidgetObjCmd procedure} { +test message-1.21 {configuration option: "highlightbackground"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -highlightbackground #112233 + .m cget -highlightbackground +} -cleanup { + destroy .m +} -result {#112233} +test message-1.22 {configuration option: "highlightbackground"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -highlightbackground ugly +} -cleanup { + destroy .m +} -returnCodes {error} -result {unknown color name "ugly"} + +test message-1.23 {configuration option: "highlightcolor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -highlightcolor #123456 + .m cget -highlightcolor +} -cleanup { + destroy .m +} -result {#123456} +test message-1.24 {configuration option: "highlightcolor"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -highlightcolor non-existent +} -cleanup { + destroy .m +} -returnCodes {error} -result {unknown color name "non-existent"} + +test message-1.25 {configuration option: "highlightthickness"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -highlightthickness 2 + .m cget -highlightthickness +} -cleanup { + destroy .m +} -result {2} +test message-1.26 {configuration option: "highlightthickness"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -highlightthickness badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad screen distance "badValue"} + +test message-1.27 {configuration option: "justify"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -justify right + .m cget -justify +} -cleanup { + destroy .m +} -result {right} +test message-1.28 {configuration option: "justify"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -justify bogus +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} + +test message-1.29 {configuration option: "padx"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -padx 12m + .m cget -padx +} -cleanup { + destroy .m +} -result {12m} +test message-1.30 {configuration option: "padx"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -padx 420x +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad screen distance "420x"} + +test message-1.31 {configuration option: "pady"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -pady 12m + .m cget -pady +} -cleanup { + destroy .m +} -result {12m} +test message-1.32 {configuration option: "pady"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -pady 420x +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad screen distance "420x"} + +test message-1.33 {configuration option: "relief"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -relief ridge + .m cget -relief +} -cleanup { + destroy .m +} -result {ridge} +test message-1.34 {configuration option: "relief"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -relief badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} + +test message-1.35 {configuration options: "text"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -text "Sample text" + .m cget -text +} -cleanup { + destroy .m +} -result {Sample text} + +test message-1.36 {configuration option: "textvariable"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -textvariable i + .m cget -textvariable +} -cleanup { + destroy .m +} -result {i} + +test message-1.37 {configuration option: "width"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -width 2 + .m cget -width +} -cleanup { + destroy .m +} -result {2} +test message-1.38 {configuration option: "width"} -setup { + message .m -borderwidth 2 -highlightthickness 2 -font {Helvetica -12 bold} + pack .m + update +} -body { + .m configure -width badValue +} -cleanup { + destroy .m +} -returnCodes {error} -result {bad screen distance "badValue"} + + +test message-2.1 {Tk_MessageObjCmd procedure} -body { + message +} -returnCodes {error} -result {wrong # args: should be "message pathName ?-option value ...?"} + +test message-2.2 {Tk_MessageObjCmd procedure} -body { + message foo +} -returnCodes {error} -result {bad window path name "foo"} +test message-2.3 {Tk_MessageObjCmd procedure} -body { + catch {message foo} + winfo child . +} -result {} + +test message-2.4 {Tk_MessageObjCmd procedure} -body { + message .s -gorp dump +} -returnCodes {error} -result {unknown option "-gorp"} +test message-2.5 {Tk_MessageObjCmd procedure} -body { + catch {message .s -gorp dump} + winfo child . +} -result {} + + +test message-3.1 {MessageWidgetObjCmd procedure} -setup { message .m - set result [list [catch {.m} msg] $msg] +} -body { + .m +} -cleanup { destroy .m - set result -} {1 {wrong # args: should be ".m option ?arg arg ...?"}} -test message-3.2 {MessageWidgetObjCmd procedure, "cget"} { +} -returnCodes error -result {wrong # args: should be ".m option ?arg ...?"} +test message-3.2 {MessageWidgetObjCmd procedure, "cget"} -setup { message .m - set result [list [catch {.m cget} msg] $msg] +} -body { + .m cget +} -cleanup { destroy .m - set result -} {1 {wrong # args: should be ".m cget option"}} -test message-3.3 {MessageWidgetObjCmd procedure, "cget"} { +} -returnCodes error -result {wrong # args: should be ".m cget option"} +test message-3.3 {MessageWidgetObjCmd procedure, "cget"} -setup { message .m - set result [list [catch {.m cget -gorp} msg] $msg] +} -body { + .m cget -gorp +} -cleanup { destroy .m - set result -} {1 {unknown option "-gorp"}} -test message-3.4 {MessageWidgetObjCmd procedure, "cget"} { +} -returnCodes error -result {unknown option "-gorp"} + +test message-3.4 {MessageWidgetObjCmd procedure, "configure"} -setup { message .m +} -body { .m configure -text foobar - set result [.m cget -text] + lindex [.m configure -text] 4 +} -cleanup { destroy .m - set result -} "foobar" -test message-3.5 {MessageWidgetObjCmd procedure, "configure"} { +} -result {foobar} +test message-3.5 {MessageWidgetObjCmd procedure, "configure"} -setup { message .m - set result [llength [.m configure]] +} -body { + llength [.m configure] +} -cleanup { destroy .m - set result -} 21 -test message-3.6 {MessageWidgetObjCmd procedure, "configure"} { +} -result {21} +test message-3.6 {MessageWidgetObjCmd procedure, "configure"} -setup { message .m - set result [list [catch {.m configure -foo} msg] $msg] +} -body { + .m configure -foo +} -cleanup { destroy .m - set result -} {1 {unknown option "-foo"}} -test message-3.7 {MessageWidgetObjCmd procedure, "configure"} { +} -returnCodes error -result {unknown option "-foo"} +test message-3.7 {MessageWidgetObjCmd procedure, "configure"} -setup { message .m +} -body { .m configure -bd 4 .m configure -bg #ffffff - set result [lindex [.m configure -bd] 4] + lindex [.m configure -bd] 4 +} -cleanup { destroy .m - set result -} {4} +} -result {4} -# cleanup cleanupTests return diff --git a/tests/msgbox.test b/tests/msgbox.test index ec98c89..643ae2c 100644 --- a/tests/msgbox.test +++ b/tests/msgbox.test @@ -5,65 +5,79 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -test msgbox-1.1 {tk_messageBox command} { - list [catch {tk_messageBox -foo} msg] $msg -} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}} -test msgbox-1.2 {tk_messageBox command} { - list [catch {tk_messageBox -foo bar} msg] $msg -} {1 {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type}} - -catch {tk_messageBox -foo bar} msg -regsub -all , $msg "" options -regsub \"-foo\" $options "" options - -foreach option $options { - if {[string index $option 0] eq "-"} { - test msgbox-1.3$option {tk_messageBox command} -body { - tk_messageBox $option - } -returnCodes error -result "value for \"$option\" missing" - } -} -test msgbox-1.4 {tk_messageBox command} { - list [catch {tk_messageBox -default} msg] $msg -} {1 {value for "-default" missing}} +test msgbox-1.1 {tk_messageBox command} -body { + tk_messageBox -foo +} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type} +test msgbox-1.2 {tk_messageBox command} -body { + tk_messageBox -foo bar +} -returnCodes error -result {bad option "-foo": must be -default, -detail, -icon, -message, -parent, -title, or -type} -test msgbox-1.5 {tk_messageBox command} { - list [catch {tk_messageBox -type foo} msg] $msg -} {1 {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel}} +test msgbox-1.3 {tk_messageBox command} -body { + tk_messageBox -default +} -returnCodes error -result {value for "-default" missing} +test msgbox-1.4 {tk_messageBox command} -body { + tk_messageBox -detail +} -returnCodes error -result {value for "-detail" missing} +test msgbox-1.5 {tk_messageBox command} -body { + tk_messageBox -icon +} -returnCodes error -result {value for "-icon" missing} +test msgbox-1.6 {tk_messageBox command} -body { + tk_messageBox -message +} -returnCodes error -result {value for "-message" missing} +test msgbox-1.7 {tk_messageBox command} -body { + tk_messageBox -parent +} -returnCodes error -result {value for "-parent" missing} +test msgbox-1.8 {tk_messageBox command} -body { + tk_messageBox -title +} -returnCodes error -result {value for "-title" missing} +test msgbox-1.9 {tk_messageBox command} -body { + tk_messageBox -type +} -returnCodes error -result {value for "-type" missing} -proc createPlatformMsg {val} { - global tcl_platform - if {$tcl_platform(platform) == "unix"} { - return "invalid default button \"$val\"" - } - return "bad -default value \"$val\": must be abort, retry, ignore, ok, cancel, no, or yes" -} +test msgbox-1.10 {tk_messageBox command} -body { + tk_messageBox -default +} -returnCodes error -result {value for "-default" missing} + +test msgbox-1.11 {tk_messageBox command} -body { + tk_messageBox -type foo +} -returnCodes error -result {bad -type value "foo": must be abortretryignore, ok, okcancel, retrycancel, yesno, or yesnocancel} -test msgbox-1.6 {tk_messageBox command} { - list [catch {tk_messageBox -default 1.1} msg] $msg -} [list 1 [createPlatformMsg "1.1"]] +test msgbox-1.12 {tk_messageBox command} -constraints unix -body { + tk_messageBox -default 1.1 +} -returnCodes error -result {invalid default button "1.1"} +test msgbox-1.13 {tk_messageBox command} -constraints macOrWin -body { + tk_messageBox -default 1.1 +} -returnCodes error -result {bad -default value "1.1": must be abort, retry, ignore, ok, cancel, no, or yes} -test msgbox-1.7 {tk_messageBox command} { - list [catch {tk_messageBox -default foo} msg] $msg -} [list 1 [createPlatformMsg "foo"]] +test msgbox-1.14 {tk_messageBox command} -constraints unix -body { + tk_messageBox -default foo +} -returnCodes error -result {invalid default button "foo"} +test msgbox-1.15 {tk_messageBox command} -constraints macOrWin -body { + tk_messageBox -default foo +} -returnCodes error -result {bad -default value "foo": must be abort, retry, ignore, ok, cancel, no, or yes} -test msgbox-1.8 {tk_messageBox command} { - list [catch {tk_messageBox -type yesno -default 3} msg] $msg -} [list 1 [createPlatformMsg "3"]] +test msgbox-1.16 {tk_messageBox command} -constraints unix -body { + tk_messageBox -type yesno -default 3 +} -returnCodes error -result {invalid default button "3"} +test msgbox-1.17 {tk_messageBox command} -constraints macOrWin -body { + tk_messageBox -type yesno -default 3 +} -returnCodes error -result {bad -default value "3": must be abort, retry, ignore, ok, cancel, no, or yes} -test msgbox-1.9 {tk_messageBox command} { - list [catch {tk_messageBox -icon foo} msg] $msg -} {1 {bad -icon value "foo": must be error, info, question, or warning}} +test msgbox-1.18 {tk_messageBox command} -body { + tk_messageBox -icon foo +} -returnCodes error -result {bad -icon value "foo": must be error, info, question, or warning} +test msgbox-1.19 {tk_messageBox command} -body { + tk_messageBox -parent foo.bar +} -returnCodes error -result {bad window path name "foo.bar"} -test msgbox-1.10 {tk_messageBox command} { - list [catch {tk_messageBox -parent foo.bar} msg] $msg -} {1 {bad window path name "foo.bar"}} +catch {tk_messageBox -foo bar} set isNative [expr {[info commands tk::MessageBox] == ""}] proc ChooseMsg {parent btn} { @@ -104,72 +118,332 @@ proc SendEventToMsg {parent btn type} { event generate $w <KeyPress> -keysym Return } } - -set parent . - -set specs { - {"abortretryignore" MB_ABORTRETRYIGNORE 3 {"abort" "retry" "ignore"}} - {"ok" MB_OK 1 {"ok" }} - {"okcancel" MB_OKCANCEL 2 {"ok" "cancel" }} - {"retrycancel" MB_RETRYCANCEL 2 {"retry" "cancel" }} - {"yesno" MB_YESNO 2 {"yes" "no" }} - {"yesnocancel" MB_YESNOCANCEL 3 {"yes" "no" "cancel"}} -} - # # Try out all combinations of (type) x (default button) and # (type) x (icon). # -set count 1 -foreach spec $specs { - set type [lindex $spec 0] - set buttons [lindex $spec 3] - - set button [lindex $buttons 0] - test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction { - ChooseMsg $parent $button - tk_messageBox -title Hi -message "Please press $button" \ - -type $type - } $button - incr count - - foreach icon {warning error info question} { - test msgbox-2.$count {tk_messageBox command -icon option} \ - nonUnixUserInteraction { - ChooseMsg $parent $button - tk_messageBox -title Hi -message "Please press $button" \ - -type $type -icon $icon - } $button - incr count - } +test msgbox-2.1 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . abort + tk_messageBox -title Hi -message "Please press abort" -type abortretryignore +} -result {abort} +test msgbox-2.2 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . abort + tk_messageBox -title Hi -message "Please press abort" \ + -type abortretryignore -icon warning +} -result {abort} +test msgbox-2.3 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . abort + tk_messageBox -title Hi -message "Please press abort" \ + -type abortretryignore -icon error +} -result {abort} +test msgbox-2.4 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . abort + tk_messageBox -title Hi -message "Please press abort" \ + -type abortretryignore -icon info +} -result {abort} +test msgbox-2.5 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . abort + tk_messageBox -title Hi -message "Please press abort" \ + -type abortretryignore -icon question +} -result {abort} +test msgbox-2.6 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . abort + tk_messageBox -title Hi -message "Please press abort" \ + -type abortretryignore -default abort +} -result {abort} +test msgbox-2.7 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" \ + -type abortretryignore -default retry +} -result {retry} +test msgbox-2.8 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ignore + tk_messageBox -title Hi -message "Please press ignore" \ + -type abortretryignore -default ignore +} -result {ignore} +test msgbox-2.9 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" -type ok +} -result {ok} +test msgbox-2.10 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -icon warning +} -result {ok} +test msgbox-2.11 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -icon error +} -result {ok} +test msgbox-2.12 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -icon info +} -result {ok} +test msgbox-2.13 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -icon question +} -result {ok} +test msgbox-2.14 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type ok -default ok +} -result {ok} +test msgbox-2.15 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" -type okcancel +} -result {ok} +test msgbox-2.16 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type okcancel -icon warning +} -result {ok} +test msgbox-2.17 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type okcancel -icon error +} -result {ok} +test msgbox-2.18 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type okcancel -icon info +} -result {ok} +test msgbox-2.19 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type okcancel -icon question +} -result {ok} +test msgbox-2.20 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . ok + tk_messageBox -title Hi -message "Please press ok" \ + -type okcancel -default ok +} -result {ok} +test msgbox-2.21 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . cancel + tk_messageBox -title Hi -message "Please press cancel" \ + -type okcancel -default cancel +} -result {cancel} +test msgbox-2.22 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" -type retrycancel +} -result {retry} +test msgbox-2.23 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" \ + -type retrycancel -icon warning +} -result {retry} +test msgbox-2.24 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" \ + -type retrycancel -icon error +} -result {retry} +test msgbox-2.25 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" \ + -type retrycancel -icon info +} -result {retry} +test msgbox-2.26 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" \ + -type retrycancel -icon question +} -result {retry} +test msgbox-2.27 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . retry + tk_messageBox -title Hi -message "Please press retry" \ + -type retrycancel -default retry +} -result {retry} +test msgbox-2.28 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . cancel + tk_messageBox -title Hi -message "Please press cancel" \ + -type retrycancel -default cancel +} -result {cancel} +test msgbox-2.29 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" -type yesno +} -result {yes} +test msgbox-2.30 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesno -icon warning +} -result {yes} +test msgbox-2.31 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesno -icon error +} -result {yes} +test msgbox-2.32 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesno -icon info +} -result {yes} +test msgbox-2.33 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesno -icon question +} -result {yes} +test msgbox-2.34 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesno -default yes +} -result {yes} +test msgbox-2.35 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . no + tk_messageBox -title Hi -message "Please press no" \ + -type yesno -default no +} -result {no} +test msgbox-2.36 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" -type yesnocancel +} -result {yes} +test msgbox-2.37 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesnocancel -icon warning +} -result {yes} +test msgbox-2.38 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesnocancel -icon error +} -result {yes} +test msgbox-2.39 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesnocancel -icon info +} -result {yes} +test msgbox-2.40 {tk_messageBox command -icon option} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesnocancel -icon question +} -result {yes} +test msgbox-2.41 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . yes + tk_messageBox -title Hi -message "Please press yes" \ + -type yesnocancel -default yes +} -result {yes} +test msgbox-2.42 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . no + tk_messageBox -title Hi -message "Please press no" \ + -type yesnocancel -default no +} -result {no} +test msgbox-2.43 {tk_messageBox command} -constraints { + nonUnixUserInteraction +} -body { + ChooseMsg . cancel + tk_messageBox -title Hi -message "Please press cancel" \ + -type yesnocancel -default cancel +} -result {cancel} - foreach button $buttons { - test msgbox-2.$count {tk_messageBox command} nonUnixUserInteraction { - ChooseMsg $parent $button - tk_messageBox -title Hi -message "Please press $button" \ - -type $type -default $button - } "$button" - incr count - } -} # These tests will hang your test suite if they fail. -test msgbox-3.1 {tk_messageBox handles withdrawn parent} nonUnixUserInteraction { +test msgbox-3.1 {tk_messageBox handles withdrawn parent} -constraints { + nonUnixUserInteraction +} -body { wm withdraw . ChooseMsg . "ok" tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok -} "ok" -wm deiconify . +} -cleanup { + wm deiconify . +} -result {ok} -test msgbox-3.2 {tk_messageBox handles iconified parent} nonUnixUserInteraction { +test msgbox-3.2 {tk_messageBox handles iconified parent} -constraints { + nonUnixUserInteraction +} -body { wm iconify . ChooseMsg . "ok" tk_messageBox -title Hi -message "Please press ok" \ -type ok -default ok -} "ok" -wm deiconify . +} -cleanup { + wm deiconify . +} -result {ok} # cleanup cleanupTests return + + diff --git a/tests/obj.test b/tests/obj.test index 25bd70f..eece58e 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -5,26 +5,24 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test obj-1.1 {TkGetPixelsFromObj} { -} {} +test obj-1.1 {TkGetPixelsFromObj} -body { +} -result {} -test obj-2.1 {FreePixelInternalRep} { -} {} +test obj-2.1 {FreePixelInternalRep} -body { +} -result {} -test obj-3.1 {DupPixelInternalRep} { -} {} +test obj-3.1 {DupPixelInternalRep} -body { +} -result {} -test obj-4.1 {SetPixelFromAny} { -} {} +test obj-4.1 {SetPixelFromAny} -body { +} -result {} - -deleteWindows - # cleanup cleanupTests return diff --git a/tests/oldpack.test b/tests/oldpack.test index 2f9b979..72ec065 100644 --- a/tests/oldpack.test +++ b/tests/oldpack.test @@ -7,13 +7,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # First, test a single window packed in various ways in a parent -catch {destroy .pack} +destroy .pack frame .pack place .pack -width 100 -height 100 frame .pack.red -width 10 -height 20 @@ -29,189 +30,189 @@ frame .pack.violet -width 80 -height 20 label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 -test oldpack-1.1 {basic positioning} { +test oldpack-1.1 {basic positioning} -body { pack ap .pack .pack.red top update winfo geometry .pack.red -} 10x20+45+0 -test oldpack-1.2 {basic positioning} { +} -result 10x20+45+0 +test oldpack-1.2 {basic positioning} -body { pack append .pack .pack.red bottom update winfo geometry .pack.red -} 10x20+45+80 -test oldpack-1.3 {basic positioning} { +} -result 10x20+45+80 +test oldpack-1.3 {basic positioning} -body { pack append .pack .pack.red left update winfo geometry .pack.red -} 10x20+0+40 -test oldpack-1.4 {basic positioning} { +} -result 10x20+0+40 +test oldpack-1.4 {basic positioning} -body { pack append .pack .pack.red right update winfo geometry .pack.red -} 10x20+90+40 +} -result 10x20+90+40 # Try adding padding around the window and make sure that the # window gets a larger frame. -test oldpack-2.1 {padding} { +test oldpack-2.1 {padding} -body { pack append .pack .pack.red {t padx 20} update winfo geometry .pack.red -} 10x20+45+0 -test oldpack-2.2 {padding} { +} -result 10x20+45+0 +test oldpack-2.2 {padding} -body { pack append .pack .pack.red {top pady 20} update winfo geometry .pack.red -} 10x20+45+10 -test oldpack-2.3 {padding} { +} -result 10x20+45+10 +test oldpack-2.3 {padding} -body { pack append .pack .pack.red {l padx 20} update winfo geometry .pack.red -} 10x20+10+40 -test oldpack-2.4 {padding} { +} -result 10x20+10+40 +test oldpack-2.4 {padding} -body { pack append .pack .pack.red {left pady 20} update winfo geometry .pack.red -} 10x20+0+40 +} -result 10x20+0+40 # Position the window at different positions in its frame to # make sure they all work. Try two differenet frame locations, # to make sure that frame offsets are being added in correctly. -test oldpack-3.1 {framing} { +test oldpack-3.1 {framing} -body { pack append .pack .pack.red {b padx 20 pady 30} update winfo geometry .pack.red -} 10x20+45+65 -test oldpack-3.2 {framing} { +} -result 10x20+45+65 +test oldpack-3.2 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 fr n} update winfo geometry .pack.red -} 10x20+45+50 -test oldpack-3.3 {framing} { +} -result 10x20+45+50 +test oldpack-3.3 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame ne} update winfo geometry .pack.red -} 10x20+90+50 -test oldpack-3.4 {framing} { +} -result 10x20+90+50 +test oldpack-3.4 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame e} update winfo geometry .pack.red -} 10x20+90+65 -test oldpack-3.5 {framing} { +} -result 10x20+90+65 +test oldpack-3.5 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame se} update winfo geometry .pack.red -} 10x20+90+80 -test oldpack-3.6 {framing} { +} -result 10x20+90+80 +test oldpack-3.6 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame s} update winfo geometry .pack.red -} 10x20+45+80 -test oldpack-3.7 {framing} { +} -result 10x20+45+80 +test oldpack-3.7 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame sw} update winfo geometry .pack.red -} 10x20+0+80 -test oldpack-3.8 {framing} { +} -result 10x20+0+80 +test oldpack-3.8 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame w} update winfo geometry .pack.red -} 10x20+0+65 -test oldpack-3.9 {framing} { +} -result 10x20+0+65 +test oldpack-3.9 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame nw} update winfo geometry .pack.red -} 10x20+0+50 -test oldpack-3.10 {framing} { +} -result 10x20+0+50 +test oldpack-3.10 {framing} -body { pack append .pack .pack.red {bottom padx 20 pady 30 frame c} update winfo geometry .pack.red -} 10x20+45+65 -test oldpack-3.11 {framing} { +} -result 10x20+45+65 +test oldpack-3.11 {framing} -body { pack append .pack .pack.red {r padx 20 pady 30} update winfo geometry .pack.red -} 10x20+80+40 -test oldpack-3.12 {framing} { +} -result 10x20+80+40 +test oldpack-3.12 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame n} update winfo geometry .pack.red -} 10x20+80+0 -test oldpack-3.13 {framing} { +} -result 10x20+80+0 +test oldpack-3.13 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame ne} update winfo geometry .pack.red -} 10x20+90+0 -test oldpack-3.14 {framing} { +} -result 10x20+90+0 +test oldpack-3.14 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame e} update winfo geometry .pack.red -} 10x20+90+40 -test oldpack-3.15 {framing} { +} -result 10x20+90+40 +test oldpack-3.15 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame se} update winfo geometry .pack.red -} 10x20+90+80 -test oldpack-3.16 {framing} { +} -result 10x20+90+80 +test oldpack-3.16 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame s} update winfo geometry .pack.red -} 10x20+80+80 -test oldpack-3.17 {framing} { +} -result 10x20+80+80 +test oldpack-3.17 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame sw} update winfo geometry .pack.red -} 10x20+70+80 -test oldpack-3.18 {framing} { +} -result 10x20+70+80 +test oldpack-3.18 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame w} update winfo geometry .pack.red -} 10x20+70+40 -test oldpack-3.19 {framing} { +} -result 10x20+70+40 +test oldpack-3.19 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame nw} update winfo geometry .pack.red -} 10x20+70+0 -test oldpack-3.20 {framing} { +} -result 10x20+70+0 +test oldpack-3.20 {framing} -body { pack append .pack .pack.red {right padx 20 pady 30 frame center} update winfo geometry .pack.red -} 10x20+80+40 +} -result 10x20+80+40 # Try out various filling combinations in a couple of different # frame locations. -test oldpack-4.1 {filling} { +test oldpack-4.1 {filling} -body { pack append .pack .pack.red {bottom padx 20 pady 30 fillx} update winfo geometry .pack.red -} 100x20+0+65 -test oldpack-4.2 {filling} { +} -result 100x20+0+65 +test oldpack-4.2 {filling} -body { pack append .pack .pack.red {bottom padx 20 pady 30 filly} update winfo geometry .pack.red -} 10x50+45+50 -test oldpack-4.3 {filling} { +} -result 10x50+45+50 +test oldpack-4.3 {filling} -body { pack append .pack .pack.red {bottom padx 20 pady 30 fill} update winfo geometry .pack.red -} 100x50+0+50 -test oldpack-4.4 {filling} { +} -result 100x50+0+50 +test oldpack-4.4 {filling} -body { pack append .pack .pack.red {right padx 20 pady 30 fillx} update winfo geometry .pack.red -} 30x20+70+40 -test oldpack-4.5 {filling} { +} -result 30x20+70+40 +test oldpack-4.5 {filling} -body { pack append .pack .pack.red {right padx 20 pady 30 filly} update winfo geometry .pack.red -} 10x100+80+0 -test oldpack-4.6 {filling} { +} -result 10x100+80+0 +test oldpack-4.6 {filling} -body { pack append .pack .pack.red {right padx 20 pady 30 fill} update winfo geometry .pack.red -} 30x100+70+0 +} -result 30x100+70+0 # Multiple windows: make sure that space is properly subtracted # from the cavity as windows are positioned inwards from all @@ -219,57 +220,128 @@ test oldpack-4.6 {filling} { # there isn't enough space for them. pack append .pack .pack.red top .pack.green top .pack.blue top \ - .pack.violet top + .pack.violet top update -test oldpack-5.1 {multiple windows} {winfo geometry .pack.red} 10x20+45+0 -test oldpack-5.2 {multiple windows} {winfo geometry .pack.green} 30x40+35+20 -test oldpack-5.3 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60 -test oldpack-5.4 {multiple windows} {winfo ismapped .pack.violet} 0 +test oldpack-5.1 {multiple windows} -body { + winfo geometry .pack.red +} -result 10x20+45+0 +test oldpack-5.2 {multiple windows} -body { + winfo geometry .pack.green +} -result 30x40+35+20 +test oldpack-5.3 {multiple windows} -body { + winfo geometry .pack.blue +} -result 40x40+30+60 +test oldpack-5.4 {multiple windows} -body { + winfo ismapped .pack.violet +} -result 0 + pack b .pack.blue .pack.violet top update -test oldpack-5.5 {multiple windows} {winfo ismapped .pack.violet} 1 -test oldpack-5.6 {multiple windows} {winfo geometry .pack.violet} 80x20+10+60 -test oldpack-5.7 {multiple windows} {winfo geometry .pack.blue} 40x20+30+80 +test oldpack-5.5 {multiple windows} -body { + winfo ismapped .pack.violet +} -result 1 +test oldpack-5.6 {multiple windows} -body { + winfo geometry .pack.violet +} -result 80x20+10+60 +test oldpack-5.7 {multiple windows} -body { + winfo geometry .pack.blue +} -result 40x20+30+80 + pack after .pack.blue .pack.red top update -test oldpack-5.8 {multiple windows} {winfo geometry .pack.green} 30x40+35+0 -test oldpack-5.9 {multiple windows} {winfo geometry .pack.violet} 80x20+10+40 -test oldpack-5.10 {multiple windows} {winfo geometry .pack.blue} 40x40+30+60 -test oldpack-5.11 {multiple windows} {winfo ismapped .pack.red} 0 +test oldpack-5.8 {multiple windows} -body { + winfo geometry .pack.green +} -result 30x40+35+0 +test oldpack-5.9 {multiple windows} -body { + winfo geometry .pack.violet +} -result 80x20+10+40 +test oldpack-5.10 {multiple windows} -body { + winfo geometry .pack.blue +} -result 40x40+30+60 +test oldpack-5.11 {multiple windows} -body { + winfo ismapped .pack.red +} -result 0 + pack before .pack.green .pack.red right .pack.blue left update -test oldpack-5.12 {multiple windows} {winfo ismapped .pack.red} 1 -test oldpack-5.13 {multiple windows} {winfo geometry .pack.red} 10x20+90+40 -test oldpack-5.14 {multiple windows} {winfo geometry .pack.blue} 40x40+0+30 -test oldpack-5.15 {multiple windows} {winfo geometry .pack.green} 30x40+50+0 -test oldpack-5.16 {multiple windows} {winfo geometry .pack.violet} 50x20+40+40 +test oldpack-5.12 {multiple windows} -body { + winfo ismapped .pack.red +} -result 1 +test oldpack-5.13 {multiple windows} -body { + winfo geometry .pack.red +} -result 10x20+90+40 +test oldpack-5.14 {multiple windows} -body { + winfo geometry .pack.blue +} -result 40x40+0+30 +test oldpack-5.15 {multiple windows} -body { + winfo geometry .pack.green +} -result 30x40+50+0 +test oldpack-5.16 {multiple windows} -body { + winfo geometry .pack.violet +} -result 50x20+40+40 + pack append .pack .pack.violet left .pack.green bottom .pack.red bottom \ - .pack.blue bottom + .pack.blue bottom update -test oldpack-5.17 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40 -test oldpack-5.18 {multiple windows} {winfo geometry .pack.green} 20x40+80+60 -test oldpack-5.19 {multiple windows} {winfo geometry .pack.red} 10x20+85+40 -test oldpack-5.20 {multiple windows} {winfo geometry .pack.blue} 20x40+80+0 +test oldpack-5.17 {multiple windows} -body { + winfo geometry .pack.violet +} -result 80x20+0+40 +test oldpack-5.18 {multiple windows} -body { + winfo geometry .pack.green +} -result 20x40+80+60 +test oldpack-5.19 {multiple windows} -body { + winfo geometry .pack.red +} -result 10x20+85+40 +test oldpack-5.20 {multiple windows} -body { + winfo geometry .pack.blue +} -result 20x40+80+0 + pack after .pack.blue .pack.blue top .pack.red right .pack.green right \ - .pack.violet right + .pack.violet right update -test oldpack-5.21 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0 -test oldpack-5.22 {multiple windows} {winfo geometry .pack.red} 10x20+90+60 -test oldpack-5.23 {multiple windows} {winfo geometry .pack.green} 30x40+60+50 -test oldpack-5.24 {multiple windows} {winfo geometry .pack.violet} 60x20+0+60 +test oldpack-5.21 {multiple windows} -body { + winfo geometry .pack.blue +} -result 40x40+30+0 +test oldpack-5.22 {multiple windows} -body { + winfo geometry .pack.red +} -result 10x20+90+60 +test oldpack-5.23 {multiple windows} -body { + winfo geometry .pack.green +} -result 30x40+60+50 +test oldpack-5.24 {multiple windows} -body { + winfo geometry .pack.violet +} -result 60x20+0+60 + pack after .pack.blue .pack.red left .pack.green left .pack.violet left update -test oldpack-5.25 {multiple windows} {winfo geometry .pack.blue} 40x40+30+0 -test oldpack-5.26 {multiple windows} {winfo geometry .pack.red} 10x20+0+60 -test oldpack-5.27 {multiple windows} {winfo geometry .pack.green} 30x40+10+50 -test oldpack-5.28 {multiple windows} {winfo geometry .pack.violet} 60x20+40+60 +test oldpack-5.25 {multiple windows} -body { + winfo geometry .pack.blue +} -result 40x40+30+0 +test oldpack-5.26 {multiple windows} -body { + winfo geometry .pack.red +} -result 10x20+0+60 +test oldpack-5.27 {multiple windows} -body { + winfo geometry .pack.green +} -result 30x40+10+50 +test oldpack-5.28 {multiple windows} -body { + winfo geometry .pack.violet +} -result 60x20+40+60 + pack append .pack .pack.violet left .pack.green left .pack.blue left \ - .pack.red left + .pack.red left update -test oldpack-5.29 {multiple windows} {winfo geometry .pack.violet} 80x20+0+40 -test oldpack-5.30 {multiple windows} {winfo geometry .pack.green} 20x40+80+30 -test oldpack-5.31 {multiple windows} {winfo ismapped .pack.blue} 0 -test oldpack-5.32 {multiple windows} {winfo ismapped .pack.red} 0 +test oldpack-5.29 {multiple windows} -body { + winfo geometry .pack.violet +} -result 80x20+0+40 +test oldpack-5.30 {multiple windows} -body { + winfo geometry .pack.green +} -result 20x40+80+30 +test oldpack-5.31 {multiple windows} -body { + winfo ismapped .pack.blue +} -result 0 +test oldpack-5.32 {multiple windows} -body { + winfo ismapped .pack.red +} -result 0 # Test the ability of the packer to propagate geometry information @@ -279,84 +351,92 @@ test oldpack-5.32 {multiple windows} {winfo ismapped .pack.red} 0 # "left" and "right" windows). pack append .pack .pack.red top .pack.green top .pack.blue top \ - .pack.violet top + .pack.violet top update -test oldpack-6.1 {geometry propagation} {winfo reqwidth .pack} 80 -test oldpack-6.2 {geometry propagation} {winfo reqheight .pack} 120 +test oldpack-6.1 {geometry propagation} -body { + winfo reqwidth .pack} -result 80 +test oldpack-6.2 {geometry propagation} -body { + winfo reqheight .pack} -result 120 destroy .pack.violet update -test oldpack-6.3 {geometry propagation} {winfo reqwidth .pack} 40 -test oldpack-6.4 {geometry propagation} {winfo reqheight .pack} 100 +test oldpack-6.3 {geometry propagation} -body { + winfo reqwidth .pack} -result 40 +test oldpack-6.4 {geometry propagation} -body { + winfo reqheight .pack} -result 100 frame .pack.violet -width 80 -height 20 -bg violet label .pack.violet.l -text P -bd 2 -relief raised place .pack.violet.l -relwidth 1.0 -relheight 1.0 pack append .pack .pack.red left .pack.green right .pack.blue bottom \ - .pack.violet top + .pack.violet top update -test oldpack-6.5 {geometry propagation} {winfo reqwidth .pack} 120 -test oldpack-6.6 {geometry propagation} {winfo reqheight .pack} 60 +test oldpack-6.5 {geometry propagation} -body { + winfo reqwidth .pack} -result 120 +test oldpack-6.6 {geometry propagation} -body { + winfo reqheight .pack} -result 60 pack append .pack .pack.violet top .pack.green top .pack.blue left \ - .pack.red left + .pack.red left update -test oldpack-6.7 {geometry propagation} {winfo reqwidth .pack} 80 -test oldpack-6.8 {geometry propagation} {winfo reqheight .pack} 100 +test oldpack-6.7 {geometry propagation} -body { + winfo reqwidth .pack} -result 80 +test oldpack-6.8 {geometry propagation} -body { + winfo reqheight .pack} -result 100 # Test the "expand" option, and make sure space is evenly divided # when several windows request expansion. pack append .pack .pack.violet top .pack.green {left e} \ - .pack.blue {left expand} .pack.red {left expand} + .pack.blue {left expand} .pack.red {left expand} update -test oldpack-7.1 {multiple expanded windows} { +test oldpack-7.1 {multiple expanded windows} -body { pack append .pack .pack.violet top .pack.green {left e} \ - .pack.blue {left expand} .pack.red {left expand} + .pack.blue {left expand} .pack.red {left expand} update list [winfo geometry .pack.green] [winfo geometry .pack.blue] \ - [winfo geometry .pack.red] -} {30x40+3+40 40x40+39+40 10x20+86+50} -test oldpack-7.2 {multiple expanded windows} { + [winfo geometry .pack.red] +} -result {30x40+3+40 40x40+39+40 10x20+86+50} +test oldpack-7.2 {multiple expanded windows} -body { pack append .pack .pack.green left .pack.violet {bottom expand} \ - .pack.blue {bottom expand} .pack.red {bottom expand} + .pack.blue {bottom expand} .pack.red {bottom expand} update list [winfo geometry .pack.violet] [winfo geometry .pack.blue] \ - [winfo geometry .pack.red] -} {70x20+30+77 40x40+45+30 10x20+60+3} -test oldpack-7.3 {multiple expanded windows} { + [winfo geometry .pack.red] +} -result {70x20+30+77 40x40+45+30 10x20+60+3} +test oldpack-7.3 {multiple expanded windows} -body { foreach i [winfo child .pack] { - pack unpack $i + pack unpack $i } pack append .pack .pack.green {left e fill} .pack.red {left expand fill} \ - .pack.blue {top fill} + .pack.blue {top fill} update list [winfo geometry .pack.green] [winfo geometry .pack.red] \ - [winfo geometry .pack.blue] -} {40x100+0+0 20x100+40+0 40x40+60+0} -test oldpack-7.4 {multiple expanded windows} { + [winfo geometry .pack.blue] +} -result {40x100+0+0 20x100+40+0 40x40+60+0} +test oldpack-7.4 {multiple expanded windows} -body { foreach i [winfo child .pack] { - pack unpack $i + pack unpack $i } pack append .pack .pack.red {top expand} .pack.violet {top expand} \ - .pack.blue {right fill} + .pack.blue {right fill} update list [winfo geometry .pack.red] [winfo geometry .pack.violet] \ - [winfo geometry .pack.blue] -} {10x20+45+5 80x20+10+35 40x40+60+60} -test oldpack-7.5 {multiple expanded windows} { + [winfo geometry .pack.blue] +} -result {10x20+45+5 80x20+10+35 40x40+60+60} +test oldpack-7.5 {multiple expanded windows} -body { foreach i [winfo child .pack] { - pack unpack $i + pack unpack $i } pack append .pack .pack.green {right frame s} .pack.red {top expand} update list [winfo geometry .pack.green] [winfo geometry .pack.red] -} {30x40+70+60 10x20+30+40} -test oldpack-7.6 {multiple expanded windows} { +} -result {30x40+70+60 10x20+30+40} +test oldpack-7.6 {multiple expanded windows} -body { foreach i [winfo child .pack] { - pack unpack $i + pack unpack $i } pack append .pack .pack.violet {bottom frame e} .pack.red {right expand} update list [winfo geometry .pack.violet] [winfo geometry .pack.red] -} {80x20+20+80 10x20+45+30} +} -result {80x20+20+80 10x20+45+30} # Need more bizarre tests with combinations of expanded windows and # windows in opposing directions! Also, include padding in expanded @@ -364,146 +444,109 @@ test oldpack-7.6 {multiple expanded windows} { # Syntax errors on pack commands -test oldpack-8.1 {syntax errors} { - set msg "" - set result [catch {pack} msg] - concat $result $msg -} {1 wrong # args: should be "pack option arg ?arg ...?"} -test oldpack-8.2 {syntax errors} { - set msg "" - set result [catch {pack append} msg] - concat $result $msg -} {1 wrong # args: should be "pack option arg ?arg ...?"} -test oldpack-8.3 {syntax errors} { - set msg "" - set result [catch {pack gorp foo} msg] - concat $result $msg -} {1 bad option "gorp": must be configure, forget, info, propagate, or slaves} -test oldpack-8.4 {syntax errors} { - set msg "" - set result [catch {pack a .pack} msg] - concat $result $msg -} {1 bad option "a": must be configure, forget, info, propagate, or slaves} -test oldpack-8.5 {syntax errors} { - set msg "" - set result [catch {pack after foobar} msg] - concat $result $msg -} {1 bad window path name "foobar"} -test oldpack-8.6 {syntax errors} { +test oldpack-8.1 {syntax errors} -body { + pack +} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} +test oldpack-8.2 {syntax errors} -body { + pack append +} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} +test oldpack-8.3 {syntax errors} -body { + pack gorp foo +} -returnCodes error -result {bad option "gorp": must be configure, forget, info, propagate, or slaves} +test oldpack-8.4 {syntax errors} -body { + pack a .pack +} -returnCodes error -result {bad option "a": must be configure, forget, info, propagate, or slaves} +test oldpack-8.5 {syntax errors} -body { + pack after foobar +} -returnCodes error -result {bad window path name "foobar"} +test oldpack-8.6 {syntax errors} -setup { + destroy .pack.yellow +} -body { frame .pack.yellow -bg yellow - set msg "" - set result [catch {pack after .pack.yellow} msg] + pack after .pack.yellow +} -cleanup { destroy .pack.yellow - concat $result $msg -} {1 window ".pack.yellow" isn't packed} -test oldpack-8.7 {syntax errors} { - set msg "" - set result [catch {pack append foobar} msg] - concat $result $msg -} {1 bad window path name "foobar"} -test oldpack-8.8 {syntax errors} { - set msg "" - set result [catch {pack before foobar} msg] - concat $result $msg -} {1 bad window path name "foobar"} -test oldpack-8.9 {syntax errors} { +} -returnCodes error -result {window ".pack.yellow" isn't packed} +test oldpack-8.7 {syntax errors} -body { + pack append foobar +} -returnCodes error -result {bad window path name "foobar"} +test oldpack-8.8 {syntax errors} -body { + pack before foobar +} -returnCodes error -result {bad window path name "foobar"} +test oldpack-8.9 {syntax errors} -setup { + destroy .pack.yellow +} -body { frame .pack.yellow -bg yellow - set msg "" - set result [catch {pack before .pack.yellow} msg] + pack before .pack.yellow +} -cleanup { destroy .pack.yellow - concat $result $msg -} {1 window ".pack.yellow" isn't packed} -test oldpack-8.10 {syntax errors} { - set msg "" - set result [catch {pack info .pack help} msg] - concat $result $msg -} {1 wrong # args: should be "pack info window"} -test oldpack-8.11 {syntax errors} { - set msg "" - set result [catch {pack info foobar} msg] - concat $result $msg -} {1 bad window path name "foobar"} -test oldpack-8.12 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue} msg] - concat $result $msg -} {1 wrong # args: window ".pack.blue" should be followed by options} -test oldpack-8.13 {syntax errors} { - set msg "" - set result [catch {pack append . .pack.blue top} msg] - concat $result $msg -} {1 can't pack .pack.blue inside .} -test oldpack-8.14 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue f} msg] - concat $result $msg -} {1 bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} -test oldpack-8.15 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue pad} msg] - concat $result $msg -} {1 bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} -test oldpack-8.16 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue {frame south}} msg] - concat $result $msg -} {1 bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center} -test oldpack-8.17 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue {padx -2}} msg] - concat $result $msg -} {1 bad pad value "-2": must be positive screen distance} -test oldpack-8.18 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue {padx}} msg] - concat $result $msg -} {1 wrong # args: "padx" option must be followed by screen distance} -test oldpack-8.19 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue {pady -2}} msg] - concat $result $msg -} {1 bad pad value "-2": must be positive screen distance} -test oldpack-8.20 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue {pady}} msg] - concat $result $msg -} {1 wrong # args: "pady" option must be followed by screen distance} -test oldpack-8.21 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue "\{abc"} msg] - concat $result $msg -} {1 unmatched open brace in list} -test oldpack-8.22 {syntax errors} { - set msg "" - set result [catch {pack append .pack .pack.blue frame} msg] - concat $result $msg -} {1 wrong # args: "frame" option must be followed by anchor point} +} -returnCodes error -result {window ".pack.yellow" isn't packed} +test oldpack-8.10 {syntax errors} -body { + pack info .pack help +} -returnCodes error -result {wrong # args: should be "pack info window"} +test oldpack-8.11 {syntax errors} -body { + pack info foobar +} -returnCodes error -result {bad window path name "foobar"} +test oldpack-8.12 {syntax errors} -body { + pack append .pack .pack.blue +} -returnCodes error -result {wrong # args: window ".pack.blue" should be followed by options} +test oldpack-8.13 {syntax errors} -body { + pack append . .pack.blue top +} -returnCodes error -result {can't pack .pack.blue inside .} +test oldpack-8.14 {syntax errors} -body { + pack append .pack .pack.blue f +} -returnCodes error -result {bad option "f": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} +test oldpack-8.15 {syntax errors} -body { + pack append .pack .pack.blue pad +} -returnCodes error -result {bad option "pad": should be top, bottom, left, right, expand, fill, fillx, filly, padx, pady, or frame} +test oldpack-8.16 {syntax errors} -body { + pack append .pack .pack.blue {frame south} +} -returnCodes error -result {bad anchor "south": must be n, ne, e, se, s, sw, w, nw, or center} +test oldpack-8.17 {syntax errors} -body { + pack append .pack .pack.blue {padx -2} +} -returnCodes error -result {bad pad value "-2": must be positive screen distance} +test oldpack-8.18 {syntax errors} -body { + pack append .pack .pack.blue {padx} +} -returnCodes error -result {wrong # args: "padx" option must be followed by screen distance} +test oldpack-8.19 {syntax errors} -body { + pack append .pack .pack.blue {pady -2} +} -returnCodes error -result {bad pad value "-2": must be positive screen distance} +test oldpack-8.20 {syntax errors} -body { + pack append .pack .pack.blue {pady} +} -returnCodes error -result {wrong # args: "pady" option must be followed by screen distance} +test oldpack-8.21 {syntax errors} -body { + pack append .pack .pack.blue "\{abc" +} -returnCodes error -result {unmatched open brace in list} +test oldpack-8.22 {syntax errors} -body { + pack append .pack .pack.blue frame +} -returnCodes error -result {wrong # args: "frame" option must be followed by anchor point} # Test "pack info" command output. -test oldpack-9.1 {information output} { +test oldpack-9.1 {information output} -body { pack append .pack .pack.blue {top fillx frame n} \ - .pack.red {bottom filly frame s} .pack.green {left fill frame w} \ - .pack.violet {right expand frame e} + .pack.red {bottom filly frame s} .pack.green {left fill frame w} \ + .pack.violet {right expand frame e} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ - [pack info .pack.green] [pack info .pack.violet] -} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}} -test oldpack-9.2 {information output} { + [pack info .pack.green] [pack info .pack.violet] +} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor n -expand 0 -fill x -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor s -expand 0 -fill y -ipadx 0 -ipady 0 -padx 0 -pady 0 -side bottom} {-in .pack -anchor w -expand 0 -fill both -ipadx 0 -ipady 0 -padx 0 -pady 0 -side left} {-in .pack -anchor e -expand 1 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side right}} +test oldpack-9.2 {information output} -body { pack append .pack .pack.blue {padx 10 frame nw} \ - .pack.red {pady 20 frame ne} .pack.green {frame se} \ - .pack.violet {frame sw} + .pack.red {pady 20 frame ne} .pack.green {frame se} \ + .pack.violet {frame sw} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ - [pack info .pack.green] [pack info .pack.violet] -} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} -test oldpack-9.3 {information output} { + [pack info .pack.green] [pack info .pack.violet] +} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor nw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 5 -pady 0 -side top} {-in .pack -anchor ne -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 10 -side top} {-in .pack -anchor se -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor sw -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} +test oldpack-9.3 {information output} -body { pack append .pack .pack.blue {frame center} .pack.red {frame center} \ - .pack.green {frame c} .pack.violet {frame c} + .pack.green {frame c} .pack.violet {frame c} list [pack slaves .pack] [pack info .pack.blue] [pack info .pack.red] \ - [pack info .pack.green] [pack info .pack.violet] -} {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} + [pack info .pack.green] [pack info .pack.violet] +} -result {{.pack.blue .pack.red .pack.green .pack.violet} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top}} -catch {destroy .pack} +destroy .pack # cleanup cleanupTests return + diff --git a/tests/option.test b/tests/option.test index 49d2975..66df70c 100644 --- a/tests/option.test +++ b/tests/option.test @@ -6,14 +6,14 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands testConstraint appNameIsTktest [expr {[winfo name .] eq "tktest"}] -catch {destroy .op1} -catch {destroy .op2} +deleteWindows set appName [winfo name .] # First, test basic retrievals, being sure to trigger all the various @@ -27,6 +27,7 @@ frame .op1.op4 -class Class3 frame .op2.op5 -class Class2 frame .op1.op3.op6 -class Class4 +# Configurations for tests 1.* - 12.* option clear option add *Color1 red option add *x blue @@ -38,97 +39,254 @@ option add $appName.Class1.Class3.y brown option add $appName*op6*Color2 black option add $appName*Class1.op1.Color2 grey -test option-1.1 {basic option retrieval} {option get . x Color1} blue -test option-1.2 {basic option retrieval} {option get . y Color1} red -test option-1.3 {basic option retrieval} {option get . z Color1} red -test option-1.4 {basic option retrieval} {option get . x Color2} blue -test option-1.5 {basic option retrieval} {option get . y Color2} {} -test option-1.6 {basic option retrieval} {option get . z Color2} {} - -test option-2.1 {basic option retrieval} {option get .op1 x Color1} green -test option-2.2 {basic option retrieval} {option get .op1 y Color1} red -test option-2.3 {basic option retrieval} {option get .op1 z Color1} red -test option-2.4 {basic option retrieval} {option get .op1 x Color2} green -test option-2.5 {basic option retrieval} {option get .op1 y Color2} {} -test option-2.6 {basic option retrieval} {option get .op1 z Color2} {} - -test option-3.1 {basic option retrieval} {option get .op1.op3 x Color1} yellow -test option-3.2 {basic option retrieval} {option get .op1.op3 y Color1} red -test option-3.3 {basic option retrieval} {option get .op1.op3 z Color1} red -test option-3.4 {basic option retrieval} {option get .op1.op3 x Color2} yellow -test option-3.5 {basic option retrieval} {option get .op1.op3 y Color2} {} -test option-3.6 {basic option retrieval} {option get .op1.op3 z Color2} {} - -test option-4.1 {basic option retrieval} {option get .op1.op3.op6 x Color1} blue -test option-4.2 {basic option retrieval} {option get .op1.op3.op6 y Color1} red -test option-4.3 {basic option retrieval} {option get .op1.op3.op6 z Color1} red -test option-4.4 {basic option retrieval} {option get .op1.op3.op6 x Color2} black -test option-4.5 {basic option retrieval} {option get .op1.op3.op6 y Color2} black -test option-4.6 {basic option retrieval} {option get .op1.op3.op6 z Color2} black - -test option-5.1 {basic option retrieval} {option get .op1.op4 x Color1} blue -test option-5.2 {basic option retrieval} {option get .op1.op4 y Color1} brown -test option-5.3 {basic option retrieval} {option get .op1.op4 z Color1} red -test option-5.4 {basic option retrieval} {option get .op1.op4 x Color2} blue -test option-5.5 {basic option retrieval} {option get .op1.op4 y Color2} brown -test option-5.6 {basic option retrieval} {option get .op1.op4 z Color2} {} - -test option-6.1 {basic option retrieval} {option get .op2 x Color1} orange -test option-6.2 {basic option retrieval} {option get .op2 y Color1} orange -test option-6.3 {basic option retrieval} {option get .op2 z Color1} orange -test option-6.4 {basic option retrieval} {option get .op2 x Color2} blue -test option-6.5 {basic option retrieval} {option get .op2 y Color2} {} -test option-6.6 {basic option retrieval} {option get .op2 z Color2} {} - -test option-7.1 {basic option retrieval} {option get .op2.op5 x Color1} orange -test option-7.2 {basic option retrieval} {option get .op2.op5 y Color1} orange -test option-7.3 {basic option retrieval} {option get .op2.op5 z Color1} orange -test option-7.4 {basic option retrieval} {option get .op2.op5 x Color2} purple -test option-7.5 {basic option retrieval} {option get .op2.op5 y Color2} purple -test option-7.6 {basic option retrieval} {option get .op2.op5 z Color2} purple +test option-1.1 {basic option retrieval} -body { + option get . x Color1 +} -result blue +test option-1.2 {basic option retrieval} -body { + option get . y Color1 +} -result red +test option-1.3 {basic option retrieval} -body { + option get . z Color1 +} -result red +test option-1.4 {basic option retrieval} -body { + option get . x Color2 +} -result blue +test option-1.5 {basic option retrieval} -body { + option get . y Color2 +} -result {} +test option-1.6 {basic option retrieval} -body { + option get . z Color2 +} -result {} + + +test option-2.1 {basic option retrieval} -body { + option get .op1 x Color1 +} -result green +test option-2.2 {basic option retrieval} -body { + option get .op1 y Color1 +} -result red +test option-2.3 {basic option retrieval} -body { + option get .op1 z Color1 +} -result red +test option-2.4 {basic option retrieval} -body { + option get .op1 x Color2 +} -result green +test option-2.5 {basic option retrieval} -body { + option get .op1 y Color2 +} -result {} +test option-2.6 {basic option retrieval} -body { + option get .op1 z Color2 +} -result {} + + +test option-3.1 {basic option retrieval} -body { + option get .op1.op3 x Color1 +} -result yellow +test option-3.2 {basic option retrieval} -body { + option get .op1.op3 y Color1 +} -result red +test option-3.3 {basic option retrieval} -body { + option get .op1.op3 z Color1 +} -result red +test option-3.4 {basic option retrieval} -body { + option get .op1.op3 x Color2 +} -result yellow +test option-3.5 {basic option retrieval} -body { + option get .op1.op3 y Color2 +} -result {} +test option-3.6 {basic option retrieval} -body { + option get .op1.op3 z Color2 +} -result {} + + +test option-4.1 {basic option retrieval} -body { + option get .op1.op3.op6 x Color1 +} -result blue +test option-4.2 {basic option retrieval} -body { + option get .op1.op3.op6 y Color1 +} -result red +test option-4.3 {basic option retrieval} -body { + option get .op1.op3.op6 z Color1 +} -result red +test option-4.4 {basic option retrieval} -body { + option get .op1.op3.op6 x Color2 +} -result black +test option-4.5 {basic option retrieval} -body { + option get .op1.op3.op6 y Color2 +} -result black +test option-4.6 {basic option retrieval} -body { + option get .op1.op3.op6 z Color2 +} -result black + + +test option-5.1 {basic option retrieval} -body { + option get .op1.op4 x Color1 +} -result blue +test option-5.2 {basic option retrieval} -body { + option get .op1.op4 y Color1 +} -result brown +test option-5.3 {basic option retrieval} -body { + option get .op1.op4 z Color1 +} -result red +test option-5.4 {basic option retrieval} -body { + option get .op1.op4 x Color2 +} -result blue +test option-5.5 {basic option retrieval} -body { + option get .op1.op4 y Color2 +} -result brown +test option-5.6 {basic option retrieval} -body { + option get .op1.op4 z Color2 +} -result {} + + +test option-6.1 {basic option retrieval} -body { + option get .op2 x Color1 +} -result orange +test option-6.2 {basic option retrieval} -body { + option get .op2 y Color1 +} -result orange +test option-6.3 {basic option retrieval} -body { + option get .op2 z Color1 +} -result orange +test option-6.4 {basic option retrieval} -body { + option get .op2 x Color2 +} -result blue +test option-6.5 {basic option retrieval} -body { + option get .op2 y Color2 +} -result {} +test option-6.6 {basic option retrieval} -body { + option get .op2 z Color2 +} -result {} + + +test option-7.1 {basic option retrieval} -body { + option get .op2.op5 x Color1 +} -result orange +test option-7.2 {basic option retrieval} -body { + option get .op2.op5 y Color1 +} -result orange +test option-7.3 {basic option retrieval} -body { + option get .op2.op5 z Color1 +} -result orange +test option-7.4 {basic option retrieval} -body { + option get .op2.op5 x Color2 +} -result purple +test option-7.5 {basic option retrieval} -body { + option get .op2.op5 y Color2 +} -result purple +test option-7.6 {basic option retrieval} -body { + option get .op2.op5 z Color2 +} -result purple + # Now try similar tests to above, except jump around non-hierarchically # between windows to make sure that the option stacks are pushed and # popped correctly. option get . foo Foo -test option-8.1 {stack pushing/popping} {option get .op2.op5 x Color1} orange -test option-8.2 {stack pushing/popping} {option get .op2.op5 y Color1} orange -test option-8.3 {stack pushing/popping} {option get .op2.op5 z Color1} orange -test option-8.4 {stack pushing/popping} {option get .op2.op5 x Color2} purple -test option-8.5 {stack pushing/popping} {option get .op2.op5 y Color2} purple -test option-8.6 {stack pushing/popping} {option get .op2.op5 z Color2} purple - -test option-9.1 {stack pushing/popping} {option get . x Color1} blue -test option-9.2 {stack pushing/popping} {option get . y Color1} red -test option-9.3 {stack pushing/popping} {option get . z Color1} red -test option-9.4 {stack pushing/popping} {option get . x Color2} blue -test option-9.5 {stack pushing/popping} {option get . y Color2} {} -test option-9.6 {stack pushing/popping} {option get . z Color2} {} - -test option-10.1 {stack pushing/popping} {option get .op1.op3.op6 x Color1} blue -test option-10.2 {stack pushing/popping} {option get .op1.op3.op6 y Color1} red -test option-10.3 {stack pushing/popping} {option get .op1.op3.op6 z Color1} red -test option-10.4 {stack pushing/popping} {option get .op1.op3.op6 x Color2} black -test option-10.5 {stack pushing/popping} {option get .op1.op3.op6 y Color2} black -test option-10.6 {stack pushing/popping} {option get .op1.op3.op6 z Color2} black - -test option-11.1 {stack pushing/popping} {option get .op1.op3 x Color1} yellow -test option-11.2 {stack pushing/popping} {option get .op1.op3 y Color1} red -test option-11.3 {stack pushing/popping} {option get .op1.op3 z Color1} red -test option-11.4 {stack pushing/popping} {option get .op1.op3 x Color2} yellow -test option-11.5 {stack pushing/popping} {option get .op1.op3 y Color2} {} -test option-11.6 {stack pushing/popping} {option get .op1.op3 z Color2} {} - -test option-12.1 {stack pushing/popping} {option get .op1 x Color1} green -test option-12.2 {stack pushing/popping} {option get .op1 y Color1} red -test option-12.3 {stack pushing/popping} {option get .op1 z Color1} red -test option-12.4 {stack pushing/popping} {option get .op1 x Color2} green -test option-12.5 {stack pushing/popping} {option get .op1 y Color2} {} -test option-12.6 {stack pushing/popping} {option get .op1 z Color2} {} +test option-8.1 {stack pushing/popping} -body { + option get .op2.op5 x Color1 +} -result orange +test option-8.2 {stack pushing/popping} -body { + option get .op2.op5 y Color1 +} -result orange +test option-8.3 {stack pushing/popping} -body { + option get .op2.op5 z Color1 +} -result orange +test option-8.4 {stack pushing/popping} -body { + option get .op2.op5 x Color2 +} -result purple +test option-8.5 {stack pushing/popping} -body { + option get .op2.op5 y Color2 +} -result purple +test option-8.6 {stack pushing/popping} -body { + option get .op2.op5 z Color2 +} -result purple + + +test option-9.1 {stack pushing/popping} -body { + option get . x Color1 +} -result blue +test option-9.2 {stack pushing/popping} -body { + option get . y Color1 +} -result red +test option-9.3 {stack pushing/popping} -body { + option get . z Color1 +} -result red +test option-9.4 {stack pushing/popping} -body { + option get . x Color2 +} -result blue +test option-9.5 {stack pushing/popping} -body { + option get . y Color2 +} -result {} +test option-9.6 {stack pushing/popping} -body { + option get . z Color2 +} -result {} + + +test option-10.1 {stack pushing/popping} -body { + option get .op1.op3.op6 x Color1 +} -result blue +test option-10.2 {stack pushing/popping} -body { + option get .op1.op3.op6 y Color1 +} -result red +test option-10.3 {stack pushing/popping} -body { + option get .op1.op3.op6 z Color1 +} -result red +test option-10.4 {stack pushing/popping} -body { + option get .op1.op3.op6 x Color2 +} -result black +test option-10.5 {stack pushing/popping} -body { + option get .op1.op3.op6 y Color2 +} -result black +test option-10.6 {stack pushing/popping} -body { + option get .op1.op3.op6 z Color2 +} -result black + + +test option-11.1 {stack pushing/popping} -body { + option get .op1.op3 x Color1 +} -result yellow +test option-11.2 {stack pushing/popping} -body { + option get .op1.op3 y Color1 +} -result red +test option-11.3 {stack pushing/popping} -body { + option get .op1.op3 z Color1 +} -result red +test option-11.4 {stack pushing/popping} -body { + option get .op1.op3 x Color2 +} -result yellow +test option-11.5 {stack pushing/popping} -body { + option get .op1.op3 y Color2 +} -result {} +test option-11.6 {stack pushing/popping} -body { + option get .op1.op3 z Color2 +} -result {} + + +test option-12.1 {stack pushing/popping} -body { + option get .op1 x Color1 +} -result green +test option-12.2 {stack pushing/popping} -body { + option get .op1 y Color1 +} -result red +test option-12.3 {stack pushing/popping} -body { + option get .op1 z Color1 +} -result red +test option-12.4 {stack pushing/popping} -body { + option get .op1 x Color2 +} -result green +test option-12.5 {stack pushing/popping} -body { + option get .op1 y Color2 +} -result {} +test option-12.6 {stack pushing/popping} -body { + option get .op1 z Color2 +} -result {} # Test the major priority levels (widgetDefault, etc.) +# Configurations for tests 13.* +option clear option add $appName.op1.a 100 100 option add $appName.op1.A interactive interactive option add $appName.op1.b userDefault userDefault @@ -136,92 +294,127 @@ option add $appName.op1.B startupFile startupFile option add $appName.op1.c widgetDefault widgetDefault option add $appName.op1.C 0 0 -test option-13.1 {priority levels} {option get .op1 a A} 100 -test option-13.2 {priority levels} {option get .op1 b A} interactive -test option-13.3 {priority levels} {option get .op1 b B} userDefault -test option-13.4 {priority levels} {option get .op1 c B} startupFile -test option-13.5 {priority levels} {option get .op1 c C} widgetDefault +test option-13.1 {priority levels} -body { + option get .op1 a A +} -result 100 +test option-13.2 {priority levels} -body { + option get .op1 b A +} -result interactive +test option-13.3 {priority levels} -body { + option get .op1 b B +} -result userDefault +test option-13.4 {priority levels} -body { + option get .op1 c B +} -result startupFile +test option-13.5 {priority levels} -body { + option get .op1 c C +} -result widgetDefault option add $appName.op1.B file2 widget -test option-13.6 {priority levels} {option get .op1 c B} startupFile +test option-13.6 {priority levels} -body { + option get .op1 c B +} -result startupFile option add $appName.op1.B file2 startupFile -test option-13.7 {priority levels} {option get .op1 c B} file2 +test option-13.7 {priority levels} -body { + option get .op1 c B +} -result file2 + # Test various error conditions -test option-14.1 {error conditions} { - list [catch {option} msg] $msg -} {1 {wrong # args: should be "option cmd arg ?arg ...?"}} -test option-14.2 {error conditions} { - list [catch {option x} msg] $msg -} {1 {bad option "x": must be add, clear, get, or readfile}} -test option-14.3 {error conditions} { - list [catch {option foo 3} msg] $msg -} {1 {bad option "foo": must be add, clear, get, or readfile}} -test option-14.4 {error conditions} { - list [catch {option add 3} msg] $msg -} {1 {wrong # args: should be "option add pattern value ?priority?"}} -test option-14.5 {error conditions} { - list [catch {option add . a b c} msg] $msg -} {1 {wrong # args: should be "option add pattern value ?priority?"}} -test option-14.6 {error conditions} { - list [catch {option add . a -1} msg] $msg -} {1 {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}} -test option-14.7 {error conditions} { - list [catch {option add . a 101} msg] $msg -} {1 {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}} -test option-14.8 {error conditions} { - list [catch {option add . a gorp} msg] $msg -} {1 {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}} -test option-14.9 {error conditions} { - list [catch {option get 3} msg] $msg -} {1 {wrong # args: should be "option get window name class"}} -test option-14.10 {error conditions} { - list [catch {option get 3 4} msg] $msg -} {1 {wrong # args: should be "option get window name class"}} -test option-14.11 {error conditions} { - list [catch {option get 3 4 5 6} msg] $msg -} {1 {wrong # args: should be "option get window name class"}} -test option-14.12 {error conditions} { - list [catch {option get .gorp.gorp a A} msg] $msg -} {1 {bad window path name ".gorp.gorp"}} +test option-14.1 {error conditions} -body { + option +} -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"} +test option-14.2 {error conditions} -body { + option x +} -returnCodes error -result {bad option "x": must be add, clear, get, or readfile} +test option-14.3 {error conditions} -body { + option foo 3 +} -returnCodes error -result {bad option "foo": must be add, clear, get, or readfile} +test option-14.4 {error conditions} -body { + option add 3 +} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"} +test option-14.5 {error conditions} -body { + option add . a b c +} -returnCodes error -result {wrong # args: should be "option add pattern value ?priority?"} +test option-14.6 {error conditions} -body { + option add . a -1 +} -returnCodes error -result {bad priority level "-1": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} +test option-14.7 {error conditions} -body { + option add . a 101 +} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} +test option-14.8 {error conditions} -body { + option add . a gorp +} -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} +test option-14.9 {error conditions} -body { + option get 3 +} -returnCodes error -result {wrong # args: should be "option get window name class"} +test option-14.10 {error conditions} -body { + option get 3 4 +} -returnCodes error -result {wrong # args: should be "option get window name class"} +test option-14.11 {error conditions} -body { + option get 3 4 5 6 +} -returnCodes error -result {wrong # args: should be "option get window name class"} +test option-14.12 {error conditions} -body { + option get .gorp.gorp a A +} -returnCodes error -result {bad window path name ".gorp.gorp"} + set option1 [file join [testsDirectory] option.file1] -set option2 [file join [testsDirectory] option.file2] - -test option-15.1 {database files} { - list [catch {option read non-existent} msg] $msg -} {1 {couldn't open "non-existent": no such file or directory}} -option read $option1 -test option-15.2 {database files} {option get . x1 color} blue -test option-15.3 {database files} appNameIsTktest {option get . x2 color} green -test option-15.4 {database files} {option get . x3 color} purple -test option-15.5 {database files} {option get . {x 4} color} brown -test option-15.6 {database files} {option get . x6 color} {} -test option-15.7 {database files} { - list [catch {option read $option1 widget foo} msg] $msg -} {1 {wrong # args: should be "option readfile fileName ?priority?"}} -option add *x3 burgundy -catch {option read $option1 userDefault} -test option-15.8 {database files} {option get . x3 color} burgundy -test option-15.9 {database files} { - list [catch {option read $option2} msg] $msg -} {1 {missing colon on line 2}} - -test option-16.1 {ReadOptionFile} { +test option-15.1 {database files} -body { + option read non-existent +} -returnCodes error -result {couldn't open "non-existent": no such file or directory} +test option-15.2 {database files} -body { + option read $option1 + option get . x1 color +} -result blue +test option-15.3 {database files} -constraints appNameIsTktest -body { + option read $option1 + option get . x2 color +} -result green +test option-15.4 {database files} -body { + option read $option1 + option get . x3 color +} -result purple +test option-15.5 {database files} -body { + option read $option1 + option get . {x 4} color +} -result brown +test option-15.6 {database files} -body { + option read $option1 + option get . x6 color +} -result {} +test option-15.7 {database files} -body { + option read $option1 widget foo +} -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"} + +test option-15.8 {database files} -body { + option add *x3 burgundy + catch {option read $option1 userDefault} + option get . x3 color +} -result burgundy +test option-15.9 {database files} -body { + set option2 [file join [testsDirectory] option.file2] + option read $option2 +} -returnCodes error -result {missing colon on line 2} + + +test option-16.1 {ReadOptionFile} -body { set option3 [makeFile {} option.file3] set file [open $option3 w] fconfigure $file -translation crlf puts $file "*x7: true\n*x8: false" close $file option read $option3 userDefault - set result [list [option get . x7 color] [option get . x8 color]] + list [option get . x7 color] [option get . x8 color] +} -cleanup { removeFile $option3 - set result -} {true false} +} -result {true false} -catch {destroy .op1} -catch {destroy .op2} +deleteWindows # cleanup cleanupTests return + + + diff --git a/tests/pack.test b/tests/pack.test index edb9f18..eac1562 100644 --- a/tests/pack.test +++ b/tests/pack.test @@ -6,43 +6,15 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -# Utility procedures: - -proc pack1 {args} { - pack forget .pack.a .pack.b .pack.c .pack.d - eval pack .pack.a $args - pack .pack.b -expand yes -fill both - update - list [winfo geometry .pack.a] [winfo geometry .pack.b] -} -proc pack2 {args} { - pack forget .pack.a .pack.b .pack.c .pack.d - eval pack .pack.a $args - update - winfo geometry .pack.a -} -proc pack3 {args} { - pack forget .pack.a .pack.b .pack.c .pack.d - pack .pack.a -side top - pack .pack.c -side left - eval pack .pack.b $args - update - winfo geometry .pack.b -} -proc pack4 {option value} { - pack forget .pack.a .pack.b .pack.c .pack.d - pack .pack.a $option $value - set i [pack info .pack.a] - lindex $i [expr [lsearch -exact $i $option]+1] -} # Create some test windows. -catch {destroy .pack} +destroy .pack toplevel .pack wm geom .pack 300x200+0+0 wm minsize .pack 1 1 @@ -57,400 +29,767 @@ foreach i {a b c d} { .pack.c config -width 80 -height 80 .pack.d config -width 40 -height 30 -test pack-1.1 {-side option} { - pack1 -side top -} {20x40+140+0 300x160+0+40} -test pack-1.2 {-side option} { - pack1 -side bottom -} {20x40+140+160 300x160+0+0} -test pack-1.3 {-side option} { - pack1 -side left -} {20x40+0+80 280x200+20+0} -test pack-1.4 {-side option} { - pack1 -side right -} {20x40+280+80 280x200+0+0} +test pack-1.1 {-side option} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+0 300x160+0+40} +test pack-1.2 {-side option} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side bottom + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+160 300x160+0+0} +test pack-1.3 {-side option} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side left + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+0+80 280x200+20+0} +test pack-1.4 {-side option} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+280+80 280x200+0+0} -test pack-2.1 {x padding and filling} { - pack1 -side right -padx 20 -} {20x40+260+80 240x200+0+0} -test pack-2.1.1 {x padding and filling} { - pack1 -side right -padx {10 30} -} {20x40+250+80 240x200+0+0} -test pack-2.1.2 {x padding and filling} { - pack1 -side right -padx {35 5} -} {20x40+275+80 240x200+0+0} -test pack-2.2 {x padding and filling} { - pack1 -side right -ipadx 20 -} {60x40+240+80 240x200+0+0} -test pack-2.3 {x padding and filling} { - pack1 -side right -ipadx 5 -padx 10 -} {30x40+260+80 250x200+0+0} -test pack-2.4 {x padding and filling} { - pack1 -side right -padx 20 -fill x -} {20x40+260+80 240x200+0+0} -test pack-2.4.1 {x padding and filling} { - pack1 -side right -padx {9 31} -fill x -} {20x40+249+80 240x200+0+0} -test pack-2.5 {x padding and filling} { - pack1 -side right -ipadx 20 -fill x -} {60x40+240+80 240x200+0+0} -test pack-2.6 {x padding and filling} { - pack1 -side right -ipadx 5 -padx 10 -fill x -} {30x40+260+80 250x200+0+0} -test pack-2.6.1 {x padding and filling} { - pack1 -side right -ipadx 5 -padx {5 15} -fill x -} {30x40+255+80 250x200+0+0} -test pack-2.7 {x padding and filling} { - pack1 -side top -padx 20 -} {20x40+140+0 300x160+0+40} -test pack-2.7.1 {x padding and filling} { - pack1 -side top -padx {0 40} -} {20x40+120+0 300x160+0+40} -test pack-2.7.2 {x padding and filling} { - pack1 -side top -padx {31 9} -} {20x40+151+0 300x160+0+40} -test pack-2.8 {x padding and filling} { - pack1 -side top -ipadx 20 -} {60x40+120+0 300x160+0+40} -test pack-2.9 {x padding and filling} { - pack1 -side top -ipadx 5 -padx 10 -} {30x40+135+0 300x160+0+40} -test pack-2.9.1 {x padding and filling} { - pack1 -side top -ipadx 5 -padx {5 15} -} {30x40+130+0 300x160+0+40} -test pack-2.10 {x padding and filling} { - pack1 -side top -padx 20 -fill x -} {260x40+20+0 300x160+0+40} -test pack-2.10.1 {x padding and filling} { - pack1 -side top -padx {25 15} -fill x -} {260x40+25+0 300x160+0+40} -test pack-2.11 {x padding and filling} { - pack1 -side top -ipadx 20 -fill x -} {300x40+0+0 300x160+0+40} -test pack-2.12 {x padding and filling} { - pack1 -side top -ipadx 5 -padx 10 -fill x -} {280x40+10+0 300x160+0+40} -test pack-2.12a {x padding and filling} { - pack1 -side top -ipadx 5 -padx {5 15} -fill x -} {280x40+5+0 300x160+0+40} -set pad [winfo pixels .pack 1c] -test pack-2.13 {x padding and filling} { + +test pack-2.1 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -padx 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+260+80 240x200+0+0} +test pack-2.2 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -padx {10 30} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+250+80 240x200+0+0} +test pack-2.3 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -padx {35 5} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+275+80 240x200+0+0} +test pack-2.4 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipadx 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {60x40+240+80 240x200+0+0} +test pack-2.5 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipadx 5 -padx 10 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {30x40+260+80 250x200+0+0} +test pack-2.6 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -padx 20 -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+260+80 240x200+0+0} +test pack-2.7 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -padx {9 31} -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+249+80 240x200+0+0} +test pack-2.8 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipadx 20 -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {60x40+240+80 240x200+0+0} +test pack-2.9 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipadx 5 -padx 10 -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {30x40+260+80 250x200+0+0} +test pack-2.10 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipadx 5 -padx {5 15} -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {30x40+255+80 250x200+0+0} +test pack-2.11 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -padx 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+0 300x160+0+40} +test pack-2.12 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -padx {0 40} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+120+0 300x160+0+40} +test pack-2.13 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -padx {31 9} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+151+0 300x160+0+40} +test pack-2.14 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {60x40+120+0 300x160+0+40} +test pack-2.15 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {30x40+135+0 300x160+0+40} +test pack-2.16 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx {5 15} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {30x40+130+0 300x160+0+40} +test pack-2.17 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -padx 20 -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {260x40+20+0 300x160+0+40} +test pack-2.18 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -padx {25 15} -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {260x40+25+0 300x160+0+40} +test pack-2.19 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 20 -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {300x40+0+0 300x160+0+40} +test pack-2.20 {x padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {280x40+10+0 300x160+0+40} +test pack-2.21 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx {5 15} -fill x + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {280x40+5+0 300x160+0+40} + +test pack-2.22 {x padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -padx 1c set x [pack info .pack.a] - lindex $x [expr [lsearch -exact $x -padx]+1] -} $pad -test pack-2.14 {x padding and filling} { + set res1 [lindex $x [expr [lsearch -exact $x -padx]+1]] + set res2 [winfo pixels .pack 1c] + expr {$res1 eq $res2} +} -result 1 +test pack-2.23 {x padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -ipadx 1c set x [pack info .pack.a] - lindex $x [expr [lsearch -exact $x -ipadx]+1] -} $pad + set res1 [lindex $x [expr [lsearch -exact $x -ipadx]+1]] + set res2 [winfo pixels .pack 1c] + expr {$res1 eq $res2} +} -result 1 -test pack-3.1 {y padding and filling} { - pack1 -side right -pady 20 -} {20x40+280+80 280x200+0+0} -test pack-3.1.1 {y padding and filling} { - pack1 -side right -pady {5 35} -} {20x40+280+65 280x200+0+0} -test pack-3.1.2 {y padding and filling} { - pack1 -side right -pady {40 0} -} {20x40+280+100 280x200+0+0} -test pack-3.2 {y padding and filling} { - pack1 -side right -ipady 20 -} {20x80+280+60 280x200+0+0} -test pack-3.3 {y padding and filling} { - pack1 -side right -ipady 5 -pady 10 -} {20x50+280+75 280x200+0+0} -test pack-3.3.1 {y padding and filling} { - pack1 -side right -ipady 5 -pady {5 15} -} {20x50+280+70 280x200+0+0} -test pack-3.4 {y padding and filling} { - pack1 -side right -pady 20 -fill y -} {20x160+280+20 280x200+0+0} -test pack-3.4.1 {y padding and filling} { - pack1 -side right -pady {35 5} -fill y -} {20x160+280+35 280x200+0+0} -test pack-3.5 {y padding and filling} { - pack1 -side right -ipady 20 -fill y -} {20x200+280+0 280x200+0+0} -test pack-3.6 {y padding and filling} { - pack1 -side right -ipady 5 -pady 10 -fill y -} {20x180+280+10 280x200+0+0} -test pack-3.6.1 {y padding and filling} { - pack1 -side right -ipady 5 -pady {0 20} -fill y -} {20x180+280+0 280x200+0+0} -test pack-3.7 {y padding and filling} { - pack1 -side top -pady 20 -} {20x40+140+20 300x120+0+80} -test pack-3.7.1 {y padding and filling} { - pack1 -side top -pady {40 0} -} {20x40+140+40 300x120+0+80} -test pack-3.8 {y padding and filling} { - pack1 -side top -ipady 20 -} {20x80+140+0 300x120+0+80} -test pack-3.9 {y padding and filling} { - pack1 -side top -ipady 5 -pady 10 -} {20x50+140+10 300x130+0+70} -test pack-3.9.1 {y padding and filling} { - pack1 -side top -ipady 5 -pady {3 17} -} {20x50+140+3 300x130+0+70} -test pack-3.10 {y padding and filling} { - pack1 -side top -pady 20 -fill y -} {20x40+140+20 300x120+0+80} -test pack-3.10.1 {y padding and filling} { - pack1 -side top -pady {39 1} -fill y -} {20x40+140+39 300x120+0+80} -test pack-3.11 {y padding and filling} { - pack1 -side top -ipady 20 -fill y -} {20x80+140+0 300x120+0+80} -test pack-3.12 {y padding and filling} { - pack1 -side top -ipady 5 -pady 10 -fill y -} {20x50+140+10 300x130+0+70} -test pack-3.12.1 {y padding and filling} { - pack1 -side top -ipady 5 -pady {1 19} -fill y -} {20x50+140+1 300x130+0+70} -set pad [winfo pixels .pack 1c] -test pack-3.13 {y padding and filling} { + +test pack-3.1 {y padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -pady 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+280+80 280x200+0+0} +test pack-3.2 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -pady {5 35} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+280+65 280x200+0+0} +test pack-3.3 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -pady {40 0} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+280+100 280x200+0+0} +test pack-3.4 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipady 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x80+280+60 280x200+0+0} +test pack-3.5 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipady 5 -pady 10 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x50+280+75 280x200+0+0} +test pack-3.6 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipady 5 -pady {5 15} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x50+280+70 280x200+0+0} +test pack-3.7 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -pady 20 -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x160+280+20 280x200+0+0} +test pack-3.8 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -pady {35 5} -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x160+280+35 280x200+0+0} +test pack-3.9 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipady 20 -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x200+280+0 280x200+0+0} +test pack-3.10 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipady 5 -pady 10 -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x180+280+10 280x200+0+0} +test pack-3.11 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side right -ipady 5 -pady {0 20} -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x180+280+0 280x200+0+0} +test pack-3.12 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -pady 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+20 300x120+0+80} +test pack-3.13 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -pady {40 0} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+40 300x120+0+80} +test pack-3.14 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipady 20 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x80+140+0 300x120+0+80} +test pack-3.15 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipady 5 -pady 10 + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x50+140+10 300x130+0+70} +test pack-3.16 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipady 5 -pady {3 17} + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x50+140+3 300x130+0+70} +test pack-3.17 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -pady 20 -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+20 300x120+0+80} +test pack-3.18 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -pady {39 1} -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x40+140+39 300x120+0+80} +test pack-3.19 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipady 20 -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x80+140+0 300x120+0+80} +test pack-3.20 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipady 5 -pady 10 -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x50+140+10 300x130+0+70} +test pack-3.21 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipady 5 -pady {1 19} -fill y + pack .pack.b -expand yes -fill both + update + list [winfo geometry .pack.a] [winfo geometry .pack.b] +} -result {20x50+140+1 300x130+0+70} + +test pack-3.22 {y padding and filling} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -pady 1c set x [pack info .pack.a] - lindex $x [expr [lsearch -exact $x -pady]+1] -} $pad -test pack-3.14 {y padding and filling} { + set res1 [lindex $x [expr [lsearch -exact $x -pady]+1]] + set res2 [winfo pixels .pack 1c] + expr {$res1 eq $res2} +} -result 1 +test pack-3.23 {y padding and filling} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -ipady 1c set x [pack info .pack.a] - lindex $x [expr [lsearch -exact $x -ipady]+1] -} $pad + set res1 [lindex $x [expr [lsearch -exact $x -ipady]+1]] + set res2 [winfo pixels .pack 1c] + expr {$res1 eq $res2} +} -result 1 + + +test pack-4.1 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n + update + winfo geometry .pack.a +} -result {30x70+135+20} +test pack-4.2 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne + update + winfo geometry .pack.a +} -result {30x70+260+20} +test pack-4.3 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e + update + winfo geometry .pack.a +} -result {30x70+260+65} +test pack-4.4 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se + update + winfo geometry .pack.a +} -result {30x70+260+110} +test pack-4.5 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s + update + winfo geometry .pack.a +} -result {30x70+135+110} +test pack-4.6 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw + update + winfo geometry .pack.a +} -result {30x70+10+110} +test pack-4.7 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w + update + winfo geometry .pack.a +} -result {30x70+10+65} +test pack-4.8 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw + update + winfo geometry .pack.a +} -result {30x70+10+20} +test pack-4.9 {anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center + update + winfo geometry .pack.a +} -result {30x70+135+65} -test pack-4.1 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n -} {30x70+135+20} -test pack-4.2 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne -} {30x70+260+20} -test pack-4.3 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e -} {30x70+260+65} -test pack-4.4 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se -} {30x70+260+110} -test pack-4.5 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s -} {30x70+135+110} -test pack-4.6 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw -} {30x70+10+110} -test pack-4.7 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w -} {30x70+10+65} -test pack-4.8 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw -} {30x70+10+20} -test pack-4.9 {anchors} { - pack2 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center -} {30x70+135+65} # Repeat above tests, but with a frame that isn't at (0,0), so that # we can be sure that the frame offset is being added in correctly. -test pack-5.1 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n -} {60x60+160+60} -test pack-5.2 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne -} {60x60+230+60} -test pack-5.3 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e -} {60x60+230+90} -test pack-5.4 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se -} {60x60+230+120} -test pack-5.5 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s -} {60x60+160+120} -test pack-5.6 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw -} {60x60+90+120} -test pack-5.7 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w -} {60x60+90+90} -test pack-5.8 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw -} {60x60+90+60} -test pack-5.9 {more anchors} { - pack3 -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center -} {60x60+160+90} +test pack-5.1 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor n + update + winfo geometry .pack.b +} -result {60x60+160+60} +test pack-5.2 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor ne + update + winfo geometry .pack.b +} -result {60x60+230+60} +test pack-5.3 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor e + update + winfo geometry .pack.b +} -result {60x60+230+90} +test pack-5.4 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor se + update + winfo geometry .pack.b +} -result {60x60+230+120} +test pack-5.5 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor s + update + winfo geometry .pack.b +} -result {60x60+160+120} +test pack-5.6 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor sw + update + winfo geometry .pack.b +} -result {60x60+90+120} +test pack-5.7 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor w + update + winfo geometry .pack.b +} -result {60x60+90+90} +test pack-5.8 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor nw + update + winfo geometry .pack.b +} -result {60x60+90+60} +test pack-5.9 {more anchors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side top + pack .pack.c -side left + pack .pack.b -side top -ipadx 5 -padx 10 -ipady 15 -pady 20 -expand y -anchor center + update + winfo geometry .pack.b +} -result {60x60+160+90} + -test pack-6.1 {-expand option} { +test pack-6.1 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side left update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+0+80 50x30+20+85 80x80+70+60 40x30+150+85} -test pack-6.2 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+0+80 50x30+20+85 80x80+70+60 40x30+150+85} +test pack-6.2 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side left -expand yes pack .pack.b -side left pack .pack.c .pack.d -side left -expand 1 update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+18+80 50x30+56+85 80x80+124+60 40x30+241+85} -test pack-6.3 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+18+80 50x30+56+85 80x80+124+60 40x30+241+85} +test pack-6.3 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+140+0 50x30+125+40 80x80+110+70 40x30+130+150} -test pack-6.4 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+140+0 50x30+125+40 80x80+110+70 40x30+130+150} +test pack-6.4 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side top -expand yes pack .pack.b -side top pack .pack.c .pack.d -side top -expand 1 update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+140+3 50x30+125+46 80x80+110+79 40x30+130+166} -test pack-6.5 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+140+3 50x30+125+46 80x80+110+79 40x30+130+166} +test pack-6.5 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side right update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+280+80 50x30+230+85 80x80+150+60 40x30+110+85} -test pack-6.6 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+280+80 50x30+230+85 80x80+150+60 40x30+110+85} +test pack-6.6 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side right -expand yes pack .pack.b -side right pack .pack.c .pack.d -side right -expand 1 update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+262+80 50x30+194+85 80x80+95+60 40x30+18+85} -test pack-6.7 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+262+80 50x30+194+85 80x80+95+60 40x30+18+85} +test pack-6.7 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side bottom update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+140+160 50x30+125+130 80x80+110+50 40x30+130+20} -test pack-6.8 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+140+160 50x30+125+130 80x80+110+50 40x30+130+20} +test pack-6.8 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side bottom -expand yes pack .pack.b -side bottom pack .pack.c .pack.d -side bottom -expand 1 update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {20x40+140+157 50x30+125+124 80x80+110+40 40x30+130+3} -test pack-6.9 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {20x40+140+157 50x30+125+124 80x80+110+40 40x30+130+3} +test pack-6.9 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side bottom -expand yes -fill both pack .pack.b -side right pack .pack.c -side top -expand 1 -fill both pack .pack.d -side left update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {300x65+0+135 50x30+250+52 250x105+0+0 40x30+0+105} -test pack-6.10 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {300x65+0+135 50x30+250+52 250x105+0+0 40x30+0+105} +test pack-6.10 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side left -expand yes -fill both pack .pack.b -side top pack .pack.c -side right -expand 1 -fill both pack .pack.d -side bottom update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {100x200+0+0 50x30+175+0 160x170+140+30 40x30+100+170} -test pack-6.11 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {100x200+0+0 50x30+175+0 160x170+140+30 40x30+100+170} +test pack-6.11 {-expand option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side left -expand yes -fill both pack .pack.b -side top -expand yes -fill both pack .pack.c -side right -expand 1 -fill both pack .pack.d -side bottom -expand yes -fill both update list [winfo geometry .pack.a] [winfo geometry .pack.b] \ - [winfo geometry .pack.c] [winfo geometry .pack.d] -} {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100} -catch {destroy .pack2} -toplevel .pack2 -height 400 -width 400 -wm geometry .pack2 +0+0 -pack propagate .pack2 0 -pack forget .pack2.a .pack2.b .pack2.c .pack2.d -foreach i {w1 w2 w3} { - frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised - label .pack2.$i.l -text $i - place .pack2.$i.l -relwidth 1.0 -relheight 1.0 -} -test pack-6.12 {-expand option} { + [winfo geometry .pack.c] [winfo geometry .pack.d] +} -result {100x200+0+0 200x100+100+0 160x100+140+100 40x100+100+100} + +test pack-6.12 {-expand option} -setup { + toplevel .pack2 -height 400 -width 400 + wm geometry .pack2 +0+0 + pack propagate .pack2 0 + foreach i {w1 w2 w3} { + frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised + label .pack2.$i.l -text $i + place .pack2.$i.l -relwidth 1.0 -relheight 1.0 + } +} -body { pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 -ipady 6 -expand 1 -side left update list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3] -} {38x42+47+179 38x42+180+179 38x42+314+179} -test pack-6.13 {-expand option} { - pack forget .pack2.w1 .pack2.w2 .pack2.w3 +} -cleanup { + destroy .pack2 +} -result {38x42+47+179 38x42+180+179 38x42+314+179} +test pack-6.13 {-expand option} -setup { + toplevel .pack2 -height 400 -width 400 + wm geometry .pack2 +0+0 + pack propagate .pack2 0 + foreach i {w1 w2 w3} { + frame .pack2.$i -width 30 -height 30 -bd 2 -relief raised + label .pack2.$i.l -text $i + place .pack2.$i.l -relwidth 1.0 -relheight 1.0 + } +} -body { pack .pack2.w1 .pack2.w2 .pack2.w3 -padx 5 -ipadx 4 -pady 2 \ - -ipady 6 -expand 1 -side top + -ipady 6 -expand 1 -side top update list [winfo geometry .pack2.w1] [winfo geometry .pack2.w2] [winfo geometry .pack2.w3] -} {38x42+181+45 38x42+181+178 38x42+181+312} -catch {destroy .pack2} +} -cleanup { + destroy .pack2 +} -result {38x42+181+45 38x42+181+178 38x42+181+312} + wm geometry .pack {} -test pack-7.1 {requesting size for parent} { +test pack-7.1 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side left -padx 5 -pady 10 update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {230 100} -test pack-7.2 {requesting size for parent} { +} -result {230 100} +test pack-7.2 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top -padx 5 -pady 10 update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {90 260} -test pack-7.3 {requesting size for parent} { +} -result {90 260} +test pack-7.3 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side right -padx 5 -pady 10 update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {230 100} -test pack-7.4 {requesting size for parent} { +} -result {230 100} +test pack-7.4 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side bottom -padx 5 -pady 10 update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {90 260} -test pack-7.5 {requesting size for parent} { +} -result {90 260} +test pack-7.5 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side top -padx 5 -pady 10 pack .pack.b -side right -padx 5 -pady 10 pack .pack.c -side bottom -padx 5 -pady 10 pack .pack.d -side left -padx 5 -pady 10 update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {150 210} -test pack-7.6 {requesting size for parent} { +} -result {150 210} +test pack-7.6 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side top pack .pack.c -side left pack .pack.d -side bottom update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {120 120} -test pack-7.7 {requesting size for parent} { +} -result {120 120} +test pack-7.7 {requesting size for parent} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side right pack .pack.c -side bottom pack .pack.d -side top update list [winfo reqwidth .pack] [winfo reqheight .pack] -} {100 110} +} -result {100 110} # For the tests below, create a couple of "pad" windows to shrink @@ -466,363 +805,496 @@ pack .pack.right -side right pack .pack.bottom -side bottom pack .pack.a .pack.b .pack.c -side top update -test pack-8.1 {insufficient space} { +test pack-8.1 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x40+30+0 1 50x30+15+40 1 80x80+0+70 1} wm geom .pack 270x250 update -test pack-8.2 {insufficient space} { +test pack-8.2 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x40+25+0 1 50x30+10+40 1 70x30+0+70 1} wm geom .pack 240x220 update -test pack-8.3 {insufficient space} { +test pack-8.3 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x40+10+0 1 40x30+0+40 1 70x30+0+70 0} wm geom .pack 350x350 update -test pack-8.4 {insufficient space} { +test pack-8.4 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x40+65+0 1 50x30+50+40 1 80x80+35+70 1} wm geom .pack {} pack .pack.a -side left pack .pack.b -side right pack .pack.c -side left update -test pack-8.5 {insufficient space} { +test pack-8.5 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} wm geom .pack 320x180 update -test pack-8.6 {insufficient space} { +test pack-8.6 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x30+0+0 1 50x30+70+0 1 50x30+20+0 1} wm geom .pack 250x180 update -test pack-8.7 {insufficient space} { +test pack-8.7 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x30+0+0 1 30x30+20+0 1 50x30+20+0 0} pack forget .pack.b update -test pack-8.8 {insufficient space} { +test pack-8.8 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x30+0+0 1 30x30+20+0 0 30x30+20+0 1} pack .pack.b -side right -after .pack.a wm geom .pack {} update -test pack-8.9 {insufficient space} { +test pack-8.9 {insufficient space} -body { list [winfo geometry .pack.a] [winfo ismapped .pack.a] \ - [winfo geometry .pack.b] [winfo ismapped .pack.b] \ - [winfo geometry .pack.c] [winfo ismapped .pack.c] -} {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} + [winfo geometry .pack.b] [winfo ismapped .pack.b] \ + [winfo geometry .pack.c] [winfo ismapped .pack.c] +} -result {20x40+0+20 1 50x30+100+25 1 80x80+20+0 1} pack forget .pack.right .pack.bottom -test pack-9.1 {window ordering} { + +test pack-9.1 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack .pack.a -after .pack.b pack slaves .pack -} {.pack.b .pack.a .pack.c .pack.d} -test pack-9.2 {window ordering} { +} -result {.pack.b .pack.a .pack.c .pack.d} +test pack-9.2 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack .pack.a -after .pack.a pack slaves .pack -} {.pack.a .pack.b .pack.c .pack.d} -test pack-9.3 {window ordering} { +} -result {.pack.a .pack.b .pack.c .pack.d} +test pack-9.3 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack .pack.a -before .pack.d pack slaves .pack -} {.pack.b .pack.c .pack.a .pack.d} -test pack-9.4 {window ordering} { +} -result {.pack.b .pack.c .pack.a .pack.d} +test pack-9.4 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack .pack.d -before .pack.a pack slaves .pack -} {.pack.d .pack.a .pack.b .pack.c} -test pack-9.5 {window ordering} { +} -result {.pack.d .pack.a .pack.b .pack.c} +test pack-9.5 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack propagate .pack.c 0 pack .pack.a -in .pack.c list [pack slaves .pack] [pack slaves .pack.c] -} {{.pack.b .pack.c .pack.d} .pack.a} -test pack-9.6 {window ordering} { +} -result {{.pack.b .pack.c .pack.d} .pack.a} +test pack-9.6 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack .pack.a -in .pack pack slaves .pack -} {.pack.b .pack.c .pack.d .pack.a} -test pack-9.7 {window ordering} { +} -result {.pack.b .pack.c .pack.d .pack.a} +test pack-9.7 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d -side top pack .pack.a -padx 0 pack slaves .pack -} {.pack.a .pack.b .pack.c .pack.d} -test pack-9.8 {window ordering} { +} -result {.pack.a .pack.b .pack.c .pack.d} +test pack-9.8 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c pack .pack.d pack slaves .pack -} {.pack.a .pack.b .pack.c .pack.d} -test pack-9.9 {window ordering} { +} -result {.pack.a .pack.b .pack.c .pack.d} +test pack-9.9 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d pack .pack.b .pack.d .pack.c -before .pack.a pack slaves .pack -} {.pack.b .pack.d .pack.c .pack.a} -test pack-9.10 {window ordering} { +} -result {.pack.b .pack.d .pack.c .pack.a} +test pack-9.10 {window ordering} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d pack .pack.a .pack.c .pack.d .pack.b -after .pack.a pack slaves .pack -} {.pack.a .pack.c .pack.d .pack.b} +} -result {.pack.a .pack.c .pack.d .pack.b} + -test pack-10.1 {retaining/clearing configuration state} { +test pack-10.1 {retaining/clearing configuration state} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \ - -fill both -expand 1 + -fill both -expand 1 pack forget .pack.a pack .pack.a pack info .pack.a -} {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} -test pack-10.2 {retaining/clearing configuration state} { +} -result {-in .pack -anchor center -expand 0 -fill none -ipadx 0 -ipady 0 -padx 0 -pady 0 -side top} +test pack-10.2 {retaining/clearing configuration state} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a -side bottom -anchor n -padx 1 -pady 2 -ipadx 3 -ipady 4 \ - -fill both -expand 1 + -fill both -expand 1 pack .pack.a -pady 14 pack info .pack.a -} {-in .pack -anchor n -expand 1 -fill both -ipadx 3 -ipady 4 -padx 1 -pady 14 -side bottom} -test pack-10.3 {bad -in window does not change master} { +} -result {-in .pack -anchor n -expand 1 -fill both -ipadx 3 -ipady 4 -padx 1 -pady 14 -side bottom} +test pack-10.3 {bad -in window does not change master} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [winfo manager .pack.a] \ - [catch {pack .pack.a -in .pack.a} err] $err \ - [winfo manager .pack.a] -} {{} 1 {can't pack .pack.a inside itself} {}} +} -body { + set result [list [winfo manager .pack.a]] + catch {pack .pack.a -in .pack.a} + lappend result [winfo manager .pack.a] +} -result {{} {}} +test pack-10.4 {bad -in window does not change master} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + winfo manager .pack.a + pack .pack.a -in .pack.a +} -returnCodes error -result {can't pack .pack.a inside itself} -test pack-11.1 {info option} { - pack4 -in .pack -} .pack -test pack-11.2 {info option} { - pack4 -anchor n -} n -test pack-11.3 {info option} { - pack4 -anchor sw -} sw -test pack-11.4 {info option} { - pack4 -expand yes -} 1 -test pack-11.5 {info option} { - pack4 -expand no -} 0 -test pack-11.6 {info option} { - pack4 -fill x -} x -test pack-11.7 {info option} { - pack4 -fill y -} y -test pack-11.8 {info option} { - pack4 -fill both -} both -test pack-11.9 {info option} { - pack4 -fill none -} none -test pack-11.10 {info option} { - pack4 -ipadx 14 -} 14 -test pack-11.11 {info option} { - pack4 -ipady 22 -} 22 -test pack-11.12 {info option} { - pack4 -padx 2 -} 2 -test pack-11.12.1 {info option} { - pack4 -padx {2 9} -} {2 9} -test pack-11.13 {info option} { - pack4 -pady 3 -} 3 -test pack-11.13.1 {info option} { - pack4 -pady {3 11} -} {3 11} -test pack-11.14 {info option} { - pack4 -side top -} top -test pack-11.15 {info option} { - pack4 -side bottom -} bottom -test pack-11.16 {info option} { - pack4 -side left -} left -test pack-11.17 {info option} { - pack4 -side right -} right -test pack-12.1 {command options and errors} { - list [catch {pack} msg] $msg -} {1 {wrong # args: should be "pack option arg ?arg ...?"}} -test pack-12.2 {command options and errors} { - list [catch {pack foo} msg] $msg -} {1 {wrong # args: should be "pack option arg ?arg ...?"}} -test pack-12.3 {command options and errors} { - list [catch {pack configure x} msg] $msg -} {1 {bad argument "x": must be name of window}} -test pack-12.4 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - pack configure .pack.b .pack.c - pack slaves .pack -} {.pack.b .pack.c} -test pack-12.5 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .foo} msg] $msg -} {1 {bad window path name ".foo"}} -test pack-12.6 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack} msg] $msg -} {1 {can't pack ".pack": it's a top-level window}} -test pack-12.7 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -after .foo} msg] $msg -} {1 {bad window path name ".foo"}} -test pack-12.8 {command options and errors} { +test pack-11.1 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -after .pack.b} msg] $msg -} {1 {window ".pack.b" isn't packed}} -test pack-12.9 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -anchor gorp} msg] $msg -} {1 {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center}} -test pack-12.10 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -before gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test pack-12.11 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -before .pack.b} msg] $msg -} {1 {window ".pack.b" isn't packed}} -test pack-12.12 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -expand "who cares?"} msg] $msg -} {1 {expected boolean value but got "who cares?"}} -test pack-12.13 {command options and errors} { +} -body { + pack .pack.a -in .pack + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -in]+1] +} -result .pack +test pack-11.2 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -fill z} msg] $msg -} {1 {bad fill style "z": must be none, x, y, or both}} -test pack-12.14 {command options and errors} { +} -body { + pack .pack.a -anchor n + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -anchor]+1] +} -result n +test pack-11.3 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -in z} msg] $msg -} {1 {bad window path name "z"}} -set pad [winfo pixels .pack 1c] -test pack-12.15 {command options and errors} { +} -body { + pack .pack.a -anchor sw + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -anchor]+1] +} -result sw +test pack-11.4 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -padx abc} msg] $msg -} {1 {bad pad value "abc": must be positive screen distance}} -test pack-12.15.1 {command options and errors} { +} -body { + pack .pack.a -expand yes + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -expand]+1] +} -result 1 +test pack-11.5 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -padx {5 abc}} msg] $msg -} {1 {bad 2nd pad value "abc": must be positive screen distance}} -test pack-12.16 {command options and errors} { +} -body { + pack .pack.a -expand no + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -expand]+1] +} -result 0 +test pack-11.6 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -padx -1} msg] $msg -} {1 {bad pad value "-1": must be positive screen distance}} -test pack-12.16.1 {command options and errors} { +} -body { + pack .pack.a -fill x + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -fill]+1] +} -result x +test pack-11.7 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -padx {5 -1}} msg] $msg -} {1 {bad 2nd pad value "-1": must be positive screen distance}} -test pack-12.17 {command options and errors} { +} -body { + pack .pack.a -fill y + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -fill]+1] +} -result y +test pack-11.8 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -pady abc} msg] $msg -} {1 {bad pad value "abc": must be positive screen distance}} -test pack-12.17.1 {command options and errors} { +} -body { + pack .pack.a -fill both + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -fill]+1] +} -result both +test pack-11.9 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -pady {0 abc}} msg] $msg -} {1 {bad 2nd pad value "abc": must be positive screen distance}} -test pack-12.18 {command options and errors} { +} -body { + pack .pack.a -fill none + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -fill]+1] +} -result none +test pack-11.10 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -pady -1} msg] $msg -} {1 {bad pad value "-1": must be positive screen distance}} -test pack-12.18.1 {command options and errors} { +} -body { + pack .pack.a -ipadx 14 + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -ipadx]+1] +} -result 14 +test pack-11.11 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -pady {0 -1}} msg] $msg -} {1 {bad 2nd pad value "-1": must be positive screen distance}} -test pack-12.19 {command options and errors} { +} -body { + pack .pack.a -ipady 22 + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -ipady]+1] +} -result 22 +test pack-11.12 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -ipadx abc} msg] $msg -} {1 {bad ipadx value "abc": must be positive screen distance}} -test pack-12.20 {command options and errors} { +} -body { + pack .pack.a -padx 2 + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -padx]+1] +} -result 2 +test pack-11.13 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -ipadx -1} msg] $msg -} {1 {bad ipadx value "-1": must be positive screen distance}} -test pack-12.20.1 {command options and errors} { +} -body { + pack .pack.a -padx {2 9} + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -padx]+1] +} -result {2 9} +test pack-11.14 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -ipadx {5 5}} msg] $msg -} {1 {bad ipadx value "5 5": must be positive screen distance}} -test pack-12.21 {command options and errors} { +} -body { + pack .pack.a -pady 3 + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -pady]+1] +} -result 3 +test pack-11.15 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -ipady abc} msg] $msg -} {1 {bad ipady value "abc": must be positive screen distance}} -test pack-12.22 {command options and errors} { +} -body { + pack .pack.a -pady {3 11} + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -pady]+1] +} -result {3 11} +test pack-11.16 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -ipady -1} msg] $msg -} {1 {bad ipady value "-1": must be positive screen distance}} -test pack-12.22.1 {command options and errors} { +} -body { + pack .pack.a -side top + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -side]+1] +} -result top +test pack-11.17 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -ipady {5 5}} msg] $msg -} {1 {bad ipady value "5 5": must be positive screen distance}} -test pack-12.23 {command options and errors} { +} -body { + pack .pack.a -side bottom + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -side]+1] +} -result bottom +test pack-11.18 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -side bac} msg] $msg -} {1 {bad side "bac": must be top, bottom, left, or right}} -test pack-12.24 {command options and errors} { +} -body { + pack .pack.a -side left + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -side]+1] +} -result left +test pack-11.19 {info option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -lousy bac} msg] $msg -} {1 {bad option "-lousy": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}} -test pack-12.25 {command options and errors} { +} -body { + pack .pack.a -side right + set i [pack info .pack.a] + lindex $i [expr [lsearch -exact $i -side]+1] +} -result right + + +test pack-12.1 {command options and errors} -body { + pack +} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} +test pack-12.2 {command options and errors} -body { + pack foo +} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} +test pack-12.3 {command options and errors} -body { + pack configure x +} -returnCodes error -result {bad argument "x": must be name of window} +test pack-12.4 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack configure .pack.b .pack.c + pack slaves .pack +} -result {.pack.b .pack.c} +test pack-12.5 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -padx} msg] $msg -} {1 {extra option "-padx" (option with no value?)}} -test pack-12.26 {command options and errors} { +} -body { + pack .foo +} -returnCodes error -result {bad window path name ".foo"} +test pack-12.6 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a ? 22} msg] $msg -} {1 {bad option "?": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side}} -test pack-12.27 {command options and errors} { +} -body { + pack .pack +} -returnCodes error -result {can't pack ".pack": it's a top-level window} +test pack-12.7 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -in .} msg] $msg -} {1 {can't pack .pack.a inside .}} -test pack-12.28 {command options and errors} { +} -body { + pack .pack.a -after .foo +} -returnCodes error -result {bad window path name ".foo"} +test pack-12.8 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -after .pack.b +} -returnCodes error -result {window ".pack.b" isn't packed} +test pack-12.9 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -anchor gorp +} -returnCodes error -result {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center} +test pack-12.10 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -before gorp +} -returnCodes error -result {bad window path name "gorp"} +test pack-12.11 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -before .pack.b +} -returnCodes error -result {window ".pack.b" isn't packed} +test pack-12.12 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -expand "who cares?" +} -returnCodes error -result {expected boolean value but got "who cares?"} +test pack-12.13 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -fill z +} -returnCodes error -result {bad fill style "z": must be none, x, y, or both} +test pack-12.14 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -in z +} -returnCodes error -result {bad window path name "z"} +set pad [winfo pixels .pack 1c] +test pack-12.15 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -padx abc +} -returnCodes error -result {bad pad value "abc": must be positive screen distance} +test pack-12.16 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -padx {5 abc} +} -returnCodes error -result {bad 2nd pad value "abc": must be positive screen distance} +test pack-12.17 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -padx -1 +} -returnCodes error -result {bad pad value "-1": must be positive screen distance} +test pack-12.18 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -padx {5 -1} +} -returnCodes error -result {bad 2nd pad value "-1": must be positive screen distance} +test pack-12.19 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -pady abc +} -returnCodes error -result {bad pad value "abc": must be positive screen distance} +test pack-12.20 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -pady {0 abc} +} -returnCodes error -result {bad 2nd pad value "abc": must be positive screen distance} +test pack-12.21 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -pady -1 +} -returnCodes error -result {bad pad value "-1": must be positive screen distance} +test pack-12.22 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -pady {0 -1} +} -returnCodes error -result {bad 2nd pad value "-1": must be positive screen distance} +test pack-12.23 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -ipadx abc +} -returnCodes error -result {bad ipadx value "abc": must be positive screen distance} +test pack-12.24 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -ipadx -1 +} -returnCodes error -result {bad ipadx value "-1": must be positive screen distance} +test pack-12.25 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -ipadx {5 5} +} -returnCodes error -result {bad ipadx value "5 5": must be positive screen distance} +test pack-12.26 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -ipady abc +} -returnCodes error -result {bad ipady value "abc": must be positive screen distance} +test pack-12.27 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -ipady -1 +} -returnCodes error -result {bad ipady value "-1": must be positive screen distance} +test pack-12.28 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -ipady {5 5} +} -returnCodes error -result {bad ipady value "5 5": must be positive screen distance} +test pack-12.29 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -side bac +} -returnCodes error -result {bad side "bac": must be top, bottom, left, or right} +test pack-12.30 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -lousy bac +} -returnCodes error -result {bad option "-lousy": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side} +test pack-12.31 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -padx +} -returnCodes error -result {extra option "-padx" (option with no value?)} +test pack-12.32 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a ? 22 +} -returnCodes error -result {bad option "?": must be -after, -anchor, -before, -expand, -fill, -in, -ipadx, -ipady, -padx, -pady, or -side} +test pack-12.33 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a -in . +} -returnCodes error -result {can't pack .pack.a inside .} +test pack-12.34 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { frame .pack.a.a - list [catch {pack .pack.a.a -in .pack.b} msg] $msg -} {1 {can't pack .pack.a.a inside .pack.b}} -test pack-12.29 {command options and errors} { + pack .pack.a.a -in .pack.b +} -returnCodes error -result {can't pack .pack.a.a inside .pack.b} +test pack-12.35 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack .pack.a -in .pack.a} msg] $msg -} {1 {can't pack .pack.a inside itself}} -test pack-12.30 {command options and errors} { +} -body { + pack .pack.a -in .pack.a +} -returnCodes error -result {can't pack .pack.a inside itself} +test pack-12.36 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a .pack.b .pack.c .pack.d pack forget .pack.a .pack.d pack slaves .pack -} {.pack.b .pack.c} -test pack-12.31 {command options and errors} { +} -result {.pack.b .pack.c} +test pack-12.37 {command options and errors} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { .pack configure -width 300 -height 200 pack propagate .pack 0 pack .pack.a @@ -831,63 +1303,77 @@ test pack-12.31 {command options and errors} { pack propagate .pack 1 update lappend result [winfo reqwidth .pack] [winfo reqheight .pack] - set result -} {300 200 20 40} -test pack-12.32 {command options and errors} { + return $result +} -result {300 200 20 40} +test pack-12.38 {command options and errors} -body { set result [pack propagate .pack.d] pack propagate .pack.d 0 lappend result [pack propagate .pack.d] pack propagate .pack.d 1 lappend result [pack propagate .pack.d] - set result -} {1 0 1} -test pack-12.33 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack propagate .dum} msg] $msg -} {1 {bad window path name ".dum"}} -test pack-12.34 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack propagate .pack foo} msg] $msg -} {1 {expected boolean value but got "foo"}} -test pack-12.35 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack propagate .pack foo bar} msg] $msg -} {1 {wrong # args: should be "pack propagate window ?boolean?"}} -test pack-12.36 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack slaves} msg] $msg -} {1 {wrong # args: should be "pack option arg ?arg ...?"}} -test pack-12.37 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack slaves a b} msg] $msg -} {1 {wrong # args: should be "pack slaves window"}} -test pack-12.38 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack slaves .x} msg] $msg -} {1 {bad window path name ".x"}} -test pack-12.39 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack slaves .pack.a} msg] $msg -} {0 {}} -test pack-12.40 {command options and errors} { - pack forget .pack.a .pack.b .pack.c .pack.d - list [catch {pack lousy .pack} msg] $msg -} {1 {bad option "lousy": must be configure, forget, info, propagate, or slaves}} + return $result +} -result {1 0 1} +test pack-12.39 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack propagate .dum +} -returnCodes error -result {bad window path name ".dum"} +test pack-12.40 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack propagate .pack foo +} -returnCodes error -result {expected boolean value but got "foo"} +test pack-12.41 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack propagate .pack foo bar +} -returnCodes error -result {wrong # args: should be "pack propagate window ?boolean?"} +test pack-12.42 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack slaves +} -returnCodes error -result {wrong # args: should be "pack option arg ?arg ...?"} +test pack-12.43 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack slaves a b +} -returnCodes error -result {wrong # args: should be "pack slaves window"} +test pack-12.44 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack slaves .x +} -returnCodes error -result {bad window path name ".x"} +test pack-12.45 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack slaves .pack.a +} -returnCodes ok -result {} +test pack-12.46 {command options and errors} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack lousy .pack +} -returnCodes error -result {bad option "lousy": must be configure, forget, info, propagate, or slaves} -pack .pack.right -side right -pack .pack.bottom -side bottom -test pack-13.1 {window deletion} { - pack forget .pack.a .pack.b .pack.c .pack.d + +test pack-13.1 {window deletion} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom +} -body { + pack .pack.right -side right + pack .pack.bottom -side bottom pack .pack.a .pack.d .pack.b .pack.c -side top update destroy .pack.d update set result [list [pack slaves .pack] [winfo geometry .pack.a] \ - [winfo geometry .pack.b] [winfo geometry .pack.c]] -} {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70} + [winfo geometry .pack.b] [winfo geometry .pack.c]] +} -result {{.pack.right .pack.bottom .pack.a .pack.b .pack.c} 20x40+30+0 50x30+15+40 80x80+0+70} -test pack-14.1 {respond to changes in expansion} { - pack forget .pack.a .pack.b .pack.c .pack.d + +test pack-14.1 {respond to changes in expansion} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d .pack.right .pack.bottom +} -body { + pack .pack.right -side right + pack .pack.bottom -side bottom wm geom .pack {} pack .pack.a update @@ -898,11 +1384,15 @@ test pack-14.1 {respond to changes in expansion} { pack .pack.a -expand true -fill both update lappend result [winfo geom .pack.a] -} {20x40+0+0 20x40+90+0 200x150+0+0} -wm geom .pack {} +} -cleanup { + wm geom .pack {} +} -result {20x40+0+0 20x40+90+0 200x150+0+0} -test pack-15.1 {managing geometry with -in option} { + +test pack-15.1 {managing geometry with -in option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d + destroy .pack.f +} -body { pack .pack.a -side top frame .pack.f lower .pack.f @@ -916,10 +1406,13 @@ test pack-15.1 {managing geometry with -in option} { pack unpack .pack.a update lappend result [winfo geom .pack.b] -} {50x30+0+40 50x30+0+0} -catch {destroy .pack.f} -test pack-15.2 {managing geometry with -in option} { +} -cleanup { + destroy .pack.f +} -result {50x30+0+40 50x30+0+0} +test pack-15.2 {managing geometry with -in option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d + destroy .pack.f +} -body { frame .pack.f lower .pack.f pack .pack.a -in .pack.f -side top @@ -931,10 +1424,13 @@ test pack-15.2 {managing geometry with -in option} { place forget .pack.f update lappend result [winfo ismapped .pack.a] -} {0 1 20x40+30+45 0} -catch {destroy .pack.f} -test pack-15.3 {managing geometry with -in option} { +} -cleanup { + destroy .pack.f +} -result {0 1 20x40+30+45 0} +test pack-15.3 {managing geometry with -in option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d + destroy .pack.f +} -body { pack .pack.a -side top frame .pack.f lower .pack.f @@ -948,15 +1444,18 @@ test pack-15.3 {managing geometry with -in option} { pack unpack .pack.f update lappend result [winfo ismapped .pack.b] -} {1 0} -catch {destroy .pack.f} -test pack-15.4 {managing geometry with -in option} { +} -cleanup { + destroy .pack.f +} -result {1 0} +test pack-15.4 {managing geometry with -in option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d + destroy .pack.f1 .pack.f2 +} -body { foreach i {1 2} { - frame .pack.f$i -width 100 -height 40 -bd 2 -relief raised - lower .pack.f$i - pack propagate .pack.f$i 0 - pack .pack.f$i -side top + frame .pack.f$i -width 100 -height 40 -bd 2 -relief raised + lower .pack.f$i + pack propagate .pack.f$i 0 + pack .pack.f$i -side top } pack .pack.b -in .pack.f1 -side right update @@ -971,15 +1470,18 @@ test pack-15.4 {managing geometry with -in option} { pack forget .pack.b update lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] -} {50x30+48+5 1 50x30+25+48 1 50x30+25+28 1 50x30+25+28 0} -catch {destroy .pack.f1 .pack.f2} -test pack-15.5 {managing geometry with -in option} { +} -cleanup { + destroy .pack.f1 .pack.f2 +} -result {50x30+48+5 1 50x30+25+48 1 50x30+25+28 1 50x30+25+28 0} +test pack-15.5 {managing geometry with -in option} -setup { pack forget .pack.a .pack.b .pack.c .pack.d + destroy .pack.f1 .pack.f2 +} -body { foreach i {1 2} { - frame .pack.f$i -width 100 -height 20 -bd 2 -relief raised - lower .pack.f$i - pack propagate .pack.f$i 0 - pack .pack.f$i -side top + frame .pack.f$i -width 100 -height 20 -bd 2 -relief raised + lower .pack.f$i + pack propagate .pack.f$i 0 + pack .pack.f$i -side top } pack .pack.b -in .pack.f2 -side top update @@ -988,30 +1490,50 @@ test pack-15.5 {managing geometry with -in option} { pack .pack.a -before .pack.b -side top update lappend result [winfo geometry .pack.b] [winfo ismapped .pack.b] -} {50x16+25+22 1 50x16+25+22 0} -catch {destroy .pack.f1 .pack.f2} +} -cleanup { + destroy .pack.f1 .pack.f2 +} -result {50x16+25+22 1 50x16+25+22 0} + -test pack-16.1 {geometry manager name} { +test pack-16.1 {geometry manager name} -setup { pack forget .pack.a .pack.b .pack.c .pack.d set result {} +} -body { lappend result [winfo manager .pack.a] pack .pack.a lappend result [winfo manager .pack.a] pack forget .pack.a lappend result [winfo manager .pack.a] -} {{} pack {}} +} -result {{} pack {}} + -test pack-17.1 {PackLostSlaveProc procedure} { +test pack-17.1 {PackLostSlaveProc procedure} -setup { pack forget .pack.a .pack.b .pack.c .pack.d +} -body { pack .pack.a update place .pack.a -x 40 -y 10 update - list [winfo manager .pack.a] [winfo geometry .pack.a] \ - [catch {pack info .pack.a} msg] $msg -} {place 20x40+40+10 1 {window ".pack.a" isn't packed}} + list [winfo manager .pack.a] [winfo geometry .pack.a] +} -result {place 20x40+40+10} +test pack-17.2 {PackLostSlaveProc procedure} -setup { + pack forget .pack.a .pack.b .pack.c .pack.d +} -body { + pack .pack.a + update + place .pack.a -x 40 -y 10 + update + winfo manager .pack.a + winfo geometry .pack.a + pack info .pack.a +} -returnCodes error -result {window ".pack.a" isn't packed} + -test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} { +test pack-18.1 {unmap slaves when master unmapped} -constraints { + tempNotPc +} -setup { + eval destroy [winfo child .pack] +} -body { # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big @@ -1034,19 +1556,20 @@ test pack-18.1 {unmap slaves when master unmapped} {tempNotPc} { .pack.a configure -width 200 -height 75 update lappend result [winfo width .pack.a ] [winfo height .pack.a] \ - [winfo ismapped .pack.a] + [winfo ismapped .pack.a] wm deiconify .pack update lappend result [winfo ismapped .pack.a] -} {1 0 200 75 0 1} -test pack-18.2 {unmap slaves when master unmapped} { +} -result {1 0 200 75 0 1} +test pack-18.2 {unmap slaves when master unmapped} -setup { + eval destroy [winfo child .pack] +} -body { # adjust the position of .pack before test to avoid a screen switch # that occurs with window managers that have desktops four times as big # as the screen (screen switch causes scale and other tests to fail). wm geometry .pack +100+100 - eval destroy [winfo child .pack] frame .pack.a -relief raised -bd 2 frame .pack.b -width 70 -height 30 -relief sunken -bd 2 pack .pack.a @@ -1059,15 +1582,17 @@ test pack-18.2 {unmap slaves when master unmapped} { .pack.b configure -width 100 -height 30 update lappend result [winfo width .pack.b ] [winfo height .pack.b] \ - [winfo ismapped .pack.b] + [winfo ismapped .pack.b] wm deiconify .pack update lappend result [winfo ismapped .pack.b] -} {1 0 100 30 0 1} +} -result {1 0 100 30 0 1} + -test pack-19.1 {test respect for internalborder} { +test pack-19.1 {test respect for internalborder} -setup { catch {eval pack forget [pack slaves .pack]} destroy .pack.l .pack.lf +} -body { wm geometry .pack 200x200 frame .pack.l -width 15 -height 10 labelframe .pack.lf -labelwidget .pack.l @@ -1079,12 +1604,13 @@ test pack-19.1 {test respect for internalborder} { .pack.lf configure -labelanchor e -padx 3 -pady 5 update lappend res [winfo geometry .pack.lf.f] +} -cleanup { destroy .pack.l .pack.lf - set res -} {196x188+2+10 177x186+5+7} -test pack-19.2 {test support for minreqsize} { +} -result {196x188+2+10 177x186+5+7} +test pack-19.2 {test support for minreqsize} -setup { catch {eval pack forget [pack slaves .pack]} destroy .pack.l .pack.lf +} -body { wm geometry .pack {} frame .pack.l -width 150 -height 100 labelframe .pack.lf -labelwidget .pack.l @@ -1096,15 +1622,14 @@ test pack-19.2 {test support for minreqsize} { .pack.lf configure -labelanchor ws update lappend res [winfo geometry .pack.lf] +} -cleanup { destroy .pack.l .pack.lf - set res -} {162x127+0+0 172x112+0+0} +} -result {162x127+0+0 172x112+0+0} -destroy .pack -foreach i {pack1 pack2 pack3 pack4} { - rename $i {} -} # cleanup cleanupTests return + + + diff --git a/tests/packgrid.test b/tests/packgrid.test new file mode 100644 index 0000000..355b49d --- /dev/null +++ b/tests/packgrid.test @@ -0,0 +1,250 @@ +# This file is a Tcl script to test out interaction between Tk's "pack" and +# "grid" commands. +# It is organized in the standard fashion for Tcl tests. +# +# Copyright (c) 2008 Peter Spjuth +# All rights reserved. + +package require tcltest 2.2 +eval tcltest::configure $argv +tcltest::loadTestedCommands +namespace import -force tcltest::* + +test packgrid-1.1 {pack and grid in same master} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Basic conflict + grid .g + pack .p +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} + +test packgrid-1.2 {pack and grid in same master} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Basic conflict + pack .p + grid .g +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} + +test packgrid-1.3 {pack and grid in same master} -setup { + grid propagate . false + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Ok if one is non-propagating + grid .g + pack .p +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-1.4 {pack and grid in same master} -setup { + grid propagate . false + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Ok if one is non-propagating + pack .p + grid .g +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-1.5 {pack and grid in same master} -setup { + grid propagate . true + pack propagate . false + label .p -text PACK + label .g -text GRID +} -body { + # Ok if one is non-propagating + grid .g + pack .p +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-1.6 {pack and grid in same master} -setup { + grid propagate . true + pack propagate . false + label .p -text PACK + label .g -text GRID +} -body { + # Ok if one is non-propagating + pack .p + grid .g +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-1.7 {pack and grid in same master} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Basic conflict should stop widget from being handled + grid .g + catch { pack .p } + pack slaves . +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-1.8 {pack and grid in same master} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Basic conflict should stop widget from being handled + pack .p + catch { grid .g } + grid slaves . +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-2.1 {pack and grid in same master, change propagation} -setup { + grid propagate . false + pack propagate . true + label .p -text PACK + label .g -text GRID + pack .p + grid .g + update +} -body { + grid propagate . true +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} + +test packgrid-2.2 {pack and grid in same master, change propagation} -setup { + grid propagate . true + pack propagate . false + label .p -text PACK + label .g -text GRID + pack .p + grid .g + update +} -body { + pack propagate . true +} -returnCodes error -cleanup { + destroy .p + update + destroy .g +} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} + +test packgrid-2.3 {pack and grid in same master, change propagation} -setup { + grid propagate . false + pack propagate . false + label .p -text PACK + label .g -text GRID + pack .p + grid .g + update +} -body { + grid propagate . true + update + pack propagate . true +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} + +test packgrid-2.4 {pack and grid in same master, change propagation} -setup { + grid propagate . false + pack propagate . false + label .p -text PACK + label .g -text GRID + pack .p + grid .g + update +} -body { + pack propagate . true + grid propagate . true +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} + +test packgrid-3.1 {stealing slave} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Ok to steal if the other one is emptied + grid .g + pack .g +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-3.2 {stealing slave} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Ok to steal if the other one is emptied + pack .g + grid .g +} -cleanup { + destroy .p + destroy .g +} -result {} + +test packgrid-3.3 {stealing slave} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Not ok to steal if the other one is not emptied + grid .g + grid .p + pack .g +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager pack inside . which already has slaves managed by grid} + +test packgrid-3.4 {stealing slave} -setup { + grid propagate . true + pack propagate . true + label .p -text PACK + label .g -text GRID +} -body { + # Not ok to steal if the other one is not emptied + pack .g + pack .p + grid .g +} -returnCodes error -cleanup { + destroy .p + destroy .g +} -result {cannot use geometry manager grid inside . which already has slaves managed by pack} + +cleanupTests +return diff --git a/tests/panedwindow.test b/tests/panedwindow.test index c7d84b8..f2e01e8 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -6,123 +6,312 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -set i 1 +deleteWindows +# Panedwindow for tests 1.* panedwindow .p -foreach {testName testData} { - panedwindow-1.1 {-background - "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}} - panedwindow-1.2 {-bd - 4 4 badValue {bad screen distance "badValue"}} - panedwindow-1.3 {-bg - "#ff0000" "#ff0000" non-existent {unknown color name "non-existent"}} - panedwindow-1.4 {-borderwidth - 1.3 1 badValue {bad screen distance "badValue"}} - panedwindow-1.5 {-cursor - arrow arrow badValue {bad cursor spec "badValue"}} - panedwindow-1.6 {-handlesize - 20 20 badValue {bad screen distance "badValue"}} - panedwindow-1.7 {-height - 20 20 badValue {bad screen distance "badValue"}} - panedwindow-1.8 {-opaqueresize - true 1 foo {expected boolean value but got "foo"}} - panedwindow-1.9 {-orient - horizontal horizontal - badValue {bad orient "badValue": must be horizontal or vertical}} - panedwindow-1.10 {-relief - groove groove - 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - panedwindow-1.11 {-sashcursor - arrow arrow badValue {bad cursor spec "badValue"}} - panedwindow-1.12 {-sashpad - 1.3 1 badValue {bad screen distance "badValue"}} - panedwindow-1.13 {-sashrelief - groove groove - 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - panedwindow-1.14 {-sashwidth - 10 10 badValue {bad screen distance "badValue"}} - panedwindow-1.15 {-showhandle - true 1 foo {expected boolean value but got "foo"}} - panedwindow-1.16 {-width - 402 402 badValue {bad screen distance "badValue"}} -} { - lassign $testData optionName goodIn goodOut badIn badOut - test ${testName}(good) "configuration options: $optionName" { - .p configure $optionName $goodIn - list [lindex [.p configure $optionName] 4] [.p cget $optionName] - } [list $goodOut $goodOut] - test ${testName}(bad) "configuration options: $optionName" -body { - .p configure $optionName $badIn - } -returnCodes error -result $badOut - # Reset to default - .p configure $optionName [lindex [.p configure $optionName] 3] -} +# Buttons for tests 1.33 - 1.52 .p add [button .b] .p add [button .c] -foreach {testName testData} { - panedwindow-1a.1 {-after .c .c badValue {bad window path name "badValue"}} - panedwindow-1a.2 {-before .c .c badValue {bad window path name "badValue"}} - panedwindow-1a.3 {-height 10 10 badValue {bad screen distance "badValue"}} - panedwindow-1a.4 {-hide false 0 foo {expected boolean value but got "foo"}} - panedwindow-1a.5 {-minsize 10 10 badValue {bad screen distance "badValue"}} - panedwindow-1a.6 {-padx 1.3 1 badValue {bad screen distance "badValue"}} - panedwindow-1a.7 {-pady 1.3 1 badValue {bad screen distance "badValue"}} - panedwindow-1a.8 {-sticky nsew nesw abcd {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w}} - panedwindow-1a.9 {-stretch alw always foo {bad stretch "foo": must be always, first, last, middle, or never}} - panedwindow-1a.10 {-width 10 10 badValue {bad screen distance "badValue"}} -} { - lassign $testData optionName goodIn goodOut badIn badOut - test ${testName}(good) "configuration options: $optionName" { - .p paneconfigure .b $optionName $goodIn - list [lindex [.p paneconfigure .b $optionName] 4] \ - [.p panecget .b $optionName] - } [list $goodOut $goodOut] - test ${testName}(bad) "configuration options: $optionName" -body { - .p paneconfigure .b $optionName $badIn - } -returnCodes error -result $badOut - # Reset to default - .p paneconfig .b $optionName [lindex [.p paneconfig .b $optionName] 3] -} -destroy .p .b .c - -test panedwindow-2.1 {panedwindow widget command} { - panedwindow .p - set result [list [catch {.p foo} msg] $msg] - destroy .p - set result -} {1 {bad command "foo": must be add, cget, configure, forget, identify, panecget, paneconfigure, panes, proxy, or sash}} +test panedwindow-1.1 {configuration options: -background (good)} -body { + .p configure -background #ff0000 + list [lindex [.p configure -background] 4] [.p cget -background] +} -cleanup { + .p configure -background [lindex [.p configure -background] 3] +} -result {{#ff0000} #ff0000} +test panedwindow-1.2 {configuration options: -background (bad)} -body { + .p configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test panedwindow-1.3 {configuration options: -bd (good)} -body { + .p configure -bd 4 + list [lindex [.p configure -bd] 4] [.p cget -bd] +} -cleanup { + .p configure -bd [lindex [.p configure -bd] 3] +} -result {4 4} +test panedwindow-1.4 {configuration options: -bd (bad)} -body { + .p configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.5 {configuration options: -bg (good)} -body { + .p configure -bg #ff0000 + list [lindex [.p configure -bg] 4] [.p cget -bg] +} -cleanup { + .p configure -bg [lindex [.p configure -bg] 3] +} -result {{#ff0000} #ff0000} +test panedwindow-1.6 {configuration options: -bg (bad)} -body { + .p configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test panedwindow-1.7 {configuration options: -borderwidth (good)} -body { + .p configure -borderwidth 1.3 + list [lindex [.p configure -borderwidth] 4] [.p cget -borderwidth] +} -cleanup { + .p configure -borderwidth [lindex [.p configure -borderwidth] 3] +} -result {1 1} +test panedwindow-1.8 {configuration options: -borderwidth (bad)} -body { + .p configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.9 {configuration options: -cursor (good)} -body { + .p configure -cursor arrow + list [lindex [.p configure -cursor] 4] [.p cget -cursor] +} -cleanup { + .p configure -cursor [lindex [.p configure -cursor] 3] +} -result {arrow arrow} +test panedwindow-1.10 {configuration options: -cursor (bad)} -body { + .p configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test panedwindow-1.11 {configuration options: -handlesize (good)} -body { + .p configure -handlesize 20 + list [lindex [.p configure -handlesize] 4] [.p cget -handlesize] +} -cleanup { + .p configure -handlesize [lindex [.p configure -handlesize] 3] +} -result {20 20} +test panedwindow-1.12 {configuration options: -handlesize (bad)} -body { + .p configure -handlesize badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.13 {configuration options: -height (good)} -body { + .p configure -height 20 + list [lindex [.p configure -height] 4] [.p cget -height] +} -cleanup { + .p configure -height [lindex [.p configure -height] 3] +} -result {20 20} +test panedwindow-1.14 {configuration options: -height (bad)} -body { + .p configure -height badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.15 {configuration options: -opaqueresize (good)} -body { + .p configure -opaqueresize true + list [lindex [.p configure -opaqueresize] 4] [.p cget -opaqueresize] +} -cleanup { + .p configure -opaqueresize [lindex [.p configure -opaqueresize] 3] +} -result {1 1} +test panedwindow-1.16 {configuration options: -opaqueresize (bad)} -body { + .p configure -opaqueresize foo +} -returnCodes error -result {expected boolean value but got "foo"} +test panedwindow-1.17 {configuration options: -orient (good)} -body { + .p configure -orient horizontal + list [lindex [.p configure -orient] 4] [.p cget -orient] +} -cleanup { + .p configure -orient [lindex [.p configure -orient] 3] +} -result {horizontal horizontal} +test panedwindow-1.18 {configuration options: -orient (bad)} -body { + .p configure -orient badValue +} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical} +test panedwindow-1.19 {configuration options: -relief (good)} -body { + .p configure -relief groove + list [lindex [.p configure -relief] 4] [.p cget -relief] +} -cleanup { + .p configure -relief [lindex [.p configure -relief] 3] +} -result {groove groove} +test panedwindow-1.20 {configuration options: -relief (bad)} -body { + .p configure -relief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test panedwindow-1.21 {configuration options: -sashcursor (good)} -body { + .p configure -sashcursor arrow + list [lindex [.p configure -sashcursor] 4] [.p cget -sashcursor] +} -cleanup { + .p configure -sashcursor [lindex [.p configure -sashcursor] 3] +} -result {arrow arrow} +test panedwindow-1.22 {configuration options: -sashcursor (bad)} -body { + .p configure -sashcursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test panedwindow-1.23 {configuration options: -sashpad (good)} -body { + .p configure -sashpad 1.3 + list [lindex [.p configure -sashpad] 4] [.p cget -sashpad] +} -cleanup { + .p configure -sashpad [lindex [.p configure -sashpad] 3] +} -result {1 1} +test panedwindow-1.24 {configuration options: -sashpad (bad)} -body { + .p configure -sashpad badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.25 {configuration options: -sashrelief (good)} -body { + .p configure -sashrelief groove + list [lindex [.p configure -sashrelief] 4] [.p cget -sashrelief] +} -cleanup { + .p configure -sashrelief [lindex [.p configure -sashrelief] 3] +} -result {groove groove} +test panedwindow-1.26 {configuration options: -sashrelief (bad)} -body { + .p configure -sashrelief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test panedwindow-1.27 {configuration options: -sashwidth (good)} -body { + .p configure -sashwidth 10 + list [lindex [.p configure -sashwidth] 4] [.p cget -sashwidth] +} -cleanup { + .p configure -sashwidth [lindex [.p configure -sashwidth] 3] +} -result {10 10} +test panedwindow-1.28 {configuration options: -sashwidth (bad)} -body { + .p configure -sashwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.29 {configuration options: -showhandle (good)} -body { + .p configure -showhandle true + list [lindex [.p configure -showhandle] 4] [.p cget -showhandle] +} -cleanup { + .p configure -showhandle [lindex [.p configure -showhandle] 3] +} -result {1 1} +test panedwindow-1.30 {configuration options: -showhandle (bad)} -body { + .p configure -showhandle foo +} -returnCodes error -result {expected boolean value but got "foo"} +test panedwindow-1.31 {configuration options: -width (good)} -body { + .p configure -width 402 + list [lindex [.p configure -width] 4] [.p cget -width] +} -cleanup { + .p configure -width [lindex [.p configure -width] 3] +} -result {402 402} +test panedwindow-1.32 {configuration options: -width (bad)} -body { + .p configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} + +test panedwindow-1.33 {configuration options: -after (good)} -body { + .p paneconfigure .b -after .c + list [lindex [.p paneconfigure .b -after] 4] \ + [.p panecget .b -after] +} -cleanup { + .p paneconfig .b -after [lindex [.p paneconfig .b -after] 3] +} -result {.c .c} +test panedwindow-1.34 {configuration options: -after (bad)} -body { + .p paneconfigure .b -after badValue +} -returnCodes error -result {bad window path name "badValue"} +test panedwindow-1.35 {configuration options: -before (good)} -body { + .p paneconfigure .b -before .c + list [lindex [.p paneconfigure .b -before] 4] \ + [.p panecget .b -before] +} -cleanup { + .p paneconfig .b -before [lindex [.p paneconfig .b -before] 3] +} -result {.c .c} +test panedwindow-1.36 {configuration options: -before (bad)} -body { + .p paneconfigure .b -before badValue +} -returnCodes error -result {bad window path name "badValue"} +test panedwindow-1.37 {configuration options: -height (good)} -body { + .p paneconfigure .b -height 10 + list [lindex [.p paneconfigure .b -height] 4] \ + [.p panecget .b -height] +} -cleanup { + .p paneconfig .b -height [lindex [.p paneconfig .b -height] 3] +} -result {10 10} +test panedwindow-1.38 {configuration options: -height (bad)} -body { + .p paneconfigure .b -height badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.39 {configuration options: -hide (good)} -body { + .p paneconfigure .b -hide false + list [lindex [.p paneconfigure .b -hide] 4] \ + [.p panecget .b -hide] +} -cleanup { + .p paneconfig .b -hide [lindex [.p paneconfig .b -hide] 3] +} -result {0 0} +test panedwindow-1.40 {configuration options: -hide (bad)} -body { + .p paneconfigure .b -hide foo +} -returnCodes error -result {expected boolean value but got "foo"} +test panedwindow-1.41 {configuration options: -minsize (good)} -body { + .p paneconfigure .b -minsize 10 + list [lindex [.p paneconfigure .b -minsize] 4] \ + [.p panecget .b -minsize] +} -cleanup { + .p paneconfig .b -minsize [lindex [.p paneconfig .b -minsize] 3] +} -result {10 10} +test panedwindow-1.42 {configuration options: -minsize (bad)} -body { + .p paneconfigure .b -minsize badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.43 {configuration options: -padx (good)} -body { + .p paneconfigure .b -padx 1.3 + list [lindex [.p paneconfigure .b -padx] 4] \ + [.p panecget .b -padx] +} -cleanup { + .p paneconfig .b -padx [lindex [.p paneconfig .b -padx] 3] +} -result {1 1} +test panedwindow-1.44 {configuration options: -padx (bad)} -body { + .p paneconfigure .b -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.45 {configuration options: -pady (good)} -body { + .p paneconfigure .b -pady 1.3 + list [lindex [.p paneconfigure .b -pady] 4] \ + [.p panecget .b -pady] +} -cleanup { + .p paneconfig .b -pady [lindex [.p paneconfig .b -pady] 3] +} -result {1 1} +test panedwindow-1.46 {configuration options: -pady (bad)} -body { + .p paneconfigure .b -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.47 {configuration options: -sticky (good)} -body { + .p paneconfigure .b -sticky nsew + list [lindex [.p paneconfigure .b -sticky] 4] \ + [.p panecget .b -sticky] +} -cleanup { + .p paneconfig .b -sticky [lindex [.p paneconfig .b -sticky] 3] +} -result {nesw nesw} +test panedwindow-1.48 {configuration options: -sticky (bad)} -body { + .p paneconfigure .b -sticky abcd +} -returnCodes error -result {bad stickyness value "abcd": must be a string containing zero or more of n, e, s, and w} +test panedwindow-1.49 {configuration options: -stretch (good)} -body { + .p paneconfigure .b -stretch alw + list [lindex [.p paneconfigure .b -stretch] 4] \ + [.p panecget .b -stretch] +} -cleanup { + .p paneconfig .b -stretch [lindex [.p paneconfig .b -stretch] 3] +} -result {always always} +test panedwindow-1.50 {configuration options: -stretch (bad)} -body { + .p paneconfigure .b -stretch foo +} -returnCodes error -result {bad stretch "foo": must be always, first, last, middle, or never} +test panedwindow-1.51 {configuration options: -width (good)} -body { + .p paneconfigure .b -width 10 + list [lindex [.p paneconfigure .b -width] 4] \ + [.p panecget .b -width] +} -cleanup { + .p paneconfig .b -width [lindex [.p paneconfig .b -width] 3] +} -result {10 10} +test panedwindow-1.52 {configuration options: -width (bad)} -body { + .p paneconfigure .b -width badValue +} -returnCodes error -result {bad screen distance "badValue"} +deleteWindows + + +test panedwindow-2.1 {panedwindow widget command} -setup { + deleteWindows +} -body { + panedwindow .p + .p foo +} -cleanup { + deleteWindows +} -returnCodes error -result {bad command "foo": must be add, cget, configure, forget, identify, panecget, paneconfigure, panes, proxy, or sash} -test panedwindow-3.1 {panedwindow panes subcommand} { + +test panedwindow-3.1 {panedwindow panes subcommand} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] .p add [button .c] set result [list [.p panes]] .p forget .b lappend result [.p panes] - destroy .p .b .c - set result -} [list [list .b .c] [list .c]] +} -cleanup { + deleteWindows +} -result [list [list .b .c] [list .c]] + -test panedwindow-4.1 {forget subcommand} { +test panedwindow-4.1 {forget subcommand} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p forget} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p forget widget ?widget ...?\""] -test panedwindow-4.2 {forget subcommand, forget one from start} { + .p forget +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p forget widget ?widget ...?"} +test panedwindow-4.2 {forget subcommand, forget one from start} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] .p add [button .c] set result [list [.p panes]] .p forget .b lappend result [.p panes] - destroy .p .b .c - set result -} [list {.b .c} .c] -test panedwindow-4.3 {forget subcommand, forget one from end} { +} -cleanup { + deleteWindows +} -result [list {.b .c} .c] +test panedwindow-4.3 {forget subcommand, forget one from end} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] .p add [button .c] @@ -131,10 +320,12 @@ test panedwindow-4.3 {forget subcommand, forget one from end} { .p forget .d update lappend result [.p panes] - destroy .p .b .c .d - set result -} [list {.b .c .d} {.b .c}] -test panedwindow-4.4 {forget subcommand, forget multiple} { +} -cleanup { + deleteWindows +} -result [list {.b .c .d} {.b .c}] +test panedwindow-4.4 {forget subcommand, forget multiple} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] .p add [button .c] @@ -143,317 +334,401 @@ test panedwindow-4.4 {forget subcommand, forget multiple} { .p forget .b .c update lappend result [.p panes] - destroy .p .b .c .d - set result -} [list {.b .c .d} .d] -test panedwindow-4.5 {forget subcommand, panes are unmapped} { +} -cleanup { + deleteWindows +} -result [list {.b .c .d} .d] +test panedwindow-4.5 {forget subcommand, panes are unmapped} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] .p add [button .c] pack .p update - set result [list [winfo ismapped .b] [winfo ismapped .c]] .p forget .b update - lappend result [winfo ismapped .b] [winfo ismapped .c] - destroy .p .b .c - - set result -} [list 1 1 0 1] -test panedwindow-4.6 {forget subcommand, changes reqsize of panedwindow} { +} -cleanup { + deleteWindows +} -result [list 1 1 0 1] +test panedwindow-4.6 {forget subcommand, changes reqsize of panedwindow} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [frame .g -width 20 -height 20] set result [list [winfo reqwidth .p]] .p forget .f lappend result [winfo reqwidth .p] - destroy .p .f .g - set result -} [list 44 20] +} -cleanup { + deleteWindows +} -result [list 44 20] + -test panedwindow-5.1 {sash subcommand} { +test panedwindow-5.1 {sash subcommand} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p sash option ?arg ...?\""] -test panedwindow-5.2 {sash subcommand} { + .p sash +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p sash option ?arg ...?"} +test panedwindow-5.2 {sash subcommand} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash foo} msg] $msg] - destroy .p - set result -} [list 1 "bad option \"foo\": must be coord, dragto, mark, or place"] + .p sash foo +} -cleanup { + deleteWindows +} -returnCodes error -result {bad option "foo": must be coord, dragto, mark, or place} -test panedwindow-6.1 {sash coord subcommand, errors} { + +test panedwindow-6.1 {sash coord subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash coord} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p sash coord index\""] -test panedwindow-6.2 {sash coord subcommand, errors} { + .p sash coord +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p sash coord index"} +test panedwindow-6.2 {sash coord subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 - set result [list [catch {.p sash coord 0} msg] $msg] - destroy .p - set result -} [list 1 "invalid sash index"] -test panedwindow-6.3 {sash coord subcommand, errors} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -returnCodes error -result {invalid sash index} +test panedwindow-6.3 {sash coord subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash coord foo} msg] $msg] - destroy .p - set result -} [list 1 "expected integer but got \"foo\""] -test panedwindow-6.4 {sash coord subcommand sashes correctly placed} { + .p sash coord foo +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-6.4 {sash coord subcommand sashes correctly placed} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] - set result [.p sash coord 0] - destroy .p .p.f .p.f2 .p.f3 - set result -} [list 22 0] -test panedwindow-6.5 {sash coord subcommand sashes correctly placed} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 22 0] +test panedwindow-6.5 {sash coord subcommand sashes correctly placed} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] - set result [.p sash coord 1] - destroy .p .p.f .p.f2 .p.f3 - set result -} [list 50 0] -test panedwindow-6.6 {sash coord subcommand, sashes correctly placed} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 50 0] +test panedwindow-6.6 {sash coord subcommand, sashes correctly placed} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \ -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] - set result [.p sash coord 0] - destroy .p .p.f .p.f2 .p.f3 - set result -} [list 0 22] -test panedwindow-6.7 {sash coord subcommand, sashes correctly placed} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 22] +test panedwindow-6.7 {sash coord subcommand, sashes correctly placed} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 -orient vertical \ -showhandle false .p add [frame .p.f -width 20 -height 20] \ [frame .p.f2 -width 20 -height 20] \ [frame .p.f3 -width 20 -height 20] - set result [.p sash coord 1] - destroy .p .p.f .p.f2 .p.f3 - set result -} [list 0 50] -test panedwindow-6.8 {sash coord subcommand, errors} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 0 50] +test panedwindow-6.8 {sash coord subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list \ - [catch {.p sash coord -1} msg] $msg \ - [catch {.p sash coord 0} msg] $msg \ - [catch {.p sash coord 1} msg] $msg \ - ] - destroy .p - set result -} [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] -test panedwindow-6.9 {sash coord subcommand, errors} { + list [catch {.p sash coord -1} msg] $msg \ + [catch {.p sash coord 0} msg] $msg \ + [catch {.p sash coord 1} msg] $msg +} -cleanup { + deleteWindows +} -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] +test panedwindow-6.9 {sash coord subcommand, errors} -setup { + deleteWindows +} -body { # There are no sashes until you have 2 panes panedwindow .p .p add [frame .p.f] - set result [list \ - [catch {.p sash coord -1} msg] $msg \ + list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] $msg \ - [catch {.p sash coord 1} msg] $msg \ - ] - destroy .p - set result -} [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] -test panedwindow-6.10 {sash coord subcommand, errors} { + [catch {.p sash coord 1} msg] $msg +} -cleanup { + deleteWindows +} -result [list 1 "invalid sash index" 1 "invalid sash index" 1 "invalid sash index"] +test panedwindow-6.10 {sash coord subcommand, errors} -setup { + deleteWindows +} -body { # There are no sashes until you have 2 panes panedwindow .p .p add [frame .p.f] [frame .p.f2] - set result [list \ - [catch {.p sash coord -1} msg] $msg \ + list [catch {.p sash coord -1} msg] $msg \ [catch {.p sash coord 0} msg] \ [catch {.p sash coord 1} msg] $msg \ - [catch {.p sash coord 2} msg] $msg \ - ] - destroy .p - set result -} [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"] + [catch {.p sash coord 2} msg] $msg +} -cleanup { + deleteWindows +} -result [list 1 "invalid sash index" 0 1 "invalid sash index" 1 "invalid sash index"] + -test panedwindow-8.1 {sash mark subcommand, errors} { +test panedwindow-7.1 {sash mark subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash mark} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p sash mark index ?x y?\""] -test panedwindow-8.2 {sash mark subcommand, errors} { + .p sash mark +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p sash mark index ?x y?"} +test panedwindow-7.2 {sash mark subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash mark foo} msg] $msg] - destroy .p - set result -} [list 1 "expected integer but got \"foo\""] -test panedwindow-8.3 {sash mark subcommand, errors} { + .p sash mark foo +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-7.3 {sash mark subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash mark 0 foo bar} msg] $msg] - destroy .p - set result -} [list 1 "invalid sash index"] -test panedwindow-8.4 {sash mark subcommand, errors} { + .p sash mark 0 foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {invalid sash index} +test panedwindow-7.4 {sash mark subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - set result [list [catch {.p sash mark 0 foo bar} msg] $msg] - destroy .p .b .c - set result -} [list 1 "expected integer but got \"foo\""] -test panedwindow-8.5 {sash mark subcommand, errors} { + .p sash mark 0 foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-7.5 {sash mark subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - set result [list [catch {.p sash mark 0 0 bar} msg] $msg] - destroy .p .b .c - set result -} [list 1 "expected integer but got \"bar\""] -test panedwindow-8.6 {sash mark subcommand, mark defaults to 0 0} { + .p sash mark 0 0 bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "bar"} +test panedwindow-7.6 {sash mark subcommand, mark defaults to 0 0} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - set result [.p sash mark 0] - destroy .p .b .c - set result -} [list 0 0] -test panedwindow-8.7 {sash mark subcommand, set mark} { + .p sash mark 0 +} -cleanup { + deleteWindows +} -result [list 0 0] +test panedwindow-7.7 {sash mark subcommand, set mark} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] .p sash mark 0 10 10 - set result [.p sash mark 0] - destroy .p .b .c - set result -} [list 10 10] + .p sash mark 0 +} -cleanup { + deleteWindows +} -result [list 10 10] + -test panedwindow-9.1 {sash dragto subcommand, errors} { +test panedwindow-8.1 {sash dragto subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash dragto} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p sash dragto index x y\""] -test panedwindow-9.2 {sash dragto subcommand, errors} { + .p sash dragto +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p sash dragto index x y"} +test panedwindow-8.2 {sash dragto subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash dragto foo bar baz} msg] $msg] - destroy .p - set result -} [list 1 "expected integer but got \"foo\""] -test panedwindow-9.3 {sash dragto subcommand, errors} { + .p sash dragto foo bar baz +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-8.3 {sash dragto subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash dragto 0 foo bar} msg] $msg] - destroy .p - set result -} [list 1 "invalid sash index"] -test panedwindow-9.4 {sash dragto subcommand, errors} { + .p sash dragto 0 foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {invalid sash index} +test panedwindow-8.4 {sash dragto subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - set result [list [catch {.p sash dragto 0 foo bar} msg] $msg] - destroy .p .b .c - set result -} [list 1 "expected integer but got \"foo\""] -test panedwindow-9.5 {sash dragto subcommand, errors} { + .p sash dragto 0 foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-8.5 {sash dragto subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - set result [list [catch {.p sash dragto 0 0 bar} msg] $msg] - destroy .p .b .c - set result -} [list 1 "expected integer but got \"bar\""] + .p sash dragto 0 0 bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "bar"} -test panedwindow-10.1 {sash mark/sash dragto interaction} { + +test panedwindow-9.1 {sash mark/sash dragto interaction} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c -text foobar] .p sash mark 0 10 10 .p sash dragto 0 20 10 - set result [.p sash coord 0] - destroy .p .f .c - set result -} [list 30 0] -test panedwindow-10.2 {sash mark/sash dragto interaction} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 30 0] +test panedwindow-9.2 {sash mark/sash dragto interaction} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical \ -showhandle false .p add [frame .p.f -width 20 -height 20] [button .p.c -text foobar] .p sash mark 0 10 10 .p sash dragto 0 10 20 - set result [.p sash coord 0] - destroy .p .p.f .p.c - set result -} [list 0 30] -test panedwindow-10.3 {sash mark/sash dragto, respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 30] +test panedwindow-9.3 {sash mark/sash dragto, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c] -minsize 15 .p sash mark 0 20 10 .p sash dragto 0 10 10 - set result [.p sash coord 0] - destroy .p .f .c - set result -} [list 15 0] + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 15 0] + -test panedwindow-11.1 {sash place subcommand, errors} { +test panedwindow-10.1 {sash place subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p sash place} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p sash place index x y\""] -test panedwindow-11.2 {sash place subcommand, errors} { - destroy .p + .p sash place +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p sash place index x y"} +test panedwindow-10.2 {sash place subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - list [catch {.p sash place foo bar baz} msg] $msg -} [list 1 "expected integer but got \"foo\""] -test panedwindow-11.3 {sash place subcommand, errors} { - destroy .p + .p sash place foo bar baz +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-10.3 {sash place subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p - list [catch {.p sash place 0 foo bar} msg] $msg -} [list 1 "invalid sash index"] -test panedwindow-11.4 {sash place subcommand, errors} { - destroy .p .b .c + .p sash place 0 foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {invalid sash index} +test panedwindow-10.4 {sash place subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - list [catch {.p sash place 0 foo bar} msg] $msg -} [list 1 "expected integer but got \"foo\""] -test panedwindow-11.5 {sash place subcommand, errors} { - destroy .p .f .c .b + .p sash place 0 foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-10.5 {sash place subcommand, errors} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - list [catch {.p sash place 0 0 bar} msg] $msg -} [list 1 "expected integer but got \"bar\""] -test panedwindow-11.6 {sash place subcommand, moves sash} { - destroy .p .f .c .b + .p sash place 0 0 bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "bar"} +test panedwindow-10.6 {sash place subcommand, moves sash} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [button .c] .p sash place 0 10 0 .p sash coord 0 -} [list 10 0] -test panedwindow-11.7 {sash place subcommand, moves sash} { - destroy .p .f .c +} -cleanup { + deleteWindows +} -result [list 10 0] +test panedwindow-10.7 {sash place subcommand, moves sash} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -orient vertical .p add [frame .f -width 20 -height 20] [button .c] .p sash place 0 0 10 .p sash coord 0 -} [list 0 10] -test panedwindow-11.8 {sash place subcommand, respects minsize} { - destroy .p .f .c +} -cleanup { + deleteWindows +} -result [list 0 10] +test panedwindow-10.8 {sash place subcommand, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c] -minsize 15 .p sash place 0 10 0 .p sash coord 0 -} [list 15 0] -test panedwindow-11.9 {sash place subcommand, respects minsize} { - destroy .p .f .c +} -cleanup { + deleteWindows +} -result [list 15 0] +test panedwindow-10.9 {sash place subcommand, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p .p add [frame .f -width 20 -height 20 -bg pink] - list [catch {.p sash place 0 2 0} msg] $msg -} [list 1 {invalid sash index}] + .p sash place 0 2 0 +} -cleanup { + deleteWindows +} -returnCodes error -result {invalid sash index} + -test panedwindow-12.1 {moving sash changes size of pane to left} { - destroy .p .f .c +test panedwindow-11.1 {moving sash changes size of pane to left} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 4 -showhandle false .p add [frame .f -width 20 -height 20] [button .c -text foobar] -sticky nsew .p sash place 0 30 0 pack .p update winfo width .f -} 30 -test panedwindow-12.2 {moving sash changes size of pane to right} { - destroy .p .f .f2 +} -result 30 +test panedwindow-11.2 {moving sash changes size of pane to right} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20] pack .p @@ -462,16 +737,20 @@ test panedwindow-12.2 {moving sash changes size of pane to right} { .p sash place 0 30 0 update lappend result [winfo width .f2] -} {20 10} -test panedwindow-12.3 {moving sash does not change reqsize of panedwindow} { - destroy .p .f .f2 +} -cleanup { + deleteWindows +} -result {20 10} +test panedwindow-11.3 {moving sash does not change reqsize of panedwindow} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [frame .f2 -width 20 -height 20] .p sash place 0 30 0 winfo reqwidth .p -} 44 -test panedwindow-12.4 {moving sash changes size of pane above} { - destroy .p .f .c +} -result 44 +test panedwindow-11.4 {moving sash changes size of pane above} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [button .c -text foobar] -sticky nsew @@ -479,11 +758,11 @@ test panedwindow-12.4 {moving sash changes size of pane above} { pack .p update set result [winfo height .f] - destroy .p .f .c set result -} 20 -test panedwindow-12.5 {moving sash changes size of pane below} { - destroy .p .f .f2 +} -result 20 +test panedwindow-11.5 {moving sash changes size of pane below} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10] @@ -493,81 +772,92 @@ test panedwindow-12.5 {moving sash changes size of pane below} { .p sash place 0 0 15 update lappend result [winfo height .f2] - destroy .p .f .f2 set result -} {10 5} -test panedwindow-12.6 {moving sash does not change reqsize of panedwindow} { +} -cleanup { + deleteWindows +} -result {10 5} +test panedwindow-11.6 {moving sash does not change reqsize of panedwindow} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10] set result [winfo reqheight .p] .p sash place 0 0 20 lappend result [winfo reqheight .p] - destroy .p .f .f2 set result -} [list 24 24] -test panedwindow-12.7 {moving sash does not alter reqsize of widget} { - destroy .p .f .f2 +} -cleanup { + deleteWindows +} -result [list 24 24] +test panedwindow-11.7 {moving sash does not alter reqsize of widget} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 10] [frame .f2 -width 20 -height 10] set result [winfo reqheight .f] .p sash place 0 0 20 lappend result [winfo reqheight .f] - destroy .p .f .f2 - set result -} [list 10 10] -test panedwindow-12.8 {moving sash restricted to minsize} { - destroy .p .f .c +} -cleanup { + deleteWindows +} -result [list 10 10] +test panedwindow-11.8 {moving sash restricted to minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 20] [button .c] -minsize 15 .p sash place 0 10 0 pack .p update - set result [winfo width .f] - destroy .p .f .c - set result -} 15 -test panedwindow-12.10 {moving sash restricted to minsize} { - destroy .p .f .c + winfo width .f +} -result 15 +test panedwindow-11.9 {moving sash restricted to minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .f -width 20 -height 30] [button .c] -minsize 10 .p sash place 0 0 5 pack .p update - set result [winfo height .f] - destroy .p .f .c - set result -} 10 -test panedwindow-12.12 {moving sash in unmapped window restricted to reqsize} { + winfo height .f +} -result 10 +test panedwindow-11.10 {moving sash in unmapped window restricted to reqsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] set result [list [.p sash coord 0]] .p sash place 0 100 0 lappend result [.p sash coord 0] - destroy .p .f .f2 - set result -} [list {20 0} {40 0}] -test panedwindow-12.13 {moving sash right pushes other sashes} { +} -cleanup { + deleteWindows +} -result [list {20 0} {40 0}] +test panedwindow-11.11 {moving sash right pushes other sashes} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] .p sash place 0 80 0 - set result [list [.p sash coord 0] [.p sash coord 1]] - destroy .p .f .f2 .f3 - set result -} {{60 0} {64 0}} -test panedwindow-12.14 {moving sash left pushes other sashes} { + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{60 0} {64 0}} +test panedwindow-11.12 {moving sash left pushes other sashes} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] .p sash place 1 0 0 - set result [list [.p sash coord 0] [.p sash coord 1]] - destroy .p .f .f2 .f3 - set result -} {{0 0} {4 0}} -test panedwindow-12.15 {move sash in mapped window restricted to visible win} { + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 0} {4 0}} +test panedwindow-11.13 {move sash in mapped window restricted to visible win} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] @@ -575,11 +865,13 @@ test panedwindow-12.15 {move sash in mapped window restricted to visible win} { update .p sash place 1 100 0 update - set result [.p sash coord 1] - destroy .p .f .f2 .f3 - set result -} {46 0} -test panedwindow-12.16 {move sash in mapped window restricted to visible win} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result {46 0} +test panedwindow-11.14 {move sash in mapped window restricted to visible win} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] @@ -587,12 +879,13 @@ test panedwindow-12.16 {move sash in mapped window restricted to visible win} { update .p sash place 1 200 0 update - set result [.p sash coord 1] - destroy .p .f .f2 .f3 - set result -} {96 0} -test panedwindow-12.17 {moving sash into "virtual" space on \ - last pane increases reqsize} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result {96 0} +test panedwindow-11.15 {moving sash into "virtual" space on last pane increases reqsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .f -width 20 -height 30] [frame .f2 -width 20 -height 20] \ [frame .f3 -width 20 -height 30] @@ -602,36 +895,45 @@ test panedwindow-12.17 {moving sash into "virtual" space on \ .p sash place 1 200 0 update lappend result [winfo reqwidth .p] - destroy .p .f .f2 .f3 - set result -} {68 100} +} -cleanup { + deleteWindows +} -result {68 100} -test panedwindow-13.1 {horizontal panedwindow lays out widgets properly} { + +test panedwindow-12.1 {horizontal panedwindow lays out widgets properly} -setup { + deleteWindows + set result {} +} -body { panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2 foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]} pack .p update - set result {} foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]} - destroy .p .p.f .p.f2 .p.f3 - set result -} [list 2 2 28 2 54 2] -test panedwindow-13.2 {vertical panedwindow lays out widgets properly} { + return $result +} -cleanup { + deleteWindows +} -result [list 2 2 28 2 54 2] +test panedwindow-12.2 {vertical panedwindow lays out widgets properly} -setup { + deleteWindows + set result {} +} -body { panedwindow .p -showhandle false -borderwidth 2 -sashpad 2 -sashwidth 2 \ -orient vertical foreach win {.p.f .p.f2 .p.f3} {.p add [frame $win -width 20 -height 10]} pack .p update - set result {} foreach w [.p panes] {lappend result [winfo x $w] [winfo y $w]} - destroy .p .p.f .p.f2 .p.f3 - set result -} [list 2 2 2 18 2 34] -test panedwindow-13.3 {horizontal panedwindow lays out widgets properly} { + return $result +} -cleanup { + deleteWindows +} -result [list 2 2 2 18 2 34] +test panedwindow-12.3 {horizontal panedwindow lays out widgets properly} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach {win color} {.p.f blue .p.f2 green} { - .p add [frame $win -width 20 -height 20 -bg $color] -padx 10 -pady 5 \ - -sticky "" + .p add [frame $win -width 20 -height 20 -bg $color] -padx 10 -pady 5 \ + -sticky "" } pack .p update @@ -641,10 +943,13 @@ test panedwindow-13.3 {horizontal panedwindow lays out widgets properly} { update lappend result [winfo reqwidth .p] [winfo reqheight .p] foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]} - destroy .p .p.f .p.f2 - set result -} [list 80 30 10 5 50 5 60 30 0 5 30 5] -test panedwindow-13.4 {vertical panedwindow lays out widgets properly} { + return $result +} -cleanup { + deleteWindows +} -result [list 80 30 10 5 50 5 60 30 0 5 30 5] +test panedwindow-12.4 {vertical panedwindow lays out widgets properly} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach win {.p.f .p.f2} { @@ -658,10 +963,13 @@ test panedwindow-13.4 {vertical panedwindow lays out widgets properly} { update lappend result [winfo reqwidth .p] [winfo reqheight .p] foreach win {.p.f .p.f2} {lappend result [winfo x $win] [winfo y $win]} - destroy .p .p.f .p.f2 - set result -} [list 40 60 10 5 10 35 40 50 10 0 10 25] -test panedwindow-13.5 {panedwindow respects reqsize of panes when possible} { + return $result +} -cleanup { + deleteWindows +} -result [list 40 60 10 5 10 35 40 50 10 0 10 25] +test panedwindow-12.5 {panedwindow respects reqsize of panes when possible} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -sticky "" place .p -width 40 @@ -670,10 +978,12 @@ test panedwindow-13.5 {panedwindow respects reqsize of panes when possible} { .p.f configure -width 30 update lappend result [winfo width .p.f] - destroy .p .p.f - set result -} [list 20 30] -test panedwindow-13.6 {panedwindow takes explicit widget width over reqwidth} { +} -cleanup { + deleteWindows +} -result [list 20 30] +test panedwindow-12.6 {panedwindow takes explicit widget width over reqwidth} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -width 20 -sticky "" place .p -width 40 @@ -682,29 +992,35 @@ test panedwindow-13.6 {panedwindow takes explicit widget width over reqwidth} { .p.f configure -width 30 update lappend result [winfo width .p.f] - destroy .p .p.f - set result -} [list 20 20] -test panedwindow-13.7 {horizontal panedwindow reqheight is max slave height} { +} -cleanup { + deleteWindows +} -result [list 20 20] +test panedwindow-12.7 {horizontal panedwindow reqheight is max slave height} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 .p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20] set result [winfo reqheight .p] .p.f config -height 40 lappend result [winfo reqheight .p] - destroy .p .p.f .p.f2 - set result -} {20 40} -test panedwindow-13.8 {horizontal panedwindow reqheight is max slave height} { +} -cleanup { + deleteWindows +} -result {20 40} +test panedwindow-12.8 {horizontal panedwindow reqheight is max slave height} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} .p paneconfigure .p.f -height 15 set result [winfo reqheight .p] .p.f config -height 40 lappend result [winfo reqheight .p] - destroy .p .p.f .p.f2 - set result -} {20 20} -test panedwindow-13.9 {panedwindow pane width overrides widget width} { +} -cleanup { + deleteWindows +} -result {20 20} +test panedwindow-12.9 {panedwindow pane width overrides widget width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} .p sash place 0 10 0 @@ -713,10 +1029,12 @@ test panedwindow-13.9 {panedwindow pane width overrides widget width} { set result [winfo width .p.f] .p paneconfigure .p.f -width 30 lappend result [winfo width .p.f] - destroy .p .p.f .p.f2 - set result -} [list 10 10] -test panedwindow-13.10 {panedwindow respects reqsize of panes when possible} { +} -cleanup { + deleteWindows +} -result [list 10 10] +test panedwindow-12.10 {panedwindow respects reqsize of panes when possible} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -sticky "" place .p -height 40 @@ -725,10 +1043,12 @@ test panedwindow-13.10 {panedwindow respects reqsize of panes when possible} { .p.f configure -height 30 update lappend result [winfo height .p.f] - destroy .p .p.f - set result -} [list 20 30] -test panedwindow-13.11 {panedwindow takes explicit height over reqheight} { +} -cleanup { + deleteWindows +} -result [list 20 30] +test panedwindow-12.11 {panedwindow takes explicit height over reqheight} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 .p add [frame .p.f -width 20 -height 20] -height 20 -sticky "" place .p -height 40 @@ -737,20 +1057,24 @@ test panedwindow-13.11 {panedwindow takes explicit height over reqheight} { .p.f configure -height 30 update lappend result [winfo height .p.f] - destroy .p .p.f - set result -} [list 20 20] -test panedwindow-13.12 {vertical panedwindow reqwidth is max slave width} { +} -cleanup { + deleteWindows +} -result [list 20 20] +test panedwindow-12.12 {vertical panedwindow reqwidth is max slave width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical .p add [frame .p.f -width 20 -height 20] [frame .p.f2 -width 20 -height 20] set result [winfo reqwidth .p] .p.f config -width 40 lappend result [winfo reqwidth .p] - destroy .p .p.f .p.f2 - set result -} {20 40} -test panedwindow-13.13 {vertical panedwindow reqwidth is max slave width} { +} -cleanup { + deleteWindows +} -result {20 40} +test panedwindow-12.13 {vertical panedwindow reqwidth is max slave width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} @@ -758,11 +1082,12 @@ test panedwindow-13.13 {vertical panedwindow reqwidth is max slave width} { set result [winfo reqwidth .p] .p.f config -width 40 lappend result [winfo reqwidth .p] - destroy .p .p.f .p.f2 - set result -} {20 20} -test panedwindow-13.14 {panedwindow pane height overrides widget width} { - destroy .p +} -cleanup { + deleteWindows +} -result {20 20} +test panedwindow-12.14 {panedwindow pane height overrides widget width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 4 \ -orient vertical foreach win {.p.f .p.f2} {.p add [frame $win -width 20 -height 20]} @@ -772,32 +1097,34 @@ test panedwindow-13.14 {panedwindow pane height overrides widget width} { set result [winfo height .p.f] .p paneconfigure .p.f -height 30 lappend result [winfo height .p.f] - destroy .p - set result -} [list 10 10] +} -cleanup { + deleteWindows +} -result [list 10 10] -test panedwindow-14.1 {PanestructureProc, widget yields managements} { +test panedwindow-13.1 {PanestructureProc, widget yields managements} -setup { + deleteWindows +} -body { # Check that the panedwindow correctly yields geometry management of # a slave when the slave is destroyed. # This test should not cause a core dump, and it should not cause # a memory leak. - destroy .p .b panedwindow .p .p add [button .b] destroy .p pack .b destroy .b set result "" -} "" -test panedwindow-14.2 {PanedWindowLostSlaveProc, widget yields management} { +} -result {} +test panedwindow-13.2 {PanedWindowLostSlaveProc, widget yields management} -setup { + deleteWindows +} -body { # Check that the paned window correctly yields geometry management of # a slave when some other geometry manager steals the slave from us. # This test should not cause a core dump, and it should not cause a # memory leak. - destroy .p .b panedwindow .p .p add [button .b] pack .p @@ -807,56 +1134,359 @@ test panedwindow-14.2 {PanedWindowLostSlaveProc, widget yields management} { set result [.p panes] destroy .p .b set result -} {} - -set stickysets [list n s e w sn ns en ne wn nw esn nse nsw nsew ""] -set stickygets [list n s e w ns ns ne ne nw nw nes nes nsw nesw ""] -set i 0 -foreach s $stickysets g $stickygets { - test panedwindow-15.[incr i] {panedwindow sticky settings} { - destroy .p .b - panedwindow .p -showhandle false - .p add [button .b] - .p paneconfigure .b -sticky $s - set result [.p panecget .b -sticky] - destroy .p .b - set result - } $g -} - -set i 0 -foreach s [list {} n s e w ns ew nw ne se sw nse nsw sew new news] \ - x [list 10 10 10 20 0 10 0 0 20 20 0 20 0 0 0 0] \ - y [list 10 0 20 10 10 0 10 0 0 20 20 0 0 20 0 0] \ - w [list 20 20 20 20 20 20 40 20 20 20 20 20 20 40 40 40] \ - h [list 20 20 20 20 20 40 20 20 20 20 20 40 40 20 20 40] { - test panedwindow-16.[incr i] {panedwindow sticky works} { - panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 - .p add [frame .p.f -height 20 -width 20 -bg red] -sticky $s - place .p -width 40 -height 40 - update - set result [list $s [winfo x .p.f] [winfo y .p.f] \ - [winfo width .p.f] [winfo height .p.f]] - destroy .p .p.f - set result - } [list $s $x $y $w $h] -} - -test panedwindow-17.1 {setting minsize when pane is too small snaps width} { +} -result {} + + +test panedwindow-14.1 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky n + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {n} +test panedwindow-14.2 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky s + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {s} +test panedwindow-14.3 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky e + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {e} +test panedwindow-14.4 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky w + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {w} +test panedwindow-14.5 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky sn + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {ns} +test panedwindow-14.6 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky ns + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {ns} +test panedwindow-14.7 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky en + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {ne} +test panedwindow-14.8 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky ne + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {ne} +test panedwindow-14.9 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky wn + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {nw} +test panedwindow-14.10 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky nw + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {nw} +test panedwindow-14.11 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky esn + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {nes} +test panedwindow-14.12 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky nse + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {nes} +test panedwindow-14.13 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky nsw + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {nsw} +test panedwindow-14.14 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky nsew + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {nesw} +test panedwindow-14.15 {panedwindow sticky settings} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false + .p add [button .b] + .p paneconfigure .b -sticky "" + .p panecget .b -sticky +} -cleanup { + deleteWindows +} -result {} + + +test panedwindow-15.1 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky {} + place .p -width 40 -height 40 + update + list {} [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {{} 10 10 20 20} +test panedwindow-15.2 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky n + place .p -width 40 -height 40 + update + list n [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {n 10 0 20 20} +test panedwindow-15.3 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky s + place .p -width 40 -height 40 + update + list s [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {s 10 20 20 20} +test panedwindow-15.4 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky e + place .p -width 40 -height 40 + update + list e [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {e 20 10 20 20} +test panedwindow-15.5 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky w + place .p -width 40 -height 40 + update + list w [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {w 0 10 20 20} +test panedwindow-15.6 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ns + place .p -width 40 -height 40 + update + list ns [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {ns 10 0 20 40} +test panedwindow-15.7 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ew + place .p -width 40 -height 40 + update + list ew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {ew 0 10 40 20} +test panedwindow-15.8 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nw + place .p -width 40 -height 40 + update + list nw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {nw 0 0 20 20} +test panedwindow-15.9 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky ne + place .p -width 40 -height 40 + update + list ne [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {ne 20 0 20 20} +test panedwindow-15.10 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky se + place .p -width 40 -height 40 + update + list se [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {se 20 20 20 20} +test panedwindow-15.11 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sw + place .p -width 40 -height 40 + update + list sw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {sw 0 20 20 20} +test panedwindow-15.12 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nse + place .p -width 40 -height 40 + update + list nse [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {nse 20 0 20 40} +test panedwindow-15.13 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky nsw + place .p -width 40 -height 40 + update + list nsw [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {nsw 0 0 20 40} +test panedwindow-15.14 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky sew + place .p -width 40 -height 40 + update + list sew [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {sew 0 20 40 20} +test panedwindow-15.15 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky new + place .p -width 40 -height 40 + update + list new [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {new 0 0 40 20} +test panedwindow-15.16 {panedwindow sticky works} -setup { + deleteWindows +} -body { + panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 + .p add [frame .p.f -height 20 -width 20 -bg red] -sticky news + place .p -width 40 -height 40 + update + list news [winfo x .p.f] [winfo y .p.f] [winfo width .p.f] [winfo height .p.f] +} -cleanup { + deleteWindows +} -result {news 0 0 40 40} + + +test panedwindow-16.1 {setting minsize when pane is too small snaps width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .p.f -height 20 -width 20 -bg red] set result [winfo reqwidth .p] .p paneconfigure .p.f -minsize 40 lappend result [winfo reqwidth .p] - destroy .p .p.f .p.f2 - set result -} [list 20 40] +} -cleanup { + deleteWindows +} -result [list 20 40] + -test panedwindow-18.1 {MoveSash, move right} { +test panedwindow-17.1 {MoveSash, move right} -setup { + deleteWindows set result {} +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window @@ -869,33 +1499,31 @@ test panedwindow-18.1 {MoveSash, move right} { # Check that the sash moved lappend result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 42 42 {30 0}] -test panedwindow-18.2 {MoveSash, move right (unmapped) clipped by reqwidth} { +} -cleanup { + deleteWindows +} -result [list 42 42 {30 0}] +test panedwindow-17.2 {MoveSash, move right (unmapped) clipped by reqwidth} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 100 0 # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 40 0] -test panedwindow-18.3 {MoveSash, move right (mapped, width < reqwidth) clipped by width} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 40 0] +test panedwindow-17.3 {MoveSash, move right (mapped, width < reqwidth) clipped by width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a width < reqwidth @@ -906,17 +1534,16 @@ test panedwindow-18.3 {MoveSash, move right (mapped, width < reqwidth) clipped b # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 30 0] -test panedwindow-18.4 {MoveSash, move right (mapped, width > reqwidth) clipped by width} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 30 0] +test panedwindow-17.4 {MoveSash, move right (mapped, width > reqwidth) clipped by width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a width > reqwidth @@ -927,121 +1554,114 @@ test panedwindow-18.4 {MoveSash, move right (mapped, width > reqwidth) clipped b # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 100 0] -test panedwindow-18.5 {MoveSash, move right respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 100 0] +test panedwindow-17.5 {MoveSash, move right respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 30 0] -test panedwindow-18.6 {MoveSash, move right respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 30 0] +test panedwindow-17.6 {MoveSash, move right respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 40 0] -test panedwindow-18.7 {MoveSash, move right pushes other sashes} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 40 0] +test panedwindow-17.7 {MoveSash, move right pushes other sashes} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 62 0] -test panedwindow-18.8 {MoveSash, move right pushes other sashes, respects minsize} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 62 0] +test panedwindow-17.8 {MoveSash, move right pushes other sashes, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 52 0] -test panedwindow-18.9 {MoveSash, move right respects minsize, exludes pad} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 52 0] +test panedwindow-17.9 {MoveSash, move right respects minsize, exludes pad} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize 10 -padx 5 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize 10 -padx 5 } .p sash place 0 100 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 50 0] -test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 50 0] +test panedwindow-17.10 {MoveSash, move right, negative minsize becomes 0} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize -50 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize -50 } .p sash place 0 50 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [list [.p sash coord 0] [.p sash coord 1]] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list [list 50 0] [list 52 0]] -test panedwindow-18.11 {MoveSash, move left} { + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result [list [list 50 0] [list 52 0]] +test panedwindow-17.11 {MoveSash, move left} -setup { + deleteWindows +} -body { set result {} panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window @@ -1054,139 +1674,132 @@ test panedwindow-18.11 {MoveSash, move left} { # Check that the sash moved lappend result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 42 42 {10 0}] -test panedwindow-18.12 {MoveSash, move left, can't move outside of window} { +} -cleanup { + deleteWindows +} -result [list 42 42 {10 0}] +test panedwindow-17.12 {MoveSash, move left, can't move outside of window} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 -100 0 # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 0] -test panedwindow-18.13 {MoveSash, move left respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 0] +test panedwindow-17.13 {MoveSash, move left respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 10 0] -test panedwindow-18.14 {MoveSash, move left respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 10 0] +test panedwindow-17.14 {MoveSash, move left respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 22 0] -test panedwindow-18.15 {MoveSash, move left pushes other sashes} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 22 0] +test panedwindow-17.15 {MoveSash, move left pushes other sashes} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 0] -test panedwindow-18.16 {MoveSash, move left pushes other sashes, respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 0] +test panedwindow-17.16 {MoveSash, move left pushes other sashes, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 10 0] -test panedwindow-18.17 {MoveSash, move left respects minsize, exludes pad} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 10 0] +test panedwindow-17.17 {MoveSash, move left respects minsize, exludes pad} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize 10 -padx 5 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize 10 -padx 5 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 42 0] -test panedwindow-18.18 {MoveSash, move left, negative minsize becomes 0} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 42 0] +test panedwindow-17.18 {MoveSash, move left, negative minsize becomes 0} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 foreach w {.f1 .f2 .f3} c {red blue green} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize -50 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize -50 } .p sash place 1 10 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [list [.p sash coord 0] [.p sash coord 1]] - - # Cleanup - destroy .p .f1 .f2 .f3 + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result [list [list 8 0] [list 10 0]] - set result -} [list [list 8 0] [list 10 0]] -test panedwindow-19.1 {MoveSash, move down} { +test panedwindow-18.1 {MoveSash, move down} -setup { + deleteWindows +} -body { set result {} panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window @@ -1199,35 +1812,33 @@ test panedwindow-19.1 {MoveSash, move down} { # Check that the sash moved lappend result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 42 42 {0 30}] -test panedwindow-19.2 {MoveSash, move down (unmapped) clipped by reqheight} { +} -cleanup { + deleteWindows +} -result [list 42 42 {0 30}] +test panedwindow-18.2 {MoveSash, move down (unmapped) clipped by reqheight} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 0 100 # Get the new sash coord; it should be clipped by the reqheight of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 40] -test panedwindow-19.3 {MoveSash, move down (mapped, height < reqheight) clipped by height} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 40] +test panedwindow-18.3 {MoveSash, move down (mapped, height < reqheight) clipped by height} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a height < reqheight @@ -1238,18 +1849,17 @@ test panedwindow-19.3 {MoveSash, move down (mapped, height < reqheight) clipped # Get the new sash coord; it should be clipped by the visible height of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 30] -test panedwindow-19.4 {MoveSash, move down (mapped, height > reqheight) clipped by height} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 30] +test panedwindow-18.4 {MoveSash, move down (mapped, height > reqheight) clipped by height} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Put the panedwindow up on the display and give it a width > reqwidth @@ -1260,129 +1870,122 @@ test panedwindow-19.4 {MoveSash, move down (mapped, height > reqheight) clipped # Get the new sash coord; it should be clipped by the visible width of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 100] -test panedwindow-19.5 {MoveSash, move down respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 100] +test panedwindow-18.5 {MoveSash, move down respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 30] -test panedwindow-19.6 {MoveSash, move down respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 30] +test panedwindow-18.6 {MoveSash, move down respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 40] -test panedwindow-19.7 {MoveSash, move down pushes other sashes} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 40] +test panedwindow-18.7 {MoveSash, move down pushes other sashes} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 62] -test panedwindow-19.8 {MoveSash, move down pushes other sashes, respects minsize} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 0 62] +test panedwindow-18.8 {MoveSash, move down pushes other sashes, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 52] -test panedwindow-19.9 {MoveSash, move down respects minsize, exludes pad} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 0 52] +test panedwindow-18.9 {MoveSash, move down respects minsize, exludes pad} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize 10 -pady 5 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize 10 -pady 5 } .p sash place 0 0 100 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 50] -test panedwindow-19.10 {MoveSash, move right, negative minsize becomes 0} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 50] +test panedwindow-18.10 {MoveSash, move right, negative minsize becomes 0} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize -50 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize -50 } .p sash place 0 0 50 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [list [.p sash coord 0] [.p sash coord 1]] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list [list 0 50] [list 0 52]] -test panedwindow-19.11 {MoveSash, move up} { + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result [list [list 0 50] [list 0 52]] +test panedwindow-18.11 {MoveSash, move up} -setup { + deleteWindows +} -body { set result {} panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } # Get the requested width of the paned window @@ -1395,178 +1998,180 @@ test panedwindow-19.11 {MoveSash, move up} { # Check that the sash moved lappend result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 42 42 {0 10}] -test panedwindow-19.12 {MoveSash, move up, can't move outside of window} { +} -cleanup { + deleteWindows +} -result [list 42 42 {0 10}] +test panedwindow-18.12 {MoveSash, move up, can't move outside of window} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 0 0 -100 # Get the new sash coord; it should be clipped by the reqwidth of # the panedwindow. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 0] -test panedwindow-19.13 {MoveSash, move up respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 0] +test panedwindow-18.13 {MoveSash, move up respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 0 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 - - set result -} [list 0 10] -test panedwindow-19.14 {MoveSash, move up respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 10] +test panedwindow-18.14 {MoveSash, move up respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 22] -test panedwindow-19.15 {MoveSash, move up pushes other sashes} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 0 22] +test panedwindow-18.15 {MoveSash, move up pushes other sashes} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 0] -test panedwindow-19.16 {MoveSash, move up pushes other sashes, respects minsize} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 0] +test panedwindow-18.16 {MoveSash, move up pushes other sashes, respects minsize} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 + .p add [frame $w -height 20 -width 20 -bg $c] -sticky nsew -minsize 10 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible while # respecting minsizes. - set result [.p sash coord 0] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 10] -test panedwindow-19.17 {MoveSash, move up respects minsize, exludes pad} { + .p sash coord 0 +} -cleanup { + deleteWindows +} -result [list 0 10] +test panedwindow-18.17 {MoveSash, move up respects minsize, exludes pad} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize 10 -pady 5 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize 10 -pady 5 } .p sash place 1 0 0 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [.p sash coord 1] - - # Cleanup - destroy .p .f1 .f2 .f3 - - set result -} [list 0 42] -test panedwindow-19.18 {MoveSash, move up, negative minsize becomes 0} { + .p sash coord 1 +} -cleanup { + deleteWindows +} -result [list 0 42] +test panedwindow-18.18 {MoveSash, move up, negative minsize becomes 0} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical foreach w {.f1 .f2 .f3} c {red blue green} { - .p add [frame $w -height 20 -width 20 -bg $c] \ - -sticky nsew -minsize -50 + .p add [frame $w -height 20 -width 20 -bg $c] \ + -sticky nsew -minsize -50 } .p sash place 1 0 10 # Get the new sash coord; it should have moved as far as possible, # respecting minsizes. - set result [list [.p sash coord 0] [.p sash coord 1]] - - # Cleanup - destroy .p .f1 .f2 .f3 + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result [list [list 0 8] [list 0 10]] - set result -} [list [list 0 8] [list 0 10]] # The following tests check that the panedwindow is correctly computing its # geometry based on the various configuration options that can affect the # geometry. -test panedwindow-20.1 {ComputeGeometry, reqheight taken from widgets} { +test panedwindow-19.1 {ComputeGeometry, reqheight taken from widgets} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach w {.f1 .f2 .f3} { - .p add [frame $w -width 20 -height 20 -bg blue] + .p add [frame $w -width 20 -height 20 -bg blue] } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .f3 configure -height 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result -} [list [list 60 20] [list 60 40]] -test panedwindow-20.2 {ComputeGeometry, reqheight taken from widgets} { +} -cleanup { + deleteWindows +} -result [list [list 60 20] [list 60 40]] + +test panedwindow-19.2 {ComputeGeometry, reqheight taken from widgets} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach w {.f1 .f2 .f3} { - .p add [frame $w -width 20 -height 20 -bg blue] + .p add [frame $w -width 20 -height 20 -bg blue] } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -height 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result -} [list [list 60 20] [list 60 40]] -test panedwindow-20.3 {ComputeGeometry, reqheight taken from widgets} { +} -cleanup { + deleteWindows +} -result [list [list 60 20] [list 60 40]] + +test panedwindow-19.3 {ComputeGeometry, reqheight taken from widgets} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 foreach w {.f1 .f2 .f3} { - .p add [frame $w -width 20 -height 20 -bg blue] -pady 20 + .p add [frame $w -width 20 -height 20 -bg blue] -pady 20 } set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -height 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result -} [list [list 60 60] [list 60 80]] -test panedwindow-20.4 {ComputeGeometry, reqwidth taken from widgets} { +} -cleanup { + deleteWindows +} -result [list [list 60 60] [list 60 80]] + +test panedwindow-19.4 {ComputeGeometry, reqwidth taken from widgets} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach w {.f1 .f2 .f3} { @@ -1575,10 +2180,13 @@ test panedwindow-20.4 {ComputeGeometry, reqwidth taken from widgets} { set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .f3 configure -width 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result -} [list [list 20 60] [list 40 60]] -test panedwindow-20.5 {ComputeGeometry, reqwidth taken from widgets} { +} -cleanup { + deleteWindows +} -result [list [list 20 60] [list 40 60]] + +test panedwindow-19.5 {ComputeGeometry, reqwidth taken from widgets} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach w {.f1 .f2 .f3} { @@ -1587,10 +2195,13 @@ test panedwindow-20.5 {ComputeGeometry, reqwidth taken from widgets} { set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -width 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result -} [list [list 20 60] [list 40 60]] -test panedwindow-20.6 {ComputeGeometry, reqwidth taken from widgets} { +} -cleanup { + deleteWindows +} -result [list [list 20 60] [list 40 60]] + +test panedwindow-19.6 {ComputeGeometry, reqwidth taken from widgets} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 0 \ -orient vertical foreach w {.f1 .f2 .f3} { @@ -1599,219 +2210,2153 @@ test panedwindow-20.6 {ComputeGeometry, reqwidth taken from widgets} { set result [list [list [winfo reqwidth .p] [winfo reqheight .p]]] .p paneconfigure .f3 -width 40 lappend result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result -} [list [list 60 60] [list 80 60]] - -set i 6 -foreach bd {0 2} { - foreach sp {0 5} { - foreach sw {0 3} { - foreach h {0 1} { - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry, one slave, reqsize set properly} { - # With just one slave, sashpad and sashwidth should not - # affect the panedwindow's geometry, since no sash should - # ever be drawn. - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h - .p add [frame .p.f -width 20 -height 20 -bg red] -padx $h \ +} -cleanup { + deleteWindows +} -result [list [list 60 60] [list 80 60]] + +test panedwindow-19.7 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.8 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {60 20} + +test panedwindow-19.9 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{20 0} {40 0}} + +test panedwindow-19.10 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {53 3 20 20} {95 3 20 20}} + +test panedwindow-19.11 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.12 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" - set result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .p.f - set result - } [list [expr {(2 * $bd) + 20 + (2 * $h)}] \ - [expr {(2 * $bd) + 20}]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry, three panes, reqsize set properly} { - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h - foreach w {.p.f1 .p.f2 .p.f3} { - .p add [frame $w -width 20 -height 20 -bg blue] \ - -sticky "" - } - set result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .p.f1 .p.f2 .p.f3 - set result - } [list [expr {(2 * $bd) + ($h?12:(2*$sw)) + (4*$sp) + 60}] \ - [expr {(2 * $bd) + 20}]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry, sash coords} { - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h - foreach w {.f1 .f2 .f3} { - .p add [frame $w -width 20 -height 20 -bg blue] \ - -sticky "" - } - set result [list [.p sash coord 0] [.p sash coord 1]] - destroy .p .f1 .f2 .f3 - set result - } [list [list [expr {$bd+20+($h?(6-$sw)/2:0)+$sp}] $bd] \ - [list [expr {$bd+40+($h?6+(6-$sw)/2:$sw)+(3*$sp)}] \ - $bd]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry/ArrangePanes, slave coords} { - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h - foreach w {.p.f1 .p.f2 .p.f3} { - .p add [frame $w -width 20 -height 20 -bg blue] \ - -sticky nsew -pady 3 -padx 11 - } - pack .p - update - set result {} - foreach w {.p.f1 .p.f2 .p.f3} { - lappend result [list [winfo x $w] [winfo y $w] \ - [winfo width $w] [winfo height $w]] - } - destroy .p .p.f1 .p.f2 .p.f3 - set result - } [list [list [expr {$bd+11}] [expr {$bd+3}] 20 20] \ - [list [expr {$bd+53+($h?6:$sw)+(2*$sp)}] \ - [expr {$bd+3}] 20 20] \ - [list [expr {$bd+95+($h?12:2*$sw)+(4*$sp)}] \ - [expr {$bd+3}] 20 20]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry, one slave, vertical} { - # With just one slave, sashpad and sashwidth should not - # affect the panedwindow's geometry, since no sash should - # ever be drawn. - panedwindow .p -borderwidth $bd -sashpad $sp \ - -orient vertical -sashwidth $sw -handlesize 6 \ - -showhandle $h - .p add [frame .f -width 20 -height 20 -bg red] -pady $h \ + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 60} + +test panedwindow-19.13 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ -sticky "" - set result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f - set result - } [list [expr {(2 * $bd) + 20}] \ - [expr {(2 * $bd) + 20 + (2 * $h)}]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry, three panes, vertical} { - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h \ - -orient vertical - foreach w {.f1 .f2 .f3} { - .p add [frame $w -width 20 -height 20 -bg blue] \ - -sticky "" - } - set result [list [winfo reqwidth .p] [winfo reqheight .p]] - destroy .p .f1 .f2 .f3 - set result - } [list [expr {(2 * $bd) + 20}] \ - [expr {(2 * $bd) + ($h?12:(2*$sw)) + (4*$sp) + 60}]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry, sash coords, vertical} { - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h \ - -orient vertical - foreach w {.f1 .f2 .f3} { - .p add [frame $w -width 20 -height 20 -bg blue] \ - -sticky "" - } - set result [list [.p sash coord 0] [.p sash coord 1]] - destroy .p .f1 .f2 .f3 - set result - } [list [list $bd [expr {$bd+20+($h?(6-$sw)/2:0)+$sp}]] \ - [list $bd \ - [expr {$bd+40+($h?6+(6-$sw)/2:$sw)+(3*$sp)}]]] - - test panedwindow-20.[incr i]-$bd-$sp-$sw-$h \ - {ComputeGeometry/ArrangePanes, slave coords, vert} { - panedwindow .p -borderwidth $bd -sashpad $sp \ - -sashwidth $sw -handlesize 6 -showhandle $h \ - -orient vertical - foreach w {.p.f1 .p.f2 .p.f3} { - .p add [frame $w -width 20 -height 20 -bg blue] \ - -sticky nsew -pady 11 -padx 3 - } - pack .p - update - set result {} - foreach w {.p.f1 .p.f2 .p.f3} { - lappend result [list [winfo x $w] [winfo y $w] \ - [winfo width $w] [winfo height $w]] - } - destroy .p .p.f1 .p.f2 .p.f3 - set result - } [list [list [expr {$bd+3}] [expr {$bd+11}] 20 20] \ - [list [expr {$bd+3}] \ - [expr {$bd+53+($h?6:$sw)+(2*$sp)}] 20 20] \ - [list [expr {$bd+3}] \ - [expr {$bd+95+($h?12:2*$sw)+(4*$sp)}] 20 20]] - } - } - } -} - -test panedwindow-21.1 {destroyed widgets are removed from panedwindow} { + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 20} {0 40}} + +test panedwindow-19.14 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 53 20 20} {3 95 20 20}} +test panedwindow-19.15 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {22 20} + +test panedwindow-19.16 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {72 20} + +test panedwindow-19.17 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{23 0} {49 0}} + +test panedwindow-19.18 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}} + +test panedwindow-19.19 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 22} + +test panedwindow-19.20 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 72} + +test panedwindow-19.21 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 23} {0 49}} + +test panedwindow-19.22 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}} +test panedwindow-19.23 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.24 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {66 20} + +test panedwindow-19.25 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{20 0} {43 0}} + +test panedwindow-19.26 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {56 3 20 20} {101 3 20 20}} + +test panedwindow-19.27 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.28 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 66} + +test panedwindow-19.29 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 20} {0 43}} + +test panedwindow-19.30 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 56 20 20} {3 101 20 20}} +test panedwindow-19.31 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {22 20} + +test panedwindow-19.32 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {72 20} + +test panedwindow-19.33 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{21 0} {47 0}} + +test panedwindow-19.34 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {59 3 20 20} {107 3 20 20}} + +test panedwindow-19.35 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 0 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 22} + +test panedwindow-19.36 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 72} + +test panedwindow-19.37 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 21} {0 47}} + +test panedwindow-19.38 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 59 20 20} {3 107 20 20}} +test panedwindow-19.39 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.40 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {80 20} + +test panedwindow-19.41 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{25 0} {55 0}} + +test panedwindow-19.42 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {63 3 20 20} {115 3 20 20}} + +test panedwindow-19.43 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.44 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 80} + +test panedwindow-19.45 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 25} {0 55}} + +test panedwindow-19.46 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 63 20 20} {3 115 20 20}} +test panedwindow-19.47 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {22 20} + +test panedwindow-19.48 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {92 20} + +test panedwindow-19.49 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{28 0} {64 0}} + +test panedwindow-19.50 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}} + +test panedwindow-19.51 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 22} + +test panedwindow-19.52 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 92} + +test panedwindow-19.53 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 28} {0 64}} + +test panedwindow-19.54 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}} +test panedwindow-19.55 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.56 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {86 20} + +test panedwindow-19.57 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{25 0} {58 0}} + +test panedwindow-19.58 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {66 3 20 20} {121 3 20 20}} + +test panedwindow-19.59 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 20} + +test panedwindow-19.60 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 86} + +test panedwindow-19.61 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 25} {0 58}} + +test panedwindow-19.62 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 66 20 20} {3 121 20 20}} +test panedwindow-19.63 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {22 20} + +test panedwindow-19.64 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {92 20} + +test panedwindow-19.65 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{26 0} {62 0}} + +test panedwindow-19.66 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{11 3 20 20} {69 3 20 20} {127 3 20 20}} + +test panedwindow-19.67 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 0 -sashpad 5 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 22} + +test panedwindow-19.68 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {20 92} + +test panedwindow-19.69 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{0 26} {0 62}} + +test panedwindow-19.70 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 0 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{3 11 20 20} {3 69 20 20} {3 127 20 20}} +test panedwindow-19.71 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.72 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {64 24} + +test panedwindow-19.73 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{22 2} {42 2}} + +test panedwindow-19.74 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {55 5 20 20} {97 5 20 20}} + +test panedwindow-19.75 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.76 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 64} + +test panedwindow-19.77 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 22} {2 42}} + +test panedwindow-19.78 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 55 20 20} {5 97 20 20}} +test panedwindow-19.79 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {26 24} + +test panedwindow-19.80 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {76 24} + +test panedwindow-19.81 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{25 2} {51 2}} + +test panedwindow-19.82 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}} + +test panedwindow-19.83 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 26} + +test panedwindow-19.84 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 76} + +test panedwindow-19.85 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 25} {2 51}} + +test panedwindow-19.86 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}} +test panedwindow-19.87 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.88 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {70 24} + +test panedwindow-19.89 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{22 2} {45 2}} + +test panedwindow-19.90 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {58 5 20 20} {103 5 20 20}} + +test panedwindow-19.91 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.92 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 70} + +test panedwindow-19.93 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 22} {2 45}} + +test panedwindow-19.94 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 58 20 20} {5 103 20 20}} +test panedwindow-19.95 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {26 24} + +test panedwindow-19.96 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {76 24} + +test panedwindow-19.97 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{23 2} {49 2}} + +test panedwindow-19.98 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {61 5 20 20} {109 5 20 20}} + +test panedwindow-19.99 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 0 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 26} + +test panedwindow-19.100 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 76} + +test panedwindow-19.101 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 23} {2 49}} + +test panedwindow-19.102 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 0 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 61 20 20} {5 109 20 20}} +test panedwindow-19.103 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.104 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {84 24} + +test panedwindow-19.105 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{27 2} {57 2}} + +test panedwindow-19.106 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {65 5 20 20} {117 5 20 20}} + +test panedwindow-19.107 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.108 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 84} + +test panedwindow-19.109 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 27} {2 57}} + +test panedwindow-19.110 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 65 20 20} {5 117 20 20}} +test panedwindow-19.111 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {26 24} + +test panedwindow-19.112 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {96 24} + +test panedwindow-19.113 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{30 2} {66 2}} + +test panedwindow-19.114 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}} + +test panedwindow-19.115 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -orient vertical -sashwidth 0 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 26} + +test panedwindow-19.116 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 96} + +test panedwindow-19.117 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 30} {2 66}} + +test panedwindow-19.118 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 0 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}} +test panedwindow-19.119 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 0 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.120 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {90 24} + +test panedwindow-19.121 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{27 2} {60 2}} + +test panedwindow-19.122 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {68 5 20 20} {123 5 20 20}} + +test panedwindow-19.123 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 0 + .p add [frame .f -width 20 -height 20 -bg red] -pady 0 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 24} + +test panedwindow-19.124 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 90} + +test panedwindow-19.125 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 27} {2 60}} + +test panedwindow-19.126 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 0 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 68 20 20} {5 123 20 20}} +test panedwindow-19.127 {ComputeGeometry, one slave, reqsize set properly} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + .p add [frame .p.f -width 20 -height 20 -bg red] -padx 1 -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {26 24} + +test panedwindow-19.128 {ComputeGeometry, three panes, reqsize set properly} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {96 24} + +test panedwindow-19.129 {ComputeGeometry, sash coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{28 2} {64 2}} + +test panedwindow-19.130 {ComputeGeometry/ArrangePanes, slave coords} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 3 -padx 11 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{13 5 20 20} {71 5 20 20} {129 5 20 20}} + +test panedwindow-19.131 {ComputeGeometry, one slave, vertical} -setup { + deleteWindows +} -body { + # With just one slave, sashpad and sashwidth should not + # affect the panedwindow's geometry, since no sash should + # ever be drawn. + panedwindow .p -borderwidth 2 -sashpad 5 \ + -orient vertical -sashwidth 3 -handlesize 6 \ + -showhandle 1 + .p add [frame .f -width 20 -height 20 -bg red] -pady 1 \ + -sticky "" + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 26} + +test panedwindow-19.132 {ComputeGeometry, three panes, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [winfo reqwidth .p] [winfo reqheight .p] +} -cleanup { + deleteWindows +} -result {24 96} + +test panedwindow-19.133 {ComputeGeometry, sash coords, vertical} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.f1 .f2 .f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky "" + } + list [.p sash coord 0] [.p sash coord 1] +} -cleanup { + deleteWindows +} -result {{2 28} {2 64}} + +test panedwindow-19.134 {ComputeGeometry/ArrangePanes, slave coords, vert} -setup { + deleteWindows +} -body { + panedwindow .p -borderwidth 2 -sashpad 5 \ + -sashwidth 3 -handlesize 6 -showhandle 1 \ + -orient vertical + foreach w {.p.f1 .p.f2 .p.f3} { + .p add [frame $w -width 20 -height 20 -bg blue] \ + -sticky nsew -pady 11 -padx 3 + } + pack .p + update + set result {} + foreach w {.p.f1 .p.f2 .p.f3} { + lappend result [list [winfo x $w] [winfo y $w] \ + [winfo width $w] [winfo height $w]] + } + return $result +} -cleanup { + deleteWindows +} -result {{5 13 20 20} {5 71 20 20} {5 129 20 20}} + + +test panedwindow-20.1 {destroyed widgets are removed from panedwindow} -setup { + deleteWindows +} -body { panedwindow .p .p add [frame .f -width 20 -height 20 -bg blue] destroy .f - set result [.p panes] - destroy .p - set result -} {} -test panedwindow-21.2 {destroyed slave causes geometry recomputation} { + .p panes +} -cleanup { + deleteWindows +} -result {} +test panedwindow-20.2 {destroyed slave causes geometry recomputation} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] destroy .f - set result [winfo reqwidth .p] - destroy .p .f2 - set result -} 20 + winfo reqwidth .p +} -cleanup { + deleteWindows +} -result 20 -test panedwindow-22.1 {ArrangePanes, extra space is given to the last pane} { + +test panedwindow-21.1 {ArrangePanes, extra space is given to the last pane} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -width 100 -x 0 -y 0 update - set result [winfo width .f2] - destroy .p .f1 .f2 - set result -} 78 -test panedwindow-22.2 {ArrangePanes, extra space is given to the last pane} { + winfo width .f2 +} -cleanup { + deleteWindows +} -result 78 +test panedwindow-21.2 {ArrangePanes, extra space is given to the last pane} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -height 100 -x 0 -y 0 update - set result [winfo height .f2] - destroy .p .f1 .f2 - set result -} 78 -test panedwindow-22.3 {ArrangePanes, explicit height/width are preferred} { + winfo height .f2 +} -cleanup { + deleteWindows +} -result 78 +test panedwindow-21.3 {ArrangePanes, explicit height/width are preferred} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky "" .p paneconfigure .f1 -width 10 -height 15 pack .p update - set result [list [winfo width .f1] [winfo height .f1]] - destroy .p .f1 .f2 - set result -} {10 15} -test panedwindow-22.4 {ArrangePanes, panes clipped by size of pane} { + list [winfo width .f1] [winfo height .f1] +} -cleanup { + deleteWindows +} -result {10 15} +test panedwindow-21.4 {ArrangePanes, panes clipped by size of pane} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] .p sash place 0 10 0 pack .p update - set result [list [winfo width .f1] [winfo height .f1]] - destroy .p .f1 .f2 - set result -} {10 20} -test panedwindow-22.5 {ArrangePanes, panes clipped by size of pane} { + list [winfo width .f1] [winfo height .f1] +} -cleanup { + deleteWindows +} -result {10 20} +test panedwindow-21.5 {ArrangePanes, panes clipped by size of pane} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .f1 -width 20 -height 20 -bg blue] \ @@ -1819,32 +4364,38 @@ test panedwindow-22.5 {ArrangePanes, panes clipped by size of pane} { .p sash place 0 0 10 pack .p update - set result [list [winfo width .f1] [winfo height .f1]] - destroy .p .f1 .f2 - set result -} {20 10} -test panedwindow-22.6 {ArrangePanes, height of pane taken from total height} { + list [winfo width .f1] [winfo height .f1] +} -cleanup { + deleteWindows +} -result {20 10} +test panedwindow-21.6 {ArrangePanes, height of pane taken from total height} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 20 -height 40 -bg red] -sticky "" pack .p update - set result [list [winfo y .p.f1]] - destroy .p .p.f1 .p.f2 - set result -} 10 -test panedwindow-22.8 {ArrangePanes, width of pane taken from total width} { + winfo y .p.f1 +} -cleanup { + deleteWindows +} -result 10 +test panedwindow-21.7 {ArrangePanes, width of pane taken from total width} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 40 -height 40 -bg red] -sticky "" pack .p update - set result [list [winfo x .p.f1]] - destroy .p .p.f1 .p.f2 - set result -} 10 -test panedwindow-22.9 {ArrangePanes, panes with width <= 0 are unmapped} { + winfo x .p.f1 +} -cleanup { + deleteWindows +} -result 10 +test panedwindow-21.8 {ArrangePanes, panes with width <= 0 are unmapped} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 40 -bg red] @@ -1854,10 +4405,12 @@ test panedwindow-22.9 {ArrangePanes, panes with width <= 0 are unmapped} { .p sash place 0 0 0 update lappend result [winfo ismapped .f1] - destroy .p .f1 .f2 - set result -} {1 0} -test panedwindow-22.10 {ArrangePanes, panes with width <= 0 are unmapped} { +} -cleanup { + deleteWindows +} -result {1 0} +test panedwindow-21.9 {ArrangePanes, panes with width <= 0 are unmapped} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 20 -height 40 -bg red] @@ -1867,10 +4420,12 @@ test panedwindow-22.10 {ArrangePanes, panes with width <= 0 are unmapped} { .p sash place 0 0 0 update lappend result [winfo ismapped .p.f1] - destroy .p .p.f1 .p.f2 - set result -} {1 0} -test panedwindow-22.11 {ArrangePanes, panes with width <= 0 are unmapped} { +} -cleanup { + deleteWindows +} -result {1 0} +test panedwindow-21.10 {ArrangePanes, panes with width <= 0 are unmapped} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 -orient vertical .p add [frame .p.f1 -width 20 -height 20 -bg blue] \ [frame .p.f2 -width 20 -height 40 -bg red] @@ -1880,32 +4435,37 @@ test panedwindow-22.11 {ArrangePanes, panes with width <= 0 are unmapped} { .p sash place 0 0 0 update lappend result [winfo ismapped .p.f1] - destroy .p .p.f1 .p.f2 - set result -} {1 0} -test panedwindow-22.12 {ArrangePanes, last pane shrinks} { +} -cleanup { + deleteWindows +} -result {1 0} +test panedwindow-21.11 {ArrangePanes, last pane shrinks} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -width 40 -x 0 -y 0 update - set result [winfo width .f2] - destroy .p .f1 .f2 - set result -} 18 -test panedwindow-22.13 {ArrangePanes, last pane shrinks} { + winfo width .f2 +} -cleanup { + deleteWindows +} -result 18 +test panedwindow-21.12 {ArrangePanes, last pane shrinks} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -borderwidth 0 -sashpad 0 -sashwidth 2 \ -orient vertical .p add [frame .f1 -width 20 -height 20 -bg blue] \ [frame .f2 -width 20 -height 20 -bg red] -sticky nsew place .p -height 40 -x 0 -y 0 update - set result [winfo height .f2] - destroy .p .f1 .f2 - set result -} 18 -test panedwindow-22.14 {ArrangePanes, panedwindow resizes} { - -body { + winfo height .f2 +} -cleanup { + deleteWindows +} -result 18 +test panedwindow-21.13 {ArrangePanes, panedwindow resizes} -setup { + deleteWindows +} -body { panedwindow .p -width 200 -borderwidth 0 frame .f1 -height 50 -bg blue set result [list] @@ -1913,12 +4473,12 @@ test panedwindow-22.14 {ArrangePanes, panedwindow resizes} { .p add .f1 pack .p lappend result [winfo reqwidth .p] [winfo reqheight .p] - } - -cleanup {destroy .p .f1} - -result {200 1 200 50} -} -test panedwindow-22.15 {ArrangePanes, panedwindow resizes} { - -body { +} -cleanup { + deleteWindows +} -result {200 1 200 50} +test panedwindow-21.14 {ArrangePanes, panedwindow resizes} -setup { + deleteWindows +} -body { panedwindow .p -height 200 -borderwidth 0 -orient vertical frame .f1 -width 50 -bg blue set result [list] @@ -1926,12 +4486,12 @@ test panedwindow-22.15 {ArrangePanes, panedwindow resizes} { .p add .f1 pack .p lappend result [winfo reqwidth .p] [winfo reqheight .p] - } - -cleanup {destroy .p .f1} - -result {1 200 50 200} -} -test panedwindow-22.16 {ArrangePanes, last pane grows} { - -body { +} -cleanup { + deleteWindows +} -result {1 200 50 200} +test panedwindow-21.15 {ArrangePanes, last pane grows} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -height 50 .p add [frame .f1 -width 50 -bg red] [frame .f2 -width 50 -bg white] \ [frame .f3 -width 50 -bg blue] [frame .f4 -width 50 -bg green] @@ -1945,13 +4505,14 @@ test panedwindow-22.16 {ArrangePanes, last pane grows} { update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {50 150 1 1 211 50 150 1 89 300} -} +} -cleanup { + deleteWindows +} -result {50 150 1 1 211 50 150 1 89 300} -test panedwindow-23.1 {PanedWindowReqProc, react to slave geometry changes} { +test panedwindow-22.1 {PanedWindowReqProc, react to slave geometry changes} -setup { + deleteWindows +} -body { # Basically just want to make sure that the PanedWindowReqProc is called panedwindow .p -borderwidth 0 -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 20 -height 20 -bg blue] \ @@ -1959,10 +4520,12 @@ test panedwindow-23.1 {PanedWindowReqProc, react to slave geometry changes} { set result [winfo reqheight .p] .f1 configure -height 80 lappend result [winfo reqheight .p] - destroy .p .f1 .f2 - set result -} {40 80} -test panedwindow-23.2 {PanedWindowReqProc, react to slave geometry changes} { +} -cleanup { + deleteWindows +} -result {40 80} +test panedwindow-22.2 {PanedWindowReqProc, react to slave geometry changes} -setup { + deleteWindows +} -body { panedwindow .p -orient horizontal -sashpad 0 -sashwidth 2 .p add [frame .f1 -width 10] [frame .f2 -width 10] set result [winfo reqwidth .p] @@ -1970,111 +4533,139 @@ test panedwindow-23.2 {PanedWindowReqProc, react to slave geometry changes} { lappend result [winfo reqwidth .p] destroy .p .f1 .f2 expr {[lindex $result 1] - [lindex $result 0]} -} {10} +} -cleanup { + deleteWindows +} -result {10} -test panedwindow-24.1 {ConfigurePanes, can't add panedwindow to itself} { +test panedwindow-23.1 {ConfigurePanes, can't add panedwindow to itself} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p add .p} msg] $msg] - destroy .p - set result -} [list 1 "can't add .p to itself"] -test panedwindow-24.2 {ConfigurePanes, bad window throws error} { + .p add .p +} -cleanup { + deleteWindows +} -returnCodes error -result {can't add .p to itself} +test panedwindow-23.2 {ConfigurePanes, bad window throws error} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p add .b} msg] $msg] - destroy .p - set result -} [list 1 "bad window path name \".b\""] -test panedwindow-24.3 {ConfigurePanes, bad window aborts processing} { + .p add .b +} -cleanup { + deleteWindows +} -returnCodes error -result {bad window path name ".b"} +test panedwindow-23.3 {ConfigurePanes, bad window aborts processing} -setup { + deleteWindows +} -body { panedwindow .p button .b catch {.p add .b .a} - set result [.p panes] - destroy .p .b - set result -} {} -test panedwindow-24.4 {ConfigurePanes, bad option aborts processing} { + .p panes +} -cleanup { + deleteWindows +} -result {} +test panedwindow-23.4 {ConfigurePanes, bad option aborts processing} -setup { + deleteWindows +} -body { panedwindow .p button .b catch {.p add .b -sticky foobar} - set result [.p panes] - destroy .p .b - set result -} {} -test panedwindow-24.5 {ConfigurePanes, after win isn't managed by panedwin} { + .p panes +} -cleanup { + deleteWindows +} -result {} +test panedwindow-23.5 {ConfigurePanes, after win isn't managed by panedwin} -setup { + deleteWindows +} -body { panedwindow .p button .b button .c - set result [list [catch {.p add .b -after .c} msg] $msg] - destroy .p .b .c - set result -} [list 1 "window \".c\" is not managed by .p"] -test panedwindow-24.6 {ConfigurePanes, before win isn't managed by panedwin} { + .p add .b -after .c +} -cleanup { + deleteWindows +} -returnCodes error -result {window ".c" is not managed by .p} +test panedwindow-23.6 {ConfigurePanes, before win isn't managed by panedwin} -setup { + deleteWindows +} -body { panedwindow .p button .b button .c - set result [list [catch {.p add .b -before .c} msg] $msg] - destroy .p .b .c - set result -} [list 1 "window \".c\" is not managed by .p"] -test panedwindow-24.7 {ConfigurePanes, -after {} is a no-op} { + .p add .b -before .c +} -cleanup { + deleteWindows +} -returnCodes error -result {window ".c" is not managed by .p} +test panedwindow-23.7 {ConfigurePanes, -after {} is a no-op} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] .p paneconfigure .b -after {} - set result [.p panes] - destroy .p .b .c - set result -} {.b .c} -test panedwindow-24.8 {ConfigurePanes, -before {} is a no-op} { + .p panes +} -cleanup { + deleteWindows +} -result {.b .c} +test panedwindow-23.8 {ConfigurePanes, -before {} is a no-op} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] .p paneconfigure .b -before {} - set result [.p panes] - destroy .p .b .c - set result -} {.b .c} -test panedwindow-24.9 {ConfigurePanes, new panes are added} { + .p panes +} -cleanup { + deleteWindows +} -result {.b .c} +test panedwindow-23.9 {ConfigurePanes, new panes are added} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] - set result [.p panes] - destroy .p .b .c - set result -} {.b .c} -test panedwindow-24.10 {ConfigurePanes, options applied to all panes} { + .p panes +} -cleanup { + deleteWindows +} -result {.b .c} +test panedwindow-23.10 {ConfigurePanes, options applied to all panes} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] [button .c] -sticky ne -height 5 -width 5 -minsize 10 set result {} foreach w {.b .c} { - set val {} - foreach option {-sticky -height -width -minsize} { - lappend val $option [.p panecget $w $option] - } - lappend result $w $val + set val {} + foreach option {-sticky -height -width -minsize} { + lappend val $option [.p panecget $w $option] + } + lappend result $w $val } - destroy .p .b .c - set result -} [list .b {-sticky ne -height 5 -width 5 -minsize 10} \ - .c {-sticky ne -height 5 -width 5 -minsize 10}] -test panedwindow-24.11 {ConfigurePanes, existing panes are reconfigured} { + return $result +} -cleanup { + deleteWindows +} -result {.b {-sticky ne -height 5 -width 5 -minsize 10} .c {-sticky ne -height 5 -width 5 -minsize 10}} + +test panedwindow-23.11 {ConfigurePanes, existing panes are reconfigured} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] -sticky nw -height 10 .p add .b [button .c] -sticky se -height 2 - set result [list [.p panes] \ - [.p panecget .b -sticky] [.p panecget .b -height] \ - [.p panecget .c -sticky] [.p panecget .c -height]] - destroy .p .b .c - set result -} [list {.b .c} es 2 es 2] -test panedwindow-24.12 {ConfigurePanes, widgets added to end by default} { + list [.p panes] [.p panecget .b -sticky] [.p panecget .b -height] \ + [.p panecget .c -sticky] [.p panecget .c -height] +} -cleanup { + deleteWindows +} -result [list {.b .c} es 2 es 2] +test panedwindow-23.12 {ConfigurePanes, widgets added to end by default} -setup { + deleteWindows +} -body { panedwindow .p .p add [button .b] .p add [button .c] .p add [button .d] - set result [.p panes] - destroy .p .b .c .d - set result -} {.b .c .d} -test panedwindow-24.13 {ConfigurePanes, -after, single addition} { + .p panes +} -cleanup { + deleteWindows +} -result {.b .c .d} +test panedwindow-23.13 {ConfigurePanes, -after, single addition} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2082,11 +4673,13 @@ test panedwindow-24.13 {ConfigurePanes, -after, single addition} { .p add .a .b .p add .c -after .a - set result [.p panes] - destroy .p .a .b .c - set result -} {.a .c .b} -test panedwindow-24.14 {ConfigurePanes, -after, multiple additions} { + .p panes +} -cleanup { + deleteWindows +} -result {.a .c .b} +test panedwindow-23.14 {ConfigurePanes, -after, multiple additions} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2095,11 +4688,13 @@ test panedwindow-24.14 {ConfigurePanes, -after, multiple additions} { .p add .a .b .p add .c .d -after .a - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.a .c .d .b} -test panedwindow-24.15 {ConfigurePanes, -after, relocates existing widget} { + .p panes +} -cleanup { + deleteWindows +} -result {.a .c .d .b} +test panedwindow-23.15 {ConfigurePanes, -after, relocates existing widget} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2108,11 +4703,13 @@ test panedwindow-24.15 {ConfigurePanes, -after, relocates existing widget} { .p add .a .b .c .d .p add .d -after .a - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.a .d .b .c} -test panedwindow-24.16 {ConfigurePanes, -after, relocates existing widgets} { + .p panes +} -cleanup { + deleteWindows +} -result {.a .d .b .c} +test panedwindow-23.16 {ConfigurePanes, -after, relocates existing widgets} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2121,11 +4718,13 @@ test panedwindow-24.16 {ConfigurePanes, -after, relocates existing widgets} { .p add .a .b .c .d .p add .b .d -after .a - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.a .b .d .c} -test panedwindow-24.17 {ConfigurePanes, -after, relocates existing widgets} { + .p panes +} -cleanup { + deleteWindows +} -result {.a .b .d .c} +test panedwindow-23.17 {ConfigurePanes, -after, relocates existing widgets} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2134,11 +4733,13 @@ test panedwindow-24.17 {ConfigurePanes, -after, relocates existing widgets} { .p add .a .b .c .d .p add .d .a -after .b - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.b .d .a .c} -test panedwindow-24.18 {ConfigurePanes, -after, relocates existing widgets} { + .p panes +} -cleanup { + deleteWindows +} -result {.b .d .a .c} +test panedwindow-23.18 {ConfigurePanes, -after, relocates existing widgets} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2147,11 +4748,13 @@ test panedwindow-24.18 {ConfigurePanes, -after, relocates existing widgets} { .p add .a .b .c .d .p add .d .a -after .a - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.d .a .b .c} -test panedwindow-24.19 {ConfigurePanes, -after, after last window} { + .p panes +} -cleanup { + deleteWindows +} -result {.d .a .b .c} +test panedwindow-23.19 {ConfigurePanes, -after, after last window} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2160,11 +4763,13 @@ test panedwindow-24.19 {ConfigurePanes, -after, after last window} { .p add .a .b .c .p add .d -after .c - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.a .b .c .d} -test panedwindow-24.20 {ConfigurePanes, -before, before first window} { + .p panes +} -cleanup { + deleteWindows +} -result {.a .b .c .d} +test panedwindow-23.20 {ConfigurePanes, -before, before first window} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2173,11 +4778,13 @@ test panedwindow-24.20 {ConfigurePanes, -before, before first window} { .p add .a .b .c .p add .d -before .a - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.d .a .b .c} -test panedwindow-24.21 {ConfigurePanes, -before, relocate existing windows} { + .p panes +} -cleanup { + deleteWindows +} -result {.d .a .b .c} +test panedwindow-23.21 {ConfigurePanes, -before, relocate existing windows} -setup { + deleteWindows +} -body { panedwindow .p button .a button .b @@ -2186,11 +4793,13 @@ test panedwindow-24.21 {ConfigurePanes, -before, relocate existing windows} { .p add .a .b .c .p add .d .b -before .a - set result [.p panes] - destroy .p .a .b .c .d - set result -} {.d .b .a .c} -test panedwindow-24.22 {ConfigurePanes, slave specified multiple times} { + .p panes +} -cleanup { + deleteWindows +} -result {.d .b .a .c} +test panedwindow-23.22 {ConfigurePanes, slave specified multiple times} -setup { + deleteWindows +} -body { # This test should not cause a core dump panedwindow .p @@ -2199,11 +4808,13 @@ test panedwindow-24.22 {ConfigurePanes, slave specified multiple times} { button .c .p add .a .a .b .c - set result [.p panes] - destroy .p .a .b .c - set result -} {.a .b .c} -test panedwindow-24.23 {ConfigurePanes, slave specified multiple times} { + .p panes +} -cleanup { + deleteWindows +} -result {.a .b .c} +test panedwindow-23.23 {ConfigurePanes, slave specified multiple times} -setup { + deleteWindows +} -body { # This test should not cause a core dump panedwindow .p @@ -2213,52 +4824,63 @@ test panedwindow-24.23 {ConfigurePanes, slave specified multiple times} { .p add .a .a .b .c .p add .a .b .a -after .c - set result [.p panes] - destroy .p .a .b .c - set result -} {.c .a .b} -test panedwindow-24.24 {ConfigurePanes, panedwindow cannot manage toplevels} { + .p panes +} -cleanup { + deleteWindows +} -result {.c .a .b} +test panedwindow-23.24 {ConfigurePanes, panedwindow cannot manage toplevels} -setup { + deleteWindows +} -body { panedwindow .p toplevel .t - set result [list [catch {.p add .t} msg] $msg] - destroy .p .t - set result -} [list 1 "can't add toplevel .t to .p"] -test panedwindow-24.25 {ConfigurePanes, restrict possible panes} { + .p add .t +} -cleanup { + deleteWindows +} -returnCodes error -result {can't add toplevel .t to .p} +test panedwindow-23.25 {ConfigurePanes, restrict possible panes} -setup { + deleteWindows +} -body { panedwindow .p frame .f button .f.b - set result [list [catch {.p add .f.b} msg] $msg] - destroy .p .f .f.b - set result -} [list 1 "can't add .f.b to .p"] -test panedwindow-24.26 {ConfigurePanes, restrict possible panes} { + .p add .f.b +} -cleanup { + deleteWindows +} -returnCodes error -result {can't add .f.b to .p} +test panedwindow-23.26 {ConfigurePanes, restrict possible panes} -setup { + deleteWindows +} -body { frame .f panedwindow .f.p button .b - set result [list [catch {.f.p add .b} msg] $msg] - destroy .f.p .f .b - set result -} [list 0 ""] -test panedwindow-24.27 {ConfigurePanes, restrict possible panes} { + .f.p add .b +} -cleanup { + deleteWindows +} -result {} +test panedwindow-23.27 {ConfigurePanes, restrict possible panes} -setup { + deleteWindows +} -body { panedwindow .p button .p.b - set result [list [catch {.p add .p.b} msg] $msg] - destroy .p .p.b - set result -} [list 0 ""] -test panedwindow-24.28 {ConfigurePanes, restrict possible panes} { + .p add .p.b +} -cleanup { + deleteWindows +} -result {} +test panedwindow-23.28 {ConfigurePanes, restrict possible panes} -setup { + deleteWindows +} -body { frame .f frame .f.f frame .f.f.f panedwindow .f.f.f.p button .b - set result [list [catch {.f.f.f.p add .b} msg] $msg] - destroy .f .f.f .f.f.f .f.f.f.p .b - set result -} [list 0 ""] -test panedwindow-24.29.1 {ConfigurePanes, -hide works} { - -body { + .f.f.f.p add .b +} -cleanup { + deleteWindows +} -result {} +test panedwindow-23.29 {ConfigurePanes, -hide works} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false frame .f1 -width 40 -height 100 -bg red frame .f2 -width 40 -height 100 -bg white @@ -2278,12 +4900,12 @@ test panedwindow-24.29.1 {ConfigurePanes, -hide works} { [winfo ismapped .f3] [winfo ismapped .f4] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128} -} -test panedwindow-24.29.2 {ConfigurePanes, -hide works} { - -body { +} -cleanup { + deleteWindows +} -result {1 1 1 1 40 40 40 40 171 1 0 1 1 40 40 40 40 128} +test panedwindow-23.30 {ConfigurePanes, -hide works} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -width 130 -height 100 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white @@ -2303,12 +4925,12 @@ test panedwindow-24.29.2 {ConfigurePanes, -hide works} { [winfo ismapped .f3] [winfo ismapped .f4] lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] [winfo width .p] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130} -} -test panedwindow-24.29.3 {ConfigurePanes, -hide works, last pane stretches} { - -body { +} -cleanup { + deleteWindows +} -result {1 1 1 0 39 40 40 1 130 1 0 1 1 40 40 40 42 130} +test panedwindow-23.31 {ConfigurePanes, -hide works, last pane stretches} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -width 200 -height 200 -borderwidth 0 frame .f1 -width 50 -bg red frame .f2 -width 50 -bg green @@ -2320,13 +4942,13 @@ test panedwindow-24.29.3 {ConfigurePanes, -hide works, last pane stretches} { lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] .p paneconfigure .f2 -hide 1 update - lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] - } - -cleanup {destroy .p .f1 .f2 .f3} - -result {50 50 94 50 50 147} -} -test panedwindow-24.29.4 {ConfigurePanes, -hide works, last pane stretches} { - -body { + lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] +} -cleanup { + deleteWindows +} -result {50 50 94 50 50 147} +test panedwindow-23.32 {ConfigurePanes, -hide works, last pane stretches} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -width 200 -height 200 \ -borderwidth 0 -orient vertical frame .f1 -height 50 -bg red @@ -2340,13 +4962,13 @@ test panedwindow-24.29.4 {ConfigurePanes, -hide works, last pane stretches} { .p paneconfigure .f2 -hide 1 update lappend result [winfo height .f1] [winfo height .f2] [winfo height .f3] - } - -cleanup {destroy .p .f1 .f2 .f3} - -result {50 50 94 50 50 147} -} +} -cleanup { + deleteWindows +} -result {50 50 94 50 50 147} -test panedwindow-24.30 {ConfigurePanes, -stretch first} { - -body { +test panedwindow-23.33 {ConfigurePanes, -stretch first} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white @@ -2362,12 +4984,12 @@ test panedwindow-24.30 {ConfigurePanes, -stretch first} { update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {51 40 40 40 94 40 40 40} -} -test panedwindow-24.31 {ConfigurePanes, -stretch middle} { - -body { +} -cleanup { + deleteWindows +} -result {51 40 40 40 94 40 40 40} +test panedwindow-23.34 {ConfigurePanes, -stretch middle} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white @@ -2383,12 +5005,12 @@ test panedwindow-24.31 {ConfigurePanes, -stretch middle} { update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {40 45 46 40 40 45 94 40} -} -test panedwindow-24.32 {ConfigurePanes, -stretch always} { - -body { +} -cleanup { + deleteWindows +} -result {40 45 46 40 40 45 94 40} +test panedwindow-23.35 {ConfigurePanes, -stretch always} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white @@ -2404,12 +5026,12 @@ test panedwindow-24.32 {ConfigurePanes, -stretch always} { update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {42 43 43 43 58 43 58 58} -} -test panedwindow-24.33 {ConfigurePanes, -stretch never} { - -body { +} -cleanup { + deleteWindows +} -result {42 43 43 43 58 43 58 58} +test panedwindow-23.36 {ConfigurePanes, -stretch never} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -height 100 -width 182 frame .f1 -width 40 -bg red frame .f2 -width 40 -bg white @@ -2425,12 +5047,14 @@ test panedwindow-24.33 {ConfigurePanes, -stretch never} { update lappend result [winfo width .f1] [winfo width .f2] [winfo width .f3] \ [winfo width .f4] - } - -cleanup {destroy .p .f1 .f2 .f3 .f4} - -result {40 40 40 40 40 40 40 40} -} +} -cleanup { + deleteWindows +} -result {40 40 40 40 40 40 40 40} + -test panedwindow-25.1 {Unlink, remove a paned with -before/-after refs} { +test panedwindow-24.1 {Unlink, remove a paned with -before/-after refs} -setup { + deleteWindows +} -body { # Bug 928413 set result {} panedwindow .pw @@ -2445,315 +5069,386 @@ test panedwindow-25.1 {Unlink, remove a paned with -before/-after refs} { lappend result [.pw panecget .pw.l2 -before] .pw paneconfigure .pw.l2 -before .pw.l1 lappend result [.pw panecget .pw.l2 -before] - destroy .pw - set result -} {.pw.l3 {} .pw.l1} +} -cleanup { + deleteWindows +} -result {.pw.l3 {} .pw.l1} -test panedwindow-26.1 {DestroyPanedWindow} { + +test panedwindow-25.1 {DestroyPanedWindow} -setup { + deleteWindows +} -body { # This test should not result in any memory leaks. panedwindow .p foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .q .r .s .t} { - .p add [button $w] + .p add [button $w] } foreach w {.a .b .c .d .e .f .g .h .i .j .k .l .m .n .o .p .q .r .s .t} { - destroy $w + destroy $w } set result {} -} {} +} -result {} + -test panedwindow-27.1 {PanedWindowIdentifyCoords} { +test panedwindow-26.1 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 0] - destroy .p .f .f2 - set result -} {} -test panedwindow-27.2 {PanedWindowIdentifyCoords, padding is included} { + .p identify 0 0 +} -cleanup { + deleteWindows +} -result {} +test panedwindow-26.2 {PanedWindowIdentifyCoords, padding is included} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 20 0] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.3 {PanedWindowIdentifyCoords} { + .p identify 20 0 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.3 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 22 0] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.4 {PanedWindowIdentifyCoords} { + .p identify 22 0 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.4 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 24 0] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.5 {PanedWindowIdentifyCoords} { + .p identify 24 0 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.5 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 26 0] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.6 {PanedWindowIdentifyCoords} { + .p identify 26 0 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.6 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 26 -1] - destroy .p .f .f2 - set result -} {} -test panedwindow-27.7 {PanedWindowIdentifyCoords} { + .p identify 26 -1 +} -cleanup { + deleteWindows +} -result {} +test panedwindow-26.7 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 26 100] - destroy .p .f .f2 - set result -} {} -test panedwindow-27.8 {PanedWindowIdentifyCoords} { + .p identify 26 100 +} -cleanup { + deleteWindows +} -result {} +test panedwindow-26.8 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 22 4] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.9 {PanedWindowIdentifyCoords} { + .p identify 22 4 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.9 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 22 5] - destroy .p .f .f2 - set result -} {0 handle} -test panedwindow-27.10 {PanedWindowIdentifyCoords} { + .p identify 22 5 +} -cleanup { + deleteWindows +} -result {0 handle} +test panedwindow-26.10 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 20 5] - destroy .p .f .f2 - set result -} {0 handle} -test panedwindow-27.11 {PanedWindowIdentifyCoords} { + .p identify 20 5 +} -cleanup { + deleteWindows +} -result {0 handle} +test panedwindow-26.11 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 20 0] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.12 {PanedWindowIdentifyCoords} { + .p identify 20 0 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.12 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2 .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] \ [frame .f3 -bg green -width 20 -height 20] - set result [.p identify 48 0] - destroy .p .f .f2 .f3 - set result -} {1 sash} -test panedwindow-27.13 {identify subcommand errors} { + .p identify 48 0 +} -cleanup { + deleteWindows +} -result {1 sash} +test panedwindow-26.13 {identify subcommand errors} -setup { + deleteWindows +} -body { panedwindow .p -borderwidth 0 -sashpad 2 -sashwidth 4 - set result [list [catch {.p identify} msg] $msg] - destroy .p - set result -} [list 1 "wrong # args: should be \".p identify x y\""] -test panedwindow-27.14 {identify subcommand errors} { + .p identify +} -cleanup { + deleteWindows +} -returnCodes error -result {wrong # args: should be ".p identify x y"} +test panedwindow-26.14 {identify subcommand errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p identify foo bar} msg] $msg] - destroy .p - set result -} [list 1 "expected integer but got \"foo\""] -test panedwindow-27.14a {identify subcommand errors} { + .p identify foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "foo"} +test panedwindow-26.15 {identify subcommand errors} -setup { + deleteWindows +} -body { panedwindow .p - set result [list [catch {.p identify 0 bar} msg] $msg] - destroy .p - set result -} [list 1 "expected integer but got \"bar\""] -test panedwindow-27.15 {PanedWindowIdentifyCoords} { + .p identify 0 bar +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "bar"} +test panedwindow-26.16 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 0] - destroy .p .f .f2 - set result -} {} -test panedwindow-27.16 {PanedWindowIdentifyCoords, padding is included} { + .p identify 0 0 +} -cleanup { + deleteWindows +} -result {} +test panedwindow-26.17 {PanedWindowIdentifyCoords, padding is included} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 20] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.17 {PanedWindowIdentifyCoords} { + .p identify 0 20 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.18 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 22] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.18 {PanedWindowIdentifyCoords} { + .p identify 0 22 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.19 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 24] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.19 {PanedWindowIdentifyCoords} { + .p identify 0 24 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.20 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 26] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.20 {PanedWindowIdentifyCoords} { + .p identify 0 26 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.21 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify -1 26] - destroy .p .f .f2 - set result -} {} -test panedwindow-27.21 {PanedWindowIdentifyCoords} { + .p identify -1 26 +} -cleanup { + deleteWindows +} -result {} +test panedwindow-26.22 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 100 26] - destroy .p .f .f2 - set result -} {} -test panedwindow-27.22 {PanedWindowIdentifyCoords} { + .p identify 100 26 +} -cleanup { + deleteWindows +} -result {} +test panedwindow-26.23 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 4 22] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.23 {PanedWindowIdentifyCoords} { + .p identify 4 22 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.24 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 6 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 5 22] - destroy .p .f .f2 - set result -} {0 handle} -test panedwindow-27.24 {PanedWindowIdentifyCoords} { + .p identify 5 22 +} -cleanup { + deleteWindows +} -result {0 handle} +test panedwindow-26.25 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 5 20] - destroy .p .f .f2 - set result -} {0 handle} -test panedwindow-27.25 {PanedWindowIdentifyCoords} { + .p identify 5 20 +} -cleanup { + deleteWindows +} -result {0 handle} +test panedwindow-26.26 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -bd 0 -sashwidth 2 -sashpad 2 -showhandle 1 -handlepad 5 \ -handlesize 8 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] - set result [.p identify 0 20] - destroy .p .f .f2 - set result -} {0 sash} -test panedwindow-27.26 {PanedWindowIdentifyCoords} { + .p identify 0 20 +} -cleanup { + deleteWindows +} -result {0 sash} +test panedwindow-26.27 {PanedWindowIdentifyCoords} -setup { + deleteWindows +} -body { panedwindow .p -showhandle false -bd 0 -sashwidth 2 -sashpad 2 -orient vertical .p add [frame .f -bg red -width 20 -height 20] \ [frame .f2 -bg blue -width 20 -height 20] \ [frame .f3 -bg green -width 20 -height 20] - set result [.p identify 0 48] - destroy .p .f .f2 .f3 - set result -} {1 sash} - -test panedwindow-28.1 {destroy the window cleanly on error [Bug #616589]} { - list [catch {panedwindow .p -bogusopt bogus} msg] $msg -} {1 {unknown option "-bogusopt"}} -test panedwindow-28.2 {destroy the window cleanly on rename [Bug #616589]} { + .p identify 0 48 +} -cleanup { + deleteWindows +} -result {1 sash} + + +test panedwindow-27.1 {destroy the window cleanly on error [Bug #616589]} -setup { + deleteWindows +} -body { + panedwindow .p -bogusopt bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-bogusopt"} +test panedwindow-27.2 {destroy the window cleanly on rename [Bug #616589]} -setup { + deleteWindows +} -body { destroy .p panedwindow .p rename .p {} winfo exists .p -} {0} - - -test panedwindow-29.1 {resizing width} { - -body { - panedwindow .p -bd 5 - frame .f1 -width 100 -height 50 -bg blue - frame .f2 -width 100 -height 50 -bg red - - .p add .f1 -sticky news - .p add .f2 -sticky news - pack .p -side top -fill both -expand 1 - wm geometry . "" - update - # Note the width - set a [winfo width .f2] - # Increase the size by 10 - regexp {^(\d+)x(\d+)} [wm geometry .] -> w h - wm geometry . [expr {$w + 10}]x$h - update - set b "$a [winfo width .f2]" - } - -cleanup {destroy .p .f1 .f2} - -result {100 110} -} - -test panedwindow-29.2 {resizing height} { - -body { - panedwindow .p -orient vertical -bd 5 - frame .f1 -width 50 -height 100 -bg blue - frame .f2 -width 50 -height 100 -bg red - - .p add .f1 -sticky news - .p add .f2 -sticky news - pack .p -side top -fill both -expand 1 - wm geometry . "" - update - # Note the height - set a [winfo height .f2] - # Increase the size by 10 - regexp {^(\d+)x(\d+)} [wm geometry .] -> w h - wm geometry . ${w}x[expr {$h + 10}] - update - set b "$a [winfo height .f2]" - } - -cleanup {destroy .p .f1 .f2} - -result {100 110} -} - -test panedwindow-30.1 {display on depths other than the default one} { - -constraints {pseudocolor8 haveTruecolor24} - -body { +} -cleanup { + deleteWindows +} -result {0} + + +test panedwindow-28.1 {resizing width} -setup { + deleteWindows +} -body { + panedwindow .p -bd 5 + frame .f1 -width 100 -height 50 -bg blue + frame .f2 -width 100 -height 50 -bg red + + .p add .f1 -sticky news + .p add .f2 -sticky news + pack .p -side top -fill both -expand 1 + wm geometry . "" + update + # Note the width + set a [winfo width .f2] + # Increase the size by 10 + regexp {^(\d+)x(\d+)} [wm geometry .] -> w h + wm geometry . [expr {$w + 10}]x$h + update + set b "$a [winfo width .f2]" +} -cleanup { + deleteWindows +} -result {100 110} + +test panedwindow-28.2 {resizing height} -setup { + deleteWindows +} -body { + panedwindow .p -orient vertical -bd 5 + frame .f1 -width 50 -height 100 -bg blue + frame .f2 -width 50 -height 100 -bg red + + .p add .f1 -sticky news + .p add .f2 -sticky news + pack .p -side top -fill both -expand 1 + wm geometry . "" + update + # Note the height + set a [winfo height .f2] + # Increase the size by 10 + regexp {^(\d+)x(\d+)} [wm geometry .] -> w h + wm geometry . ${w}x[expr {$h + 10}] + update + set b "$a [winfo height .f2]" +} -cleanup { + deleteWindows +} -result {100 110} + + +test panedwindow-29.1 {display on depths other than the default one} -constraints { + pseudocolor8 haveTruecolor24 +} -setup { + deleteWindows +} -body { toplevel .t -visual {truecolor 24} pack [panedwindow .t.p] .t.p add [frame .t.p.f1] [frame .t.p.f2] update # If we got here, we didn't crash and that's good - } - -cleanup {destroy .t} - -result {} -} -test panedwindow-30.2 {display on depths other than the default one} { - -constraints {pseudocolor8 haveTruecolor24} - -body { +} -cleanup { + deleteWindows +} -result {} +test panedwindow-29.2 {display on depths other than the default one} -constraints { + pseudocolor8 haveTruecolor24 +} -setup { + deleteWindows +} -body { toplevel .t -visual {pseudocolor 8} pack [frame .t.f -visual {truecolor 24}] pack [panedwindow .t.f.p] @@ -2764,11 +5459,13 @@ test panedwindow-30.2 {display on depths other than the default one} { .t.f.p proxy forget update # If we got here, we didn't crash and that's good - } - -cleanup {destroy .t} - -result {} -} +} -cleanup { + deleteWindows +} -result {} + # cleanup cleanupTests return + + diff --git a/tests/place.test b/tests/place.test index ac2ece7..ddfa64c 100644 --- a/tests/place.test +++ b/tests/place.test @@ -5,7 +5,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -15,6 +16,7 @@ testConstraint memory [llength [info commands memory]] # XXX - This test file is woefully incomplete. At present, only a # few of the features are tested. +# Widgets used in tests 1.* - 8.* toplevel .t -width 300 -height 200 -bd 0 wm geom .t +0+0 frame .t.f -width 154 -height 84 -bd 2 -relief raised @@ -22,145 +24,181 @@ place .t.f -x 48 -y 38 frame .t.f2 -width 30 -height 60 -bd 2 -relief raised update -test place-1.1 {Tk_PlaceCmd procedure, "info" option} { +test place-1.1 {Tk_PlaceCmd procedure, "info" option} -setup { + place forget .t.f2 +} -body { place .t.f2 -x 0 place info .t.f2 -} {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside} -test place-1.2 {Tk_PlaceCmd procedure, "info" option} { +} -result {-in .t -x 0 -relx 0 -y 0 -rely 0 -width {} -relwidth {} -height {} -relheight {} -anchor nw -bordermode inside} +test place-1.2 {Tk_PlaceCmd procedure, "info" option} -setup { + place forget .t.f2 +} -body { place .t.f2 -x 1 -y 2 -width 3 -height 4 -relx 0.1 -rely 0.2 \ - -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \ - -bordermode outside + -relwidth 0.3 -relheight 0.4 -anchor se -in .t.f \ + -bordermode outside place info .t.f2 -} {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside} -test place-1.3 {Tk_PlaceCmd procedure, "info" option} { +} -result {-in .t.f -x 1 -relx 0.1 -y 2 -rely 0.2 -width 3 -relwidth 0.3 -height 4 -relheight 0.4 -anchor se -bordermode outside} +test place-1.3 {Tk_PlaceCmd procedure, "info" option} -setup { + place forget .t.f2 + destroy .t.a.b +} -body { # Make sure the result is built as a proper list by using a space in parent frame ".t.a b" place .t.f2 -x 1 -y 2 -width {} -height 4 -relx 0.2 -rely 0.2 \ - -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \ - -bordermode ignore - set res [place info .t.f2] - destroy ".t.a b" - set res -} {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore} - -test place-2.1 {ConfigureSlave procedure, -height option} { - list [catch {place .t.f2 -height abcd} msg] $msg -} {1 {bad screen distance "abcd"}} -test place-2.2 {ConfigureSlave procedure, -height option} { + -relwidth 0.3 -relheight {} -anchor w -in ".t.a b" \ + -bordermode ignore + place info .t.f2 +} -cleanup { + destroy ".t.a.b" +} -result {-in {.t.a b} -x 1 -relx 0.2 -y 2 -rely 0.2 -width {} -relwidth 0.3 -height 4 -relheight {} -anchor w -bordermode ignore} + + +test place-2.1 {ConfigureSlave procedure, -height option} -body { + place .t.f2 -height abcd +} -returnCodes error -result {bad screen distance "abcd"} +test place-2.2 {ConfigureSlave procedure, -height option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -height 40 update winfo height .t.f2 -} {40} -test place-2.3 {ConfigureSlave procedure, -height option} { +} -result {40} +test place-2.3 {ConfigureSlave procedure, -height option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -height 120 update place .t.f2 -height {} update winfo height .t.f2 -} {60} +} -result {60} -test place-3.1 {ConfigureSlave procedure, -relheight option} { - list [catch {place .t.f2 -relheight abcd} msg] $msg -} {1 {expected floating-point number but got "abcd"}} -test place-3.2 {ConfigureSlave procedure, -relheight option} { + +test place-3.1 {ConfigureSlave procedure, -relheight option} -body { + place .t.f2 -relheight abcd +} -returnCodes error -result {expected floating-point number but got "abcd"} +test place-3.2 {ConfigureSlave procedure, -relheight option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -relheight .5 update winfo height .t.f2 -} {40} -test place-3.3 {ConfigureSlave procedure, -relheight option} { +} -result {40} +test place-3.3 {ConfigureSlave procedure, -relheight option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -relheight .8 update place .t.f2 -relheight {} update winfo height .t.f2 -} {60} +} -result {60} + -test place-4.1 {ConfigureSlave procedure, bad -in options} { +test place-4.1 {ConfigureSlave procedure, bad -in options} -setup { + place forget .t.f2 +} -body { + place .t.f2 -in .t.f2 +} -returnCodes error -result {can't place .t.f2 relative to itself} +test place-4.2 {ConfigureSlave procedure, bad -in option} -setup { place forget .t.f2 - list [catch {place .t.f2 -in .t.f2} msg] $msg -} [list 1 "can't place .t.f2 relative to itself"] -test place-4.2 {ConfigureSlave procedure, bad -in option} { +} -body { + set result [list [winfo manager .t.f2]] + catch {place .t.f2 -in .t.f2} + lappend result [winfo manager .t.f2] +} -result {{} {}} +test place-4.3 {ConfigureSlave procedure, bad -in option} -setup { place forget .t.f2 - list [winfo manager .t.f2] \ - [catch {place .t.f2 -in .t.f2} err] $err \ - [winfo manager .t.f2] -} {{} 1 {can't place .t.f2 relative to itself} {}} -test place-4.3 {ConfigureSlave procedure, bad -in option} { +} -body { + winfo manager .t.f2 + place .t.f2 -in .t.f2 +} -returnCodes error -result {can't place .t.f2 relative to itself} +test place-4.4 {ConfigureSlave procedure, bad -in option} -setup { place forget .t.f2 - list [catch {place .t.f2 -in .} msg] $msg -} [list 1 "can't place .t.f2 relative to ."] +} -body { + place .t.f2 -in . +} -returnCodes error -result {can't place .t.f2 relative to .} -test place-5.1 {ConfigureSlave procedure, -relwidth option} { - list [catch {place .t.f2 -relwidth abcd} msg] $msg -} {1 {expected floating-point number but got "abcd"}} -test place-5.2 {ConfigureSlave procedure, -relwidth option} { + +test place-5.1 {ConfigureSlave procedure, -relwidth option} -body { + place .t.f2 -relwidth abcd +} -returnCodes error -result {expected floating-point number but got "abcd"} +test place-5.2 {ConfigureSlave procedure, -relwidth option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -relwidth .5 update winfo width .t.f2 -} {75} -test place-5.3 {ConfigureSlave procedure, -relwidth option} { +} -result {75} +test place-5.3 {ConfigureSlave procedure, -relwidth option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -relwidth .8 update place .t.f2 -relwidth {} update winfo width .t.f2 -} {30} +} -result {30} -test place-6.1 {ConfigureSlave procedure, -width option} { - list [catch {place .t.f2 -width abcd} msg] $msg -} {1 {bad screen distance "abcd"}} -test place-6.2 {ConfigureSlave procedure, -width option} { +test place-6.1 {ConfigureSlave procedure, -width option} -body { + place .t.f2 -width abcd +} -returnCodes error -result {bad screen distance "abcd"} +test place-6.2 {ConfigureSlave procedure, -width option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -width 100 update winfo width .t.f2 -} {100} -test place-6.3 {ConfigureSlave procedure, -width option} { +} -result {100} +test place-6.3 {ConfigureSlave procedure, -width option} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -width 120 update place .t.f2 -width {} update winfo width .t.f2 -} {30} +} -result {30} + -test place-7.1 {ReconfigurePlacement procedure, computing position} { +test place-7.1 {ReconfigurePlacement procedure, computing position} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -x -2 -relx .5 -y 3 -rely .4 update winfo geometry .t.f2 -} {30x60+123+75} -test place-7.2 {ReconfigurePlacement procedure, position rounding} { +} -result {30x60+123+75} +test place-7.2 {ReconfigurePlacement procedure, position rounding} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -x -1.4 -y -2.3 update winfo geometry .t.f2 -} {30x60+49+38} -test place-7.3 {ReconfigurePlacement procedure, position rounding} { +} -result {30x60+49+38} +test place-7.3 {ReconfigurePlacement procedure, position rounding} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -x 1.4 -y 2.3 update winfo geometry .t.f2 -} {30x60+51+42} -test place-7.4 {ReconfigurePlacement procedure, position rounding} { +} -result {30x60+51+42} +test place-7.4 {ReconfigurePlacement procedure, position rounding} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -x -1.6 -y -2.7 update winfo geometry .t.f2 -} {30x60+48+37} -test place-7.5 {ReconfigurePlacement procedure, position rounding} { +} -result {30x60+48+37} +test place-7.5 {ReconfigurePlacement procedure, position rounding} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -x 1.6 -y 2.7 update winfo geometry .t.f2 -} {30x60+52+43} -test place-7.6 {ReconfigurePlacement procedure, position rounding} { +} -result {30x60+52+43} +test place-7.6 {ReconfigurePlacement procedure, position rounding} -setup { + destroy .t.f3 +} -body { frame .t.f3 -width 100 -height 100 -bg #f00000 -bd 0 place .t.f3 -x 0 -y 0 raise .t.f2 @@ -168,38 +206,44 @@ test place-7.6 {ReconfigurePlacement procedure, position rounding} { place .t.f2 -in .t.f3 -relx .303 -rely .406 -relwidth .304 -relheight .206 update winfo geometry .t.f2 -} {31x20+30+41} -catch {destroy .t.f3} -test place-7.7 {ReconfigurePlacement procedure, computing size} { +} -cleanup { + destroy .t.f3 +} -result {31x20+30+41} +test place-7.7 {ReconfigurePlacement procedure, computing size} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -width 120 -height 89 update list [winfo width .t.f2] [winfo height .t.f2] -} {120 89} -test place-7.8 {ReconfigurePlacement procedure, computing size} { +} -result {120 89} +test place-7.8 {ReconfigurePlacement procedure, computing size} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -relwidth .4 -relheight .5 update list [winfo width .t.f2] [winfo height .t.f2] -} {60 40} -test place-7.9 {ReconfigurePlacement procedure, computing size} { +} -result {60 40} +test place-7.9 {ReconfigurePlacement procedure, computing size} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5 update list [winfo width .t.f2] [winfo height .t.f2] -} {70 36} -test place-7.10 {ReconfigurePlacement procedure, computing size} { +} -result {70 36} +test place-7.10 {ReconfigurePlacement procedure, computing size} -setup { place forget .t.f2 +} -body { place .t.f2 -in .t.f -width 10 -relwidth .4 -height -4 -relheight .5 place .t.f2 -width {} -relwidth {} -height {} -relheight {} update list [winfo width .t.f2] [winfo height .t.f2] -} {30 60} +} -result {30 60} -test place-8.1 {MasterStructureProc, mapping and unmapping slaves} { +test place-8.1 {MasterStructureProc, mapping and unmapping slaves} -setup { place forget .t.f2 place forget .t.f +} -body { place .t.f2 -relx 1.0 -rely 1.0 -anchor sw update set result [winfo ismapped .t.f2] @@ -212,10 +256,11 @@ test place-8.1 {MasterStructureProc, mapping and unmapping slaves} { wm deiconify .t update lappend result [winfo ismapped .t.f2] -} {1 0 40 30 0 1} -test place-8.2 {MasterStructureProc, mapping and unmapping slaves} { +} -result {1 0 40 30 0 1} +test place-8.2 {MasterStructureProc, mapping and unmapping slaves} -setup { place forget .t.f2 place forget .t.f +} -body { place .t.f -x 0 -y 0 -width 200 -height 100 place .t.f2 -in .t.f -relx 1.0 -rely 1.0 -anchor sw -width 50 -height 20 update @@ -229,130 +274,153 @@ test place-8.2 {MasterStructureProc, mapping and unmapping slaves} { wm deiconify .t update lappend result [winfo ismapped .t.f2] -} {1 0 42 32 0 1} - -test place-9.1 {PlaceObjCmd} { - list [catch {place} msg] $msg -} [list 1 "wrong # args: should be \"place option|pathName args\""] -test place-9.2 {PlaceObjCmd} { - list [catch {place foo} msg] $msg -} [list 1 "wrong # args: should be \"place option|pathName args\""] -test place-9.3 {PlaceObjCmd} { - catch {destroy .foo} - list [catch {place .foo bar} msg] $msg -} [list 1 "bad window path name \".foo\""] -test place-9.4 {PlaceObjCmd} { - catch {destroy .foo} - list [catch {place bar .foo} msg] $msg -} [list 1 "bad window path name \".foo\""] -test place-9.5 {PlaceObjCmd} { - catch {destroy .foo} +} -result {1 0 42 32 0 1} +destroy .t + + +test place-9.1 {PlaceObjCmd} -body { + place +} -returnCodes error -result {wrong # args: should be "place option|pathName args"} +test place-9.2 {PlaceObjCmd} -body { + place foo +} -returnCodes error -result {wrong # args: should be "place option|pathName args"} +test place-9.3 {PlaceObjCmd} -setup { + destroy .foo +} -body { + place .foo bar +} -returnCodes error -result {bad window path name ".foo"} +test place-9.4 {PlaceObjCmd} -setup { + destroy .foo +} -body { + place bar .foo +} -cleanup { + destroy .foo +} -returnCodes error -result {bad window path name ".foo"} +test place-9.5 {PlaceObjCmd} -setup { + destroy .foo +} -body { frame .foo - set res [list [catch {place badopt .foo} msg] $msg] + place badopt .foo +} -cleanup { destroy .foo - set res -} [list 1 "bad option \"badopt\": must be configure, forget, info, or slaves"] -test place-9.6 {PlaceObjCmd, configure errors} { - catch {destroy .foo} +} -returnCodes error -result {bad option "badopt": must be configure, forget, info, or slaves} +test place-9.6 {PlaceObjCmd, configure errors} -setup { + destroy .foo +} -body { frame .foo - set res [list [catch {place configure .foo} msg] $msg] + place configure .foo +} -cleanup { + destroy .foo +} -returnCodes ok -result {} +test place-9.7 {PlaceObjCmd, configure errors} -setup { destroy .foo - set res -} [list 0 ""] -test place-9.7 {PlaceObjCmd, configure errors} { - catch {destroy .foo} +} -body { frame .foo - set res [list [catch {place configure .foo bar} msg] $msg] + place configure .foo bar +} -cleanup { + destroy .foo +} -returnCodes ok -result {} +test place-9.8 {PlaceObjCmd, configure} -setup { destroy .foo - set res -} [list 0 ""] -test place-9.8 {PlaceObjCmd, configure} { - catch {destroy .foo} +} -body { frame .foo place .foo -x 0 -y 0 - set res [place configure .foo] + place configure .foo +} -cleanup { destroy .foo - set res -} [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}] -test place-9.9 {PlaceObjCmd, configure} { - catch {destroy .foo} +} -result [list {-anchor {} {} nw nw} {-bordermode {} {} inside inside} {-height {} {} {} {}} {-in {} {} {} .} {-relheight {} {} {} {}} {-relwidth {} {} {} {}} {-relx {} {} 0 0.0} {-rely {} {} 0 0.0} {-width {} {} {} {}} {-x {} {} 0 0} {-y {} {} 0 0}] +test place-9.9 {PlaceObjCmd, configure} -setup { + destroy .foo +} -body { frame .foo place .foo -x 0 -y 0 - set res [place configure .foo -x] + place configure .foo -x +} -cleanup { + destroy .foo +} -result {-x {} {} 0 0} +test place-9.10 {PlaceObjCmd, forget errors} -setup { destroy .foo - set res -} [list -x {} {} 0 0] -test place-9.10 {PlaceObjCmd, forget errors} { - catch {destroy .foo} +} -body { frame .foo - set res [list [catch {place forget .foo bar} msg] $msg] + place forget .foo bar +} -cleanup { destroy .foo - set res -} [list 1 "wrong # args: should be \"place forget pathName\""] -test place-9.11 {PlaceObjCmd, info errors} { - catch {destroy .foo} +} -returnCodes error -result {wrong # args: should be "place forget pathName"} +test place-9.11 {PlaceObjCmd, info errors} -setup { + destroy .foo +} -body { frame .foo - set res [list [catch {place info .foo bar} msg] $msg] + place info .foo bar +} -cleanup { + destroy .foo +} -returnCodes error -result {wrong # args: should be "place info pathName"} +test place-9.12 {PlaceObjCmd, slaves errors} -setup { destroy .foo - set res -} [list 1 "wrong # args: should be \"place info pathName\""] -test place-9.12 {PlaceObjCmd, slaves errors} { - catch {destroy .foo} +} -body { frame .foo - set res [list [catch {place slaves .foo bar} msg] $msg] + place slaves .foo bar +} -cleanup { destroy .foo - set res -} [list 1 "wrong # args: should be \"place slaves pathName\""] - -test place-10.1 {ConfigureSlave} { - catch {destroy .foo} +} -returnCodes error -result {wrong # args: should be "place slaves pathName"} + + +test place-10.1 {ConfigureSlave} -setup { + destroy .foo +} -body { frame .foo - set res [list [catch {place .foo -badopt} msg] $msg] + place .foo -badopt +} -cleanup { destroy .foo - set res -} [list 1 "unknown option \"-badopt\""] -test place-10.2 {ConfigureSlave} { - catch {destroy .foo} +} -returnCodes error -result {unknown option "-badopt"} +test place-10.2 {ConfigureSlave} -setup { + destroy .foo +} -body { frame .foo - set res [list [catch {place .foo -anchor} msg] $msg] + place .foo -anchor +} -cleanup { + destroy .foo +} -returnCodes error -result {value for "-anchor" missing} +test place-10.3 {ConfigureSlave} -setup { destroy .foo - set res -} [list 1 "value for \"-anchor\" missing"] -test place-10.3 {ConfigureSlave} { - catch {destroy .foo} +} -body { frame .foo - set res [list [catch {place .foo -bordermode j} msg] $msg] + place .foo -bordermode j +} -cleanup { + destroy .foo +} -returnCodes error -result {bad bordermode "j": must be inside, outside, or ignore} +test place-10.4 {ConfigureSlave} -setup { destroy .foo - set res -} [list 1 "bad bordermode \"j\": must be inside, outside, or ignore"] -test place-10.4 {ConfigureSlave} { - catch {destroy .foo} +} -body { frame .foo - set res [list [catch {place configure .foo -x 0 -y} msg] $msg] + place configure .foo -x 0 -y +} -cleanup { + destroy .foo +} -returnCodes error -result {value for "-y" missing} + + +test place-11.1 {PlaceObjCmd, slaves command} -setup { destroy .foo - set res -} [list 1 "value for \"-y\" missing"] - -test place-11.1 {PlaceObjCmd, slaves command} { - catch {destroy .foo} +} -body { frame .foo - set res [place slaves .foo] + place slaves .foo +} -cleanup { destroy .foo - set res -} {} -test place-11.2 {PlaceObjCmd, slaves command} { - catch {destroy .foo .bar} +} -result {} +test place-11.2 {PlaceObjCmd, slaves command} -setup { + destroy .foo .bar +} -body { frame .foo frame .bar place .bar -in .foo - set res [place slaves .foo] - destroy .foo - destroy .bar - set res -} [list .bar] + place slaves .foo +} -cleanup { + destroy .foo .bar +} -result [list .bar] + -test place-12.1 {PlaceObjCmd, forget command} { - catch {destroy .foo} +test place-12.1 {PlaceObjCmd, forget command} -setup { + destroy .foo +} -body { frame .foo place .foo -width 50 -height 50 update @@ -360,11 +428,14 @@ test place-12.1 {PlaceObjCmd, forget command} { place forget .foo update lappend res [winfo ismapped .foo] +} -cleanup { destroy .foo - set res -} [list 1 0] +} -result {1 0} + -test place-13.1 {test respect for internalborder} { +test place-13.1 {test respect for internalborder} -setup { + destroy .pack +} -body { toplevel .pack wm geometry .pack 200x200 frame .pack.l -width 15 -height 10 @@ -377,11 +448,13 @@ test place-13.1 {test respect for internalborder} { .pack.lf configure -labelanchor e -padx 3 -pady 5 update lappend res [winfo geometry .pack.lf.f] +} -cleanup { destroy .pack - set res -} {196x188+2+10 177x186+5+7} +} -result {196x188+2+10 177x186+5+7} -test place-14.1 {memory leak testing} -setup { + +test place-14.1 {memory leak testing} -constraints memory -setup { + destroy .f proc getbytes {} { set lines [split [memory info] "\n"] lindex [lindex $lines 3] 3 @@ -400,7 +473,7 @@ test place-14.1 {memory leak testing} -setup { } return $res } -} -constraints memory -body { +} -body { # Test all manners of forgetting a slave frame .f frame .f.f @@ -416,14 +489,16 @@ test place-14.1 {memory leak testing} -setup { frame .f frame .f.f } -} -result {0 0 0} -cleanup { +} -cleanup { destroy .f rename getbytes {} rename stress {} -} +} -result {0 0 0} -catch {destroy .t} # cleanup cleanupTests return + + + diff --git a/tests/raise.test b/tests/raise.test index a17fa2e..461ccbf 100644 --- a/tests/raise.test +++ b/tests/raise.test @@ -8,19 +8,20 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Procedure to create a bunch of overlapping windows, which should # make it easy to detect differences in order. proc raise_setup {} { foreach i [winfo child .raise] { - destroy $i - } + destroy $i + } foreach i {a b c d e} { - label .raise.$i -text $i -relief raised -bd 2 + label .raise.$i -text $i -relief raised -bd 2 } place .raise.a -x 20 -y 60 -width 60 -height 80 place .raise.b -x 60 -y 60 -width 60 -height 80 @@ -59,149 +60,173 @@ proc raise_makeToplevels {} { toplevel .raise wm geom .raise 250x200+0+0 -test raise-1.1 {preserve creation order} { + +test raise-1.1 {preserve creation order} -body { raise_setup tkwait visibility .raise.e raise_getOrder -} {d d d b c e e e} -test raise-1.2 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.2 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.a update raise_getOrder -} {d d d b c e e e} -test raise-1.3 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.3 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.c update raise_getOrder -} {d d d b c e e e} -test raise-1.4 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.4 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.e update raise_getOrder -} {d d d b c e e e} -test raise-1.5 {preserve creation order} testmakeexist { +} -result {d d d b c e e e} +test raise-1.5 {preserve creation order} -constraints testmakeexist -body { raise_setup testmakeexist .raise.d .raise.c .raise.b update raise_getOrder -} {d d d b c e e e} +} -result {d d d b c e e e} -test raise-2.1 {raise internal windows before creation} { + +test raise-2.1 {raise internal windows before creation} -body { raise_setup raise .raise.a update raise_getOrder -} {a d d a c a e e} -test raise-2.2 {raise internal windows before creation} { +} -result {a d d a c a e e} +test raise-2.2 {raise internal windows before creation} -body { raise_setup raise .raise.c update raise_getOrder -} {d d c b c e e c} -test raise-2.3 {raise internal windows before creation} { +} -result {d d c b c e e c} +test raise-2.3 {raise internal windows before creation} -body { raise_setup raise .raise.e update raise_getOrder -} {d d d b c e e e} -test raise-2.4 {raise internal windows before creation} { +} -result {d d d b c e e e} +test raise-2.4 {raise internal windows before creation} -body { raise_setup raise .raise.e .raise.a update raise_getOrder -} {d d d b c e b c} -test raise-2.5 {raise internal windows before creation} { +} -result {d d d b c e b c} +test raise-2.5 {raise internal windows before creation} -body { raise_setup raise .raise.a .raise.d update raise_getOrder -} {a d d a c e e e} +} -result {a d d a c e e e} + -test raise-3.1 {raise internal windows after creation} { +test raise-3.1 {raise internal windows after creation} -body { raise_setup update raise .raise.a .raise.d raise_getOrder -} {a d d a c e e e} -test raise-3.2 {raise internal windows after creation} testmakeexist { +} -result {a d d a c e e e} +test raise-3.2 {raise internal windows after creation} -constraints { + testmakeexist +} -body { raise_setup testmakeexist .raise.a .raise.b raise .raise.a .raise.b update raise_getOrder -} {d d d a c e e e} -test raise-3.3 {raise internal windows after creation} testmakeexist { +} -result {d d d a c e e e} +test raise-3.3 {raise internal windows after creation} -constraints { + testmakeexist +} -body { raise_setup testmakeexist .raise.a .raise.d raise .raise.a .raise.b update raise_getOrder -} {d d d a c e e e} -test raise-3.4 {raise internal windows after creation} testmakeexist { +} -result {d d d a c e e e} +test raise-3.4 {raise internal windows after creation} -constraints { + testmakeexist +} -body { raise_setup testmakeexist .raise.a .raise.c .raise.d raise .raise.a .raise.b update raise_getOrder -} {d d d a c e e e} +} -result {d d d a c e e e} -test raise-4.1 {raise relative to nephews} { + +test raise-4.1 {raise relative to nephews} -body { raise_setup update frame .raise.d.child raise .raise.a .raise.d.child raise_getOrder -} {a d d a c e e e} -test raise-4.2 {raise relative to nephews} { +} -result {a d d a c e e e} +test raise-4.2 {raise relative to nephews} -setup { + destroy .raise2 +} -body { raise_setup update frame .raise2 - list [catch {raise .raise.a .raise2} msg] $msg -} {1 {can't raise ".raise.a" above ".raise2"}} -catch {destroy .raise2} + raise .raise.a .raise2 +} -cleanup { + destroy .raise2 +} -returnCodes error -result {can't raise ".raise.a" above ".raise2"} -test raise-5.1 {lower internal windows} { + +test raise-5.1 {lower internal windows} -body { raise_setup update lower .raise.d raise_getOrder -} {a b c b c e e e} -test raise-5.2 {lower internal windows} { +} -result {a b c b c e e e} +test raise-5.2 {lower internal windows} -body { raise_setup update lower .raise.d .raise.b raise_getOrder -} {d b c b c e e e} -test raise-5.3 {lower internal windows} { +} -result {d b c b c e e e} +test raise-5.3 {lower internal windows} -body { raise_setup update lower .raise.a .raise.e raise_getOrder -} {a d d a c e e e} -test raise-5.4 {lower internal windows} { +} -result {a d d a c e e e} +test raise-5.4 {lower internal windows} -setup { + destroy .raise2 +} -body { raise_setup update frame .raise2 - list [catch {lower .raise.a .raise2} msg] $msg -} {1 {can't lower ".raise.a" below ".raise2"}} -catch {destroy .raise2} + lower .raise.a .raise2 +} -cleanup { + destroy .raise2 +} -returnCodes error -result {can't lower ".raise.a" below ".raise2"} -test raise-6.1 {raise/lower toplevel windows} {nonPortable} { + +test raise-6.1 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise1 winfo containing [winfo rootx .raise1] [winfo rooty .raise1] -} .raise1 -test raise-6.2 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise1} +test raise-6.2 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise2 winfo containing [winfo rootx .raise1] [winfo rooty .raise1] -} .raise2 -test raise-6.3 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise2} +test raise-6.3 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise3 @@ -214,8 +239,10 @@ test raise-6.3 {raise/lower toplevel windows} {nonPortable} { after 500 list $result [winfo containing [winfo rootx .raise1] \ [winfo rooty .raise1]] -} {.raise2 .raise1} -test raise-6.4 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise2 .raise1} +test raise-6.4 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise2 @@ -230,14 +257,18 @@ test raise-6.4 {raise/lower toplevel windows} {nonPortable} { after 500 list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] -} {.raise1 .raise3} -test raise-6.5 {raise/lower toplevel windows} {nonPortable} { +} -result {.raise1 .raise3} +test raise-6.5 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels raise .raise1 set time [lindex [time {raise .raise1}] 0] expr {$time < 2000000} -} 1 -test raise-6.6 {raise/lower toplevel windows} {nonPortable} { +} -result 1 +test raise-6.6 {raise/lower toplevel windows} -constraints { + nonPortable +} -body { raise_makeToplevels update raise .raise2 @@ -253,35 +284,37 @@ test raise-6.6 {raise/lower toplevel windows} {nonPortable} { after 500 list $result [winfo containing [winfo rootx .raise2] \ [winfo rooty .raise2]] -} {.raise1 .raise3} +} -result {.raise1 .raise3} + -test raise-7.1 {errors in raise/lower commands} { - list [catch {raise} msg] $msg -} {1 {wrong # args: should be "raise window ?aboveThis?"}} -test raise-7.2 {errors in raise/lower commands} { - list [catch {raise a b c} msg] $msg -} {1 {wrong # args: should be "raise window ?aboveThis?"}} -test raise-7.3 {errors in raise/lower commands} { - list [catch {raise badName} msg] $msg -} {1 {bad window path name "badName"}} -test raise-7.4 {errors in raise/lower commands} { - list [catch {raise . badName2} msg] $msg -} {1 {bad window path name "badName2"}} -test raise-7.5 {errors in raise/lower commands} { - list [catch {lower} msg] $msg -} {1 {wrong # args: should be "lower window ?belowThis?"}} -test raise-7.6 {errors in raise/lower commands} { - list [catch {lower a b c} msg] $msg -} {1 {wrong # args: should be "lower window ?belowThis?"}} -test raise-7.7 {errors in raise/lower commands} { - list [catch {lower badName3} msg] $msg -} {1 {bad window path name "badName3"}} -test raise-7.8 {errors in raise/lower commands} { - list [catch {lower . badName4} msg] $msg -} {1 {bad window path name "badName4"}} +test raise-7.1 {errors in raise/lower commands} -body { + raise +} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"} +test raise-7.2 {errors in raise/lower commands} -body { + raise a b c +} -returnCodes error -result {wrong # args: should be "raise window ?aboveThis?"} +test raise-7.3 {errors in raise/lower commands} -body { + raise badName +} -returnCodes error -result {bad window path name "badName"} +test raise-7.4 {errors in raise/lower commands} -body { + raise . badName2 +} -returnCodes error -result {bad window path name "badName2"} +test raise-7.5 {errors in raise/lower commands} -body { + lower +} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"} +test raise-7.6 {errors in raise/lower commands} -body { + lower a b c +} -returnCodes error -result {wrong # args: should be "lower window ?belowThis?"} +test raise-7.7 {errors in raise/lower commands} -body { + lower badName3 +} -returnCodes error -result {bad window path name "badName3"} +test raise-7.8 {errors in raise/lower commands} -body { + lower . badName4 +} -returnCodes error -result {bad window path name "badName4"} deleteWindows # cleanup cleanupTests return + diff --git a/tests/safe.test b/tests/safe.test index 3e9f716..99681ee 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -6,9 +6,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test ## NOTE: Any time tests fail here with an error like: @@ -41,99 +42,117 @@ if {[string equal $tcl_platform(platform) "windows"]} { set saveAutoPath $::auto_path set auto_path [list [info library] $::tk_library] -test safe-1.1 {Safe Tk loading into an interpreter} { - catch {safe::interpDelete a} +test safe-1.1 {Safe Tk loading into an interpreter} -setup { + catch {safe::interpDelete a} +} -body { safe::loadTk [safe::interpCreate a] safe::interpDelete a set x {} - set x -} "" -test safe-1.2 {Safe Tk loading into an interpreter} { - catch {safe::interpDelete a} + return $x +} -result {} +test safe-1.2 {Safe Tk loading into an interpreter} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a - set l [lsort [interp hidden a]] + lsort [interp hidden a] +} -cleanup { safe::interpDelete a - set l -} $hidden_cmds -test safe-1.3 {Safe Tk loading into an interpreter} -body { - catch {safe::interpDelete a} +} -result $hidden_cmds +test safe-1.3 {Safe Tk loading into an interpreter} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a - set l [lsort [interp aliases a]] + lsort [interp aliases a] +} -cleanup { safe::interpDelete a - set l } -match glob -result {*encoding*exit*file*load*source*} -test safe-2.1 {Unsafe commands not available} { - catch {safe::interpDelete a} + +test safe-2.1 {Unsafe commands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {toplevel .t}} msg]} { set status ok } + return $status +} -cleanup { safe::interpDelete a - set status -} ok -test safe-2.2 {Unsafe commands not available} { - catch {safe::interpDelete a} +} -result ok +test safe-2.2 {Unsafe commands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {menu .m}} msg]} { set status ok } + return $status +} -cleanup { safe::interpDelete a - set status -} ok -test safe-2.3 {Unsafe subcommands not available} { - catch {safe::interpDelete a} +} -result ok +test safe-2.3 {Unsafe subcommands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {tk appname}} msg]} { set status ok } - safe::interpDelete a list $status $msg -} {ok {appname not accessible in a safe interpreter}} -test safe-2.4 {Unsafe subcommands not available} { - catch {safe::interpDelete a} +} -cleanup { + safe::interpDelete a +} -result {ok {appname not accessible in a safe interpreter}} +test safe-2.4 {Unsafe subcommands not available} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status broken if {[catch {interp eval a {tk scaling}} msg]} { set status ok } - safe::interpDelete a list $status $msg -} {ok {scaling not accessible in a safe interpreter}} +} -cleanup { + safe::interpDelete a +} -result {ok {scaling not accessible in a safe interpreter}} + -test safe-3.1 {Unsafe commands are available hidden} { - catch {safe::interpDelete a} +test safe-3.1 {Unsafe commands are available hidden} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status ok if {[catch {interp invokehidden a toplevel .t} msg]} { set status broken } + return $status +} -cleanup { safe::interpDelete a - set status -} ok -test safe-3.2 {Unsafe commands are available hidden} { - catch {safe::interpDelete a} +} -result ok +test safe-3.2 {Unsafe commands are available hidden} -setup { + catch {safe::interpDelete a} +} -body { safe::interpCreate a safe::loadTk a set status ok if {[catch {interp invokehidden a menu .m} msg]} { set status broken } + return $status +} -cleanup { safe::interpDelete a - set status -} ok +} -result ok -test safe-4.1 {testing loadTk} { + +test safe-4.1 {testing loadTk} -body { # no error shall occur, the user will # eventually see a new toplevel set i [safe::loadTk [safe::interpCreate]] @@ -142,27 +161,28 @@ test safe-4.1 {testing loadTk} { # to position the window (if the wm does not do it automatically) # and thus make the test suite not runable non interactively safe::interpDelete $i -} {} +} -result {} -test safe-4.2 {testing loadTk -use} { +test safe-4.2 {testing loadTk -use} -body { set w .safeTkFrame - catch {destroy $w} + destroy $w frame $w -container 1; pack .safeTkFrame set i [safe::loadTk [safe::interpCreate] -use [winfo id $w]] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w -} {} +} -result {} + -test safe-5.1 {loading Tk in safe interps without master's clearance} { +test safe-5.1 {loading Tk in safe interps without master's clearance} -body { set i [safe::interpCreate] - catch {interp eval $i {load {} Tk}} msg + interp eval $i {load {} Tk} +} -cleanup { safe::interpDelete $i - set msg -} {not allowed to start Tk by master's safe::TkInit} +} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit} -test safe-5.2 {multi-level Tk loading with clearance} { +test safe-5.2 {multi-level Tk loading with clearance} -body { # No error shall occur in that test and no window # shall remain at the end. set i [safe::interpCreate] @@ -170,47 +190,52 @@ test safe-5.2 {multi-level Tk loading with clearance} { set j [safe::interpCreate $j] safe::loadTk $j interp eval $j { - button .b -text Ok -command {destroy .} - pack .b -# tkwait window . ; # for interactive testing/debugging + button .b -text Ok -command {destroy .} + pack .b +# tkwait window . ; # for interactive testing/debugging } +} -cleanup { safe::interpDelete $j safe::interpDelete $i -} {} +} -result {} -test safe-6.1 {loadTk -use windowPath} { + +test safe-6.1 {loadTk -use windowPath} -body { set w .safeTkFrame - catch {destroy $w} + destroy $w frame $w -container 1; pack .safeTkFrame set i [safe::loadTk [safe::interpCreate] -use $w] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w -} {} +} -result {} -test safe-6.2 {loadTk -use windowPath, conflicting -display} { +test safe-6.2 {loadTk -use windowPath, conflicting -display} -body { set w .safeTkFrame - catch {destroy $w} + destroy $w frame $w -container 1; pack .safeTkFrame set i [safe::interpCreate] catch {safe::loadTk $i -use $w -display :23.56} msg + string range $msg 0 36 +} -cleanup { safe::interpDelete $i destroy $w - string range $msg 0 36 -} {conflicting -display :23.56 and -use } +} -result {conflicting -display :23.56 and -use } -test safe-7.1 {canvas printing} { +test safe-7.1 {canvas printing} -body { set i [safe::loadTk [safe::interpCreate]] - set r [catch {interp eval $i {canvas .c; .c postscript}}] + interp eval $i {canvas .c; .c postscript} +} -cleanup { safe::interpDelete $i - set r -} 0 +} -returnCodes ok -match glob -result * # cleanup set ::auto_path $saveAutoPath unset hidden_cmds cleanupTests return + + diff --git a/tests/scale.test b/tests/scale.test index 657f668..13ccb4d 100644 --- a/tests/scale.test +++ b/tests/scale.test @@ -6,7 +6,8 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands @@ -17,220 +18,497 @@ option add *Scale.borderWidth 2 option add *Scale.highlightThickness 2 option add *Scale.font {Helvetica -12 bold} +# Widget used in 1.* tests scale .s -from 100 -to 300 pack .s update -set i 1 -foreach test { - {-activebackground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bigincrement 12.5 12.5 badValue - {expected floating-point number but got "badValue"}} - {-bg #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-command "set x" {set x} {} {}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-digits 5 5 badValue {expected integer but got "badValue"}} - {-fg #00ff00 #00ff00 badValue {unknown color name "badValue"}} - {-font fixed fixed {} {font "" doesn't exist}} - {-foreground green green badValue {unknown color name "badValue"}} - {-from -15.0 -15.0 badValue - {expected floating-point number but got "badValue"}} - {-highlightbackground #112233 #112233 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 non-existent - {unknown color name "non-existent"}} - {-highlightthickness 2 2 badValue {bad screen distance "badValue"}} - {-label "Some text" {Some text} {} {}} - {-length 130 130 badValue {bad screen distance "badValue"}} - {-orient horizontal horizontal badValue - {bad orient "badValue": must be horizontal or vertical}} - {-orient horizontal horizontal {} {}} - {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-repeatdelay 14 14 bogus {expected integer but got "bogus"}} - {-repeatinterval 14 14 bogus {expected integer but got "bogus"}} - {-resolution 2.0 2.0 badValue - {expected floating-point number but got "badValue"}} - {-showvalue 0 0 badValue {expected boolean value but got "badValue"}} - {-sliderlength 86 86 badValue {bad screen distance "badValue"}} - {-sliderrelief raised raised badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} - {-state d disabled badValue - {bad state "badValue": must be active, disabled, or normal}} - {-state n normal {} {}} - {-takefocus "any string" "any string" {} {}} - {-tickinterval 4.3 4.0 badValue - {expected floating-point number but got "badValue"}} - {-to 14.9 15.0 badValue - {expected floating-point number but got "badValue"}} - {-troughcolor #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-variable x x {} {}} - {-width 32 32 badValue {bad screen distance "badValue"}} -} { - set name [lindex $test 0] - test scale-1.$i {configuration options} { - .s configure $name [lindex $test 1] - lindex [.s configure $name] 4 - } [lindex $test 2] - incr i - if {[lindex $test 3] ne ""} { - test scale-1.$i {configuration options} { - list [catch {.s configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .s configure $name [lindex [.s configure $name] 3] - incr i -} + +test scale-1.1 {configuration options} -body { + .s configure -activebackground #ff0000 + .s cget -activebackground +} -cleanup { + .s configure -activebackground [lindex [.s configure -activebackground] 3] +} -result {#ff0000} +test scale-1.2 {configuration options} -body { + .s configure -activebackground non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test scale-1.3 {configuration options} -body { + .s configure -background #ff0000 + .s cget -background +} -cleanup { + .s configure -background [lindex [.s configure -background] 3] +} -result {#ff0000} +test scale-1.4 {configuration options} -body { + .s configure -background non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test scale-1.5 {configuration options} -body { + .s configure -bd 4 + .s cget -bd +} -cleanup { + .s configure -bd [lindex [.s configure -bd] 3] +} -result {4} +test scale-1.6 {configuration options} -body { + .s configure -bd badValue +} -returnCodes error -result {bad screen distance "badValue"} +test scale-1.7 {configuration options} -body { + .s configure -bigincrement 12.5 + .s cget -bigincrement +} -cleanup { + .s configure -bigincrement [lindex [.s configure -bigincrement] 3] +} -result {12.5} +test scale-1.8 {configuration options} -body { + .s configure -bigincrement badValue +} -returnCodes error -result {expected floating-point number but got "badValue"} +test scale-1.9 {configuration options} -body { + .s configure -bg #ff0000 + .s cget -bg +} -cleanup { + .s configure -bg [lindex [.s configure -bg] 3] +} -result {#ff0000} +test scale-1.10 {configuration options} -body { + .s configure -bg non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test scale-1.11 {configuration options} -body { + .s configure -borderwidth 1.3 + .s cget -borderwidth +} -cleanup { + .s configure -borderwidth [lindex [.s configure -borderwidth] 3] +} -result {1} +test scale-1.12 {configuration options} -body { + .s configure -borderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test scale-1.13 {configuration options} -body { + .s configure -command {set x} + .s cget -command +} -cleanup { + .s configure -command [lindex [.s configure -command] 3] +} -result {set x} +test scale-1.15 {configuration options} -body { + .s configure -cursor arrow + .s cget -cursor +} -cleanup { + .s configure -cursor [lindex [.s configure -cursor] 3] +} -result {arrow} +test scale-1.16 {configuration options} -body { + .s configure -cursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test scale-1.17 {configuration options} -body { + .s configure -digits 5 + .s cget -digits +} -cleanup { + .s configure -digits [lindex [.s configure -digits] 3] +} -result {5} +test scale-1.18 {configuration options} -body { + .s configure -digits badValue +} -returnCodes error -result {expected integer but got "badValue"} +test scale-1.19 {configuration options} -body { + .s configure -fg #00ff00 + .s cget -fg +} -cleanup { + .s configure -fg [lindex [.s configure -fg] 3] +} -result {#00ff00} +test scale-1.20 {configuration options} -body { + .s configure -fg badValue +} -returnCodes error -result {unknown color name "badValue"} +test scale-1.21 {configuration options} -body { + .s configure -font fixed + .s cget -font +} -cleanup { + .s configure -font [lindex [.s configure -font] 3] +} -result {fixed} +test scale-1.23 {configuration options} -body { + .s configure -foreground green + .s cget -foreground +} -cleanup { + .s configure -foreground [lindex [.s configure -foreground] 3] +} -result {green} +test scale-1.24 {configuration options} -body { + .s configure -foreground badValue +} -returnCodes error -result {unknown color name "badValue"} +test scale-1.25 {configuration options} -body { + .s configure -from -15.0 + .s cget -from +} -cleanup { + .s configure -from [lindex [.s configure -from] 3] +} -result {-15.0} +test scale-1.26 {configuration options} -body { + .s configure -from badValue +} -returnCodes error -result {expected floating-point number but got "badValue"} +test scale-1.27 {configuration options} -body { + .s configure -highlightbackground #112233 + .s cget -highlightbackground +} -cleanup { + .s configure -highlightbackground [lindex [.s configure -highlightbackground] 3] +} -result {#112233} +test scale-1.28 {configuration options} -body { + .s configure -highlightbackground ugly +} -returnCodes error -result {unknown color name "ugly"} +test scale-1.29 {configuration options} -body { + .s configure -highlightcolor #123456 + .s cget -highlightcolor +} -cleanup { + .s configure -highlightcolor [lindex [.s configure -highlightcolor] 3] +} -result {#123456} +test scale-1.30 {configuration options} -body { + .s configure -highlightcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test scale-1.31 {configuration options} -body { + .s configure -highlightthickness 2 + .s cget -highlightthickness +} -cleanup { + .s configure -highlightthickness [lindex [.s configure -highlightthickness] 3] +} -result {2} +test scale-1.32 {configuration options} -body { + .s configure -highlightthickness badValue +} -returnCodes error -result {bad screen distance "badValue"} +test scale-1.33 {configuration options} -body { + .s configure -label {Some text} + .s cget -label +} -cleanup { + .s configure -label [lindex [.s configure -label] 3] +} -result {Some text} +test scale-1.35 {configuration options} -body { + .s configure -length 130 + .s cget -length +} -cleanup { + .s configure -length [lindex [.s configure -length] 3] +} -result {130} +test scale-1.36 {configuration options} -body { + .s configure -length badValue +} -returnCodes error -result {bad screen distance "badValue"} +test scale-1.37 {configuration options} -body { + .s configure -orient horizontal + .s cget -orient +} -cleanup { + .s configure -orient [lindex [.s configure -orient] 3] +} -result {horizontal} +test scale-1.38 {configuration options} -body { + .s configure -orient badValue +} -returnCodes error -result {bad orient "badValue": must be horizontal or vertical} +test scale-1.39 {configuration options} -body { + .s configure -orient horizontal + .s cget -orient +} -cleanup { + .s configure -orient [lindex [.s configure -orient] 3] +} -result {horizontal} +test scale-1.41 {configuration options} -body { + .s configure -relief ridge + .s cget -relief +} -cleanup { + .s configure -relief [lindex [.s configure -relief] 3] +} -result {ridge} +test scale-1.42 {configuration options} -body { + .s configure -relief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test scale-1.43 {configuration options} -body { + .s configure -repeatdelay 14 + .s cget -repeatdelay +} -cleanup { + .s configure -repeatdelay [lindex [.s configure -repeatdelay] 3] +} -result {14} +test scale-1.44 {configuration options} -body { + .s configure -repeatdelay bogus +} -returnCodes error -result {expected integer but got "bogus"} +test scale-1.45 {configuration options} -body { + .s configure -repeatinterval 14 + .s cget -repeatinterval +} -cleanup { + .s configure -repeatinterval [lindex [.s configure -repeatinterval] 3] +} -result {14} +test scale-1.46 {configuration options} -body { + .s configure -repeatinterval bogus +} -returnCodes error -result {expected integer but got "bogus"} +test scale-1.47 {configuration options} -body { + .s configure -resolution 2.0 + .s cget -resolution +} -cleanup { + .s configure -resolution [lindex [.s configure -resolution] 3] +} -result {2.0} +test scale-1.48 {configuration options} -body { + .s configure -resolution badValue +} -returnCodes error -result {expected floating-point number but got "badValue"} +test scale-1.49 {configuration options} -body { + .s configure -showvalue 0 + .s cget -showvalue +} -cleanup { + .s configure -showvalue [lindex [.s configure -showvalue] 3] +} -result {0} +test scale-1.50 {configuration options} -body { + .s configure -showvalue badValue +} -returnCodes error -result {expected boolean value but got "badValue"} +test scale-1.51 {configuration options} -body { + .s configure -sliderlength 86 + .s cget -sliderlength +} -cleanup { + .s configure -sliderlength [lindex [.s configure -sliderlength] 3] +} -result {86} +test scale-1.52 {configuration options} -body { + .s configure -sliderlength badValue +} -returnCodes error -result {bad screen distance "badValue"} +test scale-1.53 {configuration options} -body { + .s configure -sliderrelief raised + .s cget -sliderrelief +} -cleanup { + .s configure -sliderrelief [lindex [.s configure -sliderrelief] 3] +} -result {raised} +test scale-1.54 {configuration options} -body { + .s configure -sliderrelief badValue +} -returnCodes error -result {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} +test scale-1.55 {configuration options} -body { + .s configure -state d + .s cget -state +} -cleanup { + .s configure -state [lindex [.s configure -state] 3] +} -result {disabled} +test scale-1.56 {configuration options} -body { + .s configure -state badValue +} -returnCodes error -result {bad state "badValue": must be active, disabled, or normal} +test scale-1.57 {configuration options} -body { + .s configure -state n + .s cget -state +} -cleanup { + .s configure -state [lindex [.s configure -state] 3] +} -result {normal} +test scale-1.59 {configuration options} -body { + .s configure -takefocus {any string} + .s cget -takefocus +} -cleanup { + .s configure -takefocus [lindex [.s configure -takefocus] 3] +} -result {any string} +test scale-1.61 {configuration options} -body { + .s configure -tickinterval 4.3 + .s cget -tickinterval +} -cleanup { + .s configure -tickinterval [lindex [.s configure -tickinterval] 3] +} -result {4.0} +test scale-1.62 {configuration options} -body { + .s configure -tickinterval badValue +} -returnCodes error -result {expected floating-point number but got "badValue"} +test scale-1.63 {configuration options} -body { + .s configure -to 14.9 + .s cget -to +} -cleanup { + .s configure -to [lindex [.s configure -to] 3] +} -result {15.0} +test scale-1.64 {configuration options} -body { + .s configure -to badValue +} -returnCodes error -result {expected floating-point number but got "badValue"} +test scale-1.65 {configuration options} -body { + .s configure -troughcolor #ff0000 + .s cget -troughcolor +} -cleanup { + .s configure -troughcolor [lindex [.s configure -troughcolor] 3] +} -result {#ff0000} +test scale-1.66 {configuration options} -body { + .s configure -troughcolor non-existent +} -returnCodes error -result {unknown color name "non-existent"} +test scale-1.67 {configuration options} -body { + .s configure -variable x + .s cget -variable +} -cleanup { + .s configure -variable [lindex [.s configure -variable] 3] +} -result {x} +test scale-1.69 {configuration options} -body { + .s configure -width 32 + .s cget -width +} -cleanup { + .s configure -width [lindex [.s configure -width] 3] +} -result {32} +test scale-1.70 {configuration options} -body { + .s configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} destroy .s -test scale-2.1 {Tk_ScaleCmd procedure} { - list [catch {scale} msg] $msg -} {1 {wrong # args: should be "scale pathName ?options?"}} -test scale-2.2 {Tk_ScaleCmd procedure} { - list [catch {scale foo} msg] $msg [winfo child .] -} {1 {bad window path name "foo"} {}} -test scale-2.3 {Tk_ScaleCmd procedure} { - list [catch {scale .s -gorp dumb} msg] $msg [winfo child .] -} {1 {unknown option "-gorp"} {}} +test scale-2.1 {Tk_ScaleCmd procedure} -body { + scale +} -returnCodes error -result {wrong # args: should be "scale pathName ?-option value ...?"} +test scale-2.2 {Tk_ScaleCmd procedure} -body { + scale foo +} -returnCodes error -result {bad window path name "foo"} +test scale-2.3 {Tk_ScaleCmd procedure} -body { + catch {scale foo} + winfo child . +} -result {} +test scale-2.4 {Tk_ScaleCmd procedure} -body { + scale .s -gorp dumb +} -returnCodes error -result {unknown option "-gorp"} +test scale-2.5 {Tk_ScaleCmd procedure} -body { + catch {scale .s -gorp dumb} + winfo child . +} -result {} + + +# Widget used in 3.* tests +destroy .s scale .s -from 100 -to 200 pack .s update idletasks -test scale-3.1 {ScaleWidgetCmd procedure} { - list [catch {.s} msg] $msg -} {1 {wrong # args: should be ".s option ?arg arg ...?"}} -test scale-3.2 {ScaleWidgetCmd procedure, cget option} { - list [catch {.s cget} msg] $msg -} {1 {wrong # args: should be ".s cget option"}} -test scale-3.3 {ScaleWidgetCmd procedure, cget option} { - list [catch {.s cget a b} msg] $msg -} {1 {wrong # args: should be ".s cget option"}} -test scale-3.4 {ScaleWidgetCmd procedure, cget option} { - list [catch {.s cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test scale-3.5 {ScaleWidgetCmd procedure, cget option} { +test scale-3.1 {ScaleWidgetCmd procedure} -body { + .s +} -returnCodes error -result {wrong # args: should be ".s option ?arg ...?"} +test scale-3.2 {ScaleWidgetCmd procedure, cget option} -body { + .s cget +} -returnCodes error -result {wrong # args: should be ".s cget option"} +test scale-3.3 {ScaleWidgetCmd procedure, cget option} -body { + .s cget a b +} -returnCodes error -result {wrong # args: should be ".s cget option"} +test scale-3.4 {ScaleWidgetCmd procedure, cget option} -body { + .s cget -gorp +} -returnCodes error -result {unknown option "-gorp"} +test scale-3.5 {ScaleWidgetCmd procedure, cget option} -body { + .s configure -highlightthickness 2 .s cget -highlightthickness -} {2} -test scale-3.6 {ScaleWidgetCmd procedure, configure option} { +} -result {2} +test scale-3.6 {ScaleWidgetCmd procedure, configure option} -body { list [llength [.s configure]] [lindex [.s configure] 6] -} {33 {-command command Command {} {}}} -test scale-3.7 {ScaleWidgetCmd procedure, configure option} { - list [catch {.s configure -foo} msg] $msg -} {1 {unknown option "-foo"}} -test scale-3.8 {ScaleWidgetCmd procedure, configure option} { - list [catch {.s configure -borderwidth 2 -bg} msg] $msg -} {1 {value for "-bg" missing}} -test scale-3.9 {ScaleWidgetCmd procedure, coords option} { - list [catch {.s coords a b} msg] $msg -} {1 {wrong # args: should be ".s coords ?value?"}} -test scale-3.10 {ScaleWidgetCmd procedure, coords option} { - list [catch {.s coords bad} msg] $msg -} {1 {expected floating-point number but got "bad"}} -test scale-3.11 {ScaleWidgetCmd procedure} {fonts} { +} -result {33 {-command command Command {} {}}} +test scale-3.7 {ScaleWidgetCmd procedure, configure option} -body { + .s configure -foo +} -returnCodes error -result {unknown option "-foo"} +test scale-3.8 {ScaleWidgetCmd procedure, configure option} -body { + .s configure -borderwidth 2 -bg +} -returnCodes error -result {value for "-bg" missing} +test scale-3.9 {ScaleWidgetCmd procedure, coords option} -body { + .s coords a b +} -returnCodes error -result {wrong # args: should be ".s coords ?value?"} +test scale-3.10 {ScaleWidgetCmd procedure, coords option} -body { + .s coords bad +} -returnCodes error -result {expected floating-point number but got "bad"} +test scale-3.11 {ScaleWidgetCmd procedure} -constraints { + fonts +} -body { + .s configure -from 100 -to 200 + update idletasks .s set 120 .s coords -} {38 34} -test scale-3.12 {ScaleWidgetCmd procedure, coords option} {fonts} { - .s configure -orient horizontal - update +} -result {38 34} +test scale-3.12 {ScaleWidgetCmd procedure, coords option} -constraints { + fonts +} -body { + .s configure -from 100 -to 200 -orient horizontal + update idletasks .s set 120 .s coords -} {34 31} -.s configure -orient vertical -update -test scale-3.13 {ScaleWidgetCmd procedure, get option} { - list [catch {.s get a} msg] $msg -} {1 {wrong # args: should be ".s get ?x y?"}} -test scale-3.14 {ScaleWidgetCmd procedure, get option} { - list [catch {.s get a b c} msg] $msg -} {1 {wrong # args: should be ".s get ?x y?"}} -test scale-3.15 {ScaleWidgetCmd procedure, get option} { - list [catch {.s get a 11} msg] $msg -} {1 {expected integer but got "a"}} -test scale-3.16 {ScaleWidgetCmd procedure, get option} { - list [catch {.s get 12 b} msg] $msg -} {1 {expected integer but got "b"}} -test scale-3.17 {ScaleWidgetCmd procedure, get option} { +} -result {34 31} +test scale-3.13 {ScaleWidgetCmd procedure, get option} -body { + .s configure -orient vertical + update + .s get a +} -returnCodes error -result {wrong # args: should be ".s get ?x y?"} +test scale-3.14 {ScaleWidgetCmd procedure, get option} -body { + .s configure -orient vertical + update + .s get a b c +} -returnCodes error -result {wrong # args: should be ".s get ?x y?"} +test scale-3.15 {ScaleWidgetCmd procedure, get option} -body { + .s configure -orient vertical + update + .s get a 11 +} -returnCodes error -result {expected integer but got "a"} +test scale-3.16 {ScaleWidgetCmd procedure, get option} -body { + .s configure -orient vertical + update + .s get 12 b +} -returnCodes error -result {expected integer but got "b"} +test scale-3.17 {ScaleWidgetCmd procedure, get option} -body { + .s configure -orient vertical + update .s set 133 .s get -} 133 -test scale-3.18 {ScaleWidgetCmd procedure, get option} { - .s configure -resolution 0.5 +} -result 133 +test scale-3.18 {ScaleWidgetCmd procedure, get option} -body { + .s configure -orient vertical -resolution 0.5 + update .s set 150 .s get 37 34 -} 119.5 +} -result {119.5} .s configure -resolution 1 -test scale-3.19 {ScaleWidgetCmd procedure, identify option} { - list [catch {.s identify} msg] $msg -} {1 {wrong # args: should be ".s identify x y"}} -test scale-3.20 {ScaleWidgetCmd procedure, identify option} { - list [catch {.s identify 1 2 3} msg] $msg -} {1 {wrong # args: should be ".s identify x y"}} -test scale-3.21 {ScaleWidgetCmd procedure, identify option} { - list [catch {.s identify boo 16} msg] $msg -} {1 {expected integer but got "boo"}} -test scale-3.22 {ScaleWidgetCmd procedure, identify option} { - list [catch {.s identify 17 bad} msg] $msg -} {1 {expected integer but got "bad"}} -test scale-3.23 {ScaleWidgetCmd procedure, identify option} {fonts} { +test scale-3.19 {ScaleWidgetCmd procedure, identify option} -body { + .s identify +} -returnCodes error -result {wrong # args: should be ".s identify x y"} +test scale-3.20 {ScaleWidgetCmd procedure, identify option} -body { + .s identify 1 2 3 +} -returnCodes error -result {wrong # args: should be ".s identify x y"} +test scale-3.21 {ScaleWidgetCmd procedure, identify option} -body { + .s identify boo 16 +} -returnCodes error -result {expected integer but got "boo"} +test scale-3.22 {ScaleWidgetCmd procedure, identify option} -body { + .s identify 17 bad +} -returnCodes error -result {expected integer but got "bad"} +test scale-3.23 {ScaleWidgetCmd procedure, identify option} -constraints { + fonts +} -body { + .s configure -from 100 -to 200 -orient vertical -resolution 1 + update .s set 120 list [.s identify 35 10] [.s identify 35 30] [.s identify 35 80] [.s identify 5 80] -} {trough1 slider trough2 {}} -test scale-3.24 {ScaleWidgetCmd procedure, set option} { - list [catch {.s set} msg] $msg -} {1 {wrong # args: should be ".s set value"}} -test scale-3.25 {ScaleWidgetCmd procedure, set option} { - list [catch {.s set a b} msg] $msg -} {1 {wrong # args: should be ".s set value"}} -test scale-3.26 {ScaleWidgetCmd procedure, set option} { - list [catch {.s set bad} msg] $msg -} {1 {expected floating-point number but got "bad"}} -test scale-3.27 {ScaleWidgetCmd procedure, set option} { +} -result {trough1 slider trough2 {}} +test scale-3.24 {ScaleWidgetCmd procedure, set option} -body { + .s set +} -returnCodes error -result {wrong # args: should be ".s set value"} +test scale-3.25 {ScaleWidgetCmd procedure, set option} -body { + .s set a b +} -returnCodes error -result {wrong # args: should be ".s set value"} +test scale-3.26 {ScaleWidgetCmd procedure, set option} -body { + .s set bad +} -returnCodes error -result {expected floating-point number but got "bad"} +test scale-3.27 {ScaleWidgetCmd procedure, set option} -body { + .s configure -from 100 -to 200 -orient vertical -resolution 0.5 + update .s set 142 -} {} -test scale-3.28 {ScaleWidgetCmd procedure, set option} { +} -result {} +test scale-3.28 {ScaleWidgetCmd procedure, set option} -body { + .s configure -from 100 -to 200 -orient vertical -resolution 1 + update .s set 118 .s configure -state disabled .s set 181 .s configure -state normal .s get -} {118} -test scale-3.29 {ScaleWidgetCmd procedure} { - list [catch {.s dumb} msg] $msg -} {1 {bad option "dumb": must be cget, configure, coords, get, identify, or set}} -test scale-3.30 {ScaleWidgetCmd procedure} { - list [catch {.s c} msg] $msg -} {1 {ambiguous option "c": must be cget, configure, coords, get, identify, or set}} -test scale-3.31 {ScaleWidgetCmd procedure} { - list [catch {.s co} msg] $msg -} {1 {ambiguous option "co": must be cget, configure, coords, get, identify, or set}} -test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} { +} -result {118} +test scale-3.29 {ScaleWidgetCmd procedure} -body { + .s dumb +} -returnCodes error -result {bad option "dumb": must be cget, configure, coords, get, identify, or set} +test scale-3.30 {ScaleWidgetCmd procedure} -body { + .s c +} -returnCodes error -result {ambiguous option "c": must be cget, configure, coords, get, identify, or set} +test scale-3.31 {ScaleWidgetCmd procedure} -body { + .s co +} -returnCodes error -result {ambiguous option "co": must be cget, configure, coords, get, identify, or set} +destroy .s + +test scale-3.32 {ScaleWidgetCmd procedure, Tk_Preserve} -setup { + destroy .s +} -body { proc kill args { - destroy .s + destroy .s } - catch {destroy .s} scale .s -variable x -from 0 -to 100 -orient horizontal pack .s update .s configure -command kill .s set 55 -} {} +} -cleanup { + destroy .s +} -result {} + -test scale-4.1 {DestroyScale procedure} { - catch {destroy .s} +test scale-4.1 {DestroyScale procedure} -setup { + deleteWindows +} -body { set x 50 scale .s -variable x -from 0 -to 100 -orient horizontal pack .s update destroy .s list [catch {set x foo} msg] $msg $x -} {0 foo foo} +} -result {0 foo foo} + -test scale-5.1 {ConfigureScale procedure} { - catch {destroy .s} +test scale-5.1 {ConfigureScale procedure} -setup { + deleteWindows +} -body { set x 66 set y 77 scale .s -variable x -from 0 -to 100 @@ -238,14 +516,20 @@ test scale-5.1 {ConfigureScale procedure} { update .s configure -variable y list [catch {set x foo} msg] $msg $x [.s get] -} {0 foo foo 77} -test scale-5.2 {ConfigureScale procedure} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {0 foo foo 77} +test scale-5.2 {ConfigureScale procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 - list [catch {.s configure -foo bar} msg] $msg -} {1 {unknown option "-foo"}} -test scale-5.3 {ConfigureScale procedure} { - catch {destroy .s} + .s configure -foo bar +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-foo"} +test scale-5.3 {ConfigureScale procedure} -setup { + deleteWindows +} -body { catch {unset x} scale .s -from 0 -to 100 -variable x set result $x @@ -255,349 +539,475 @@ test scale-5.3 {ConfigureScale procedure} { .s set 3 lappend result $x unset x - lappend result [catch {set x} msg] $msg -} {0 0 92 3 0 3} -test scale-5.4 {ConfigureScale procedure} { - catch {destroy .s} + lappend result [set x] +} -cleanup { + deleteWindows +} -result {0 0 92 3 3} +test scale-5.4 {ConfigureScale procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 - list [catch {.s configure -orient dumb} msg] $msg -} {1 {bad orient "dumb": must be horizontal or vertical}} -test scale-5.5 {ConfigureScale procedure} { - catch {destroy .s} + .s configure -orient dumb +} -cleanup { + deleteWindows +} -returnCodes error -result {bad orient "dumb": must be horizontal or vertical} +test scale-5.5 {ConfigureScale procedure} -setup { + deleteWindows +} -body { scale .s -from 1.11 -to 1.89 -resolution .1 -tickinterval .76 list [format %.1f [.s cget -from]] [format %.1f [.s cget -to]] \ - [format %.1f [.s cget -tickinterval]] -} {1.1 1.9 0.8} -test scale-5.6 {ConfigureScale procedure} { - catch {destroy .s} + [format %.1f [.s cget -tickinterval]] +} -cleanup { + deleteWindows +} -result {1.1 1.9 0.8} +test scale-5.6 {ConfigureScale procedure} -setup { + deleteWindows +} -body { scale .s -from 1 -to 10 -tickinterval -2 pack .s set result [lindex [.s configure -tickinterval] 4] .s configure -from 10 -to 1 -tickinterval 2 lappend result [lindex [.s configure -tickinterval] 4] -} {2.0 -2.0} -test scale-5.7 {ConfigureScale procedure} { - catch {destroy .s} - list [catch {scale .s -from 0 -to 100 -state bogus} msg] $msg -} {1 {bad state "bogus": must be active, disabled, or normal}} +} -cleanup { + deleteWindows +} -result {2.0 -2.0} +test scale-5.7 {ConfigureScale procedure} -setup { + deleteWindows +} -body { + scale .s -from 0 -to 100 -state bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {bad state "bogus": must be active, disabled, or normal} + -catch {destroy .s} +# Widget used in 6.* tests +destroy .s scale .s -orient horizontal -length 200 pack .s -test scale-6.1 {ComputeFormat procedure} { +test scale-6.1 {ComputeFormat procedure} -body { .s configure -from 10 -to 100 -resolution 10 .s set 49.3 .s get -} {50} -test scale-6.2 {ComputeFormat procedure} { +} -result {50} +test scale-6.2 {ComputeFormat procedure} -body { .s configure -from 100 -to 1000 -resolution 100 .s set 493 .s get -} {500} -test scale-6.3 {ComputeFormat procedure} { +} -result {500} +test scale-6.3 {ComputeFormat procedure} -body { .s configure -from 1000 -to 10000 -resolution 1000 .s set 4930 .s get -} {5000} -test scale-6.4 {ComputeFormat procedure} { +} -result {5000} +test scale-6.4 {ComputeFormat procedure} -body { .s configure -from 10000 -to 100000 -resolution 10000 .s set 49000 .s get -} {50000} -test scale-6.5 {ComputeFormat procedure} { +} -result {50000} +test scale-6.5 {ComputeFormat procedure} -body { .s configure -from 100000 -to 1000000 -resolution 100000 .s set 493000 .s get -} {500000} -test scale-6.6 {ComputeFormat procedure} {nonPortable} { +} -result {500000} +test scale-6.6 {ComputeFormat procedure} -constraints { + nonPortable +} -body { # This test is non-portable because some platforms format the # result as 5e+06. - .s configure -from 1000000 -to 10000000 -resolution 1000000 .s set 4930000 .s get -} {5000000} -test scale-6.7 {ComputeFormat procedure} { +} -result {5000000} +test scale-6.7 {ComputeFormat procedure} -body { .s configure -from 1000000000 -to 10000000000 -resolution 1000000000 .s set 4930000000 expr {[.s get] == 5.0e+09} -} 1 -test scale-6.8 {ComputeFormat procedure} { +} -result 1 +test scale-6.8 {ComputeFormat procedure} -body { .s configure -from .1 -to 1 -resolution .1 .s set .6 .s get -} {0.6} -test scale-6.9 {ComputeFormat procedure} { +} -result {0.6} +test scale-6.9 {ComputeFormat procedure} -body { .s configure -from .01 -to .1 -resolution .01 .s set .06 .s get -} {0.06} -test scale-6.10 {ComputeFormat procedure} { +} -result {0.06} +test scale-6.10 {ComputeFormat procedure} -body { .s configure -from .001 -to .01 -resolution .001 .s set .006 .s get -} {0.006} -test scale-6.11 {ComputeFormat procedure} { +} -result {0.006} +test scale-6.11 {ComputeFormat procedure} -body { .s configure -from .0001 -to .001 -resolution .0001 .s set .0006 .s get -} {0.0006} -test scale-6.12 {ComputeFormat procedure} { +} -result {0.0006} +test scale-6.12 {ComputeFormat procedure} -body { .s configure -from .00001 -to .0001 -resolution .00001 .s set .00006 .s get -} {0.00006} -test scale-6.13 {ComputeFormat procedure} { +} -result {0.00006} +test scale-6.13 {ComputeFormat procedure} -body { .s configure -from .000001 -to .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} -} {1} -test scale-6.14 {ComputeFormat procedure} { +} -result {1} +test scale-6.14 {ComputeFormat procedure} -body { .s configure -to .00001 -from .0001 -resolution .00001 .s set .00006 .s get -} {0.00006} -test scale-6.15 {ComputeFormat procedure} { +} -result {0.00006} +test scale-6.15 {ComputeFormat procedure} -body { .s configure -to .000001 -from .00001 -resolution .000001 .s set .000006 expr {[.s get] == 6.0e-06} -} {1} -test scale-6.16 {ComputeFormat procedure} { +} -result {1} +test scale-6.16 {ComputeFormat procedure} -body { .s configure -from .00001 -to .0001 -resolution .00001 -digits 1 .s set .00006 expr {[.s get] == 6e-05} -} {1} -test scale-6.17 {ComputeFormat procedure} { +} -result {1} +test scale-6.17 {ComputeFormat procedure} -body { .s configure -from 10000000 -to 100000000 -resolution 10000000 -digits 3 .s set 49300000 .s get -} {50000000} -test scale-6.18 {ComputeFormat procedure} { +} -result {50000000} +test scale-6.18 {ComputeFormat procedure} -body { .s configure -length 200 -from 0 -to 10 -resolution 0 -digits 0 .s set .111111111 .s get -} {0.11} -test scale-6.19 {ComputeFormat procedure} { +} -result {0.11} +test scale-6.19 {ComputeFormat procedure} -body { .s configure -length 200 -from 1000 -to 1002 -resolution 0 -digits 0 .s set 1001.23456789 .s get -} {1001.23} -test scale-6.20 {ComputeFormat procedure} { +} -result {1001.23} +test scale-6.20 {ComputeFormat procedure} -body { .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 0 .s set 1001.23456789 .s get -} {1001.235} +} -result {1001.235} +destroy .s -test scale-7.1 {ComputeScaleGeometry procedure} {nonPortable fonts} { - catch {destroy .s} + +test scale-7.1 {ComputeScaleGeometry procedure} -constraints { + nonPortable fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 10 -label "Short" -orient vertical -length 5i pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {88 458} -test scale-7.2 {ComputeScaleGeometry procedure} {fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {88 458} +test scale-7.2 {ComputeScaleGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 1000 -label "Long string" -orient vertical -tick 200 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {168 108} -test scale-7.3 {ComputeScaleGeometry procedure} {fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {168 108} +test scale-7.3 {ComputeScaleGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -width 10 \ - -sliderlength 10 + -sliderlength 10 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {22 108} -test scale-7.4 {ComputeScaleGeometry procedure} {fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {22 108} +test scale-7.4 {ComputeScaleGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 1000 -orient vertical -showvalue 0 -bd 5 \ - -relief sunken + -relief sunken pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {39 114} -test scale-7.5 {ComputeScaleGeometry procedure} {nonPortable fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {39 114} +test scale-7.5 {ComputeScaleGeometry procedure} -constraints { + nonPortable fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 10 -label "Short" -orient horizontal -length 5i pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {458 61} -test scale-7.6 {ComputeScaleGeometry procedure} {fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {458 61} +test scale-7.6 {ComputeScaleGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 1000 -label "Long string" -orient horizontal \ - -tick 500 + -tick 500 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {108 79} -test scale-7.7 {ComputeScaleGeometry procedure} {fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {108 79} +test scale-7.7 {ComputeScaleGeometry procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {108 27} -test scale-7.8 {ComputeScaleGeometry procedure} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {108 27} +test scale-7.8 {ComputeScaleGeometry procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 1000 -orient horizontal -showvalue 0 -bd 5 \ - -relief raised -highlightthickness 2 + -relief raised -highlightthickness 2 pack .s update list [winfo reqwidth .s] [winfo reqheight .s] -} {114 39} +} -cleanup { + deleteWindows +} -result {114 39} + -test scale-8.1 {ScaleElement procedure} {fonts} { - catch {destroy .s} +test scale-8.1 {ScaleElement procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 pack .s .s set 30 update list [.s identify 53 52] [.s identify 54 52] [.s identify 70 52] \ - [.s identify 71 52] -} {{} trough1 trough1 {}} -test scale-8.2 {ScaleElement procedure} {fonts} { - catch {destroy .s} + [.s identify 71 52] +} -cleanup { + deleteWindows +} -result {{} trough1 trough1 {}} +test scale-8.2 {ScaleElement procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 pack .s .s set 30 update list [.s identify 60 2] [.s identify 60 3] [.s identify 60 302] \ - [.s identify 60 303] -} {{} trough1 trough2 {}} -test scale-8.3 {ScaleElement procedure} {fonts} { - catch {destroy .s} + [.s identify 60 303] +} -cleanup { + deleteWindows +} -result {{} trough1 trough2 {}} +test scale-8.3 {ScaleElement procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient vertical -bd 1 -tick 20 -length 300 pack .s .s set 30 update list [.s identify 60 83] [.s identify 60 84] [.s identify 60 113] \ - [.s identify 60 114] \ -} {trough1 slider slider trough2} -test scale-8.4 {ScaleElement procedure} { - catch {destroy .s} + [.s identify 60 114] \ +} -cleanup { + deleteWindows +} -result {trough1 slider slider trough2} +test scale-8.4 {ScaleElement procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient vertical -bd 4 -width 10 \ - -highlightthickness 1 -length 300 -showvalue 0 + -highlightthickness 1 -length 300 -showvalue 0 pack .s .s set 30 update list [.s identify 4 40] [.s identify 5 40] [.s identify 22 40] \ - [.s identify 23 40] \ -} {{} trough1 trough1 {}} -test scale-8.5 {ScaleElement procedure} {fonts} { - catch {destroy .s} + [.s identify 23 40] \ +} -cleanup { + deleteWindows +} -result {{} trough1 trough1 {}} +test scale-8.5 {ScaleElement procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient horizontal -bd 1 \ - -highlightthickness 2 -tick 20 -sliderlength 20 \ - -length 200 -label Test + -highlightthickness 2 -tick 20 -sliderlength 20 \ + -length 200 -label Test pack .s .s set 30 update list [.s identify 150 36] [.s identify 150 37] [.s identify 150 53] \ - [.s identify 150 54] -} {{} trough2 trough2 {}} -test scale-8.6 {ScaleElement procedure} {fonts} { - catch {destroy .s} + [.s identify 150 54] +} -cleanup { + deleteWindows +} -result {{} trough2 trough2 {}} +test scale-8.6 {ScaleElement procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient horizontal -bd 2 \ - -highlightthickness 1 -tick 20 -length 200 + -highlightthickness 1 -tick 20 -length 200 pack .s .s set 30 update list [.s identify 150 20] [.s identify 150 21] [.s identify 150 39] \ - [.s identify 150 40] -} {{} trough2 trough2 {}} -test scale-8.7 {ScaleElement procedure} { - catch {destroy .s} + [.s identify 150 40] +} -cleanup { + deleteWindows +} -result {{} trough2 trough2 {}} +test scale-8.7 {ScaleElement procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient horizontal -bd 4 -highlightthickness 2 \ - -length 200 -width 10 -showvalue 0 + -length 200 -width 10 -showvalue 0 pack .s .s set 30 update list [.s identify 30 5] [.s identify 30 6] [.s identify 30 23] \ - [.s identify 30 24] -} {{} trough1 trough1 {}} -test scale-8.8 {ScaleElement procedure} { - catch {destroy .s} + [.s identify 30 24] +} -cleanup { + deleteWindows +} -result {{} trough1 trough1 {}} +test scale-8.8 {ScaleElement procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \ - -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 + -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 pack .s .s set 30 update list [.s identify 2 28] [.s identify 3 28] [.s identify 202 28] \ - [.s identify 203 28] -} {{} trough1 trough2 {}} -test scale-8.9 {ScaleElement procedure} { - catch {destroy .s} + [.s identify 203 28] +} -cleanup { + deleteWindows +} -result {{} trough1 trough2 {}} +test scale-8.9 {ScaleElement procedure} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -orient horizontal -bd 1 -highlightthickness 2 \ - -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 + -tick 20 -sliderlength 20 -length 200 -label Test -showvalue 0 pack .s .s set 80 update list [.s identify 145 28] [.s identify 146 28] [.s identify 165 28] \ - [.s identify 166 28] -} {trough1 slider slider trough2} + [.s identify 166 28] +} -cleanup { + deleteWindows +} -result {trough1 slider slider trough2} -catch {destroy .s} -scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 -pack .s -update -test scale-9.1 {PixelToValue procedure} { + +#widget used in 9.* tests +destroy .s +pack [scale .s] +test scale-9.1 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get 46 0 -} 0 -test scale-9.2 {PixelToValue procedure} { +} -result 0 +test scale-9.2 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 9 -} 0 -test scale-9.3 {PixelToValue procedure} { +} -result 0 +test scale-9.3 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 12 -} 1 -test scale-9.4 {PixelToValue procedure} { +} -result 1 +test scale-9.4 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 46 -} 35 -test scale-9.5 {PixelToValue procedure} { +} -result 35 +test scale-9.5 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 110 -} 99 -test scale-9.6 {PixelToValue procedure} { +} -result 99 +test scale-9.6 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 111 -} 100 -test scale-9.7 {PixelToValue procedure} { +} -result 100 +test scale-9.7 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 112 -} 100 -test scale-9.8 {PixelToValue procedure} { +} -result 100 +test scale-9.8 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 + update .s get -10 154 -} 100 -.s configure -orient horizontal -update -test scale-9.9 {PixelToValue procedure} { +} -result 100 +test scale-9.9 {PixelToValue procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal + update .s get 76 152 -} 65 +} -result 65 +destroy .s + -test scale-10.1 {ValueToPixel procedure} {fonts} { - catch {destroy .s} +test scale-10.1 {ValueToPixel procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 0 -to 100 -sliderlength 20 -length 124 -bd 2 \ - -orient horizontal -label Test -tick 20 + -orient horizontal -label Test -tick 20 pack .s update list [.s coords -10] [.s coords 40] [.s coords 1000] -} {{16 47} {56 47} {116 47}} -test scale-10.2 {ValueToPixel procedure} {fonts} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {{16 47} {56 47} {116 47}} +test scale-10.2 {ValueToPixel procedure} -constraints { + fonts +} -setup { + deleteWindows +} -body { scale .s -from 100 -to 0 -sliderlength 20 -length 122 -bd 1 \ - -orient vertical -label Test -tick 20 + -orient vertical -label Test -tick 20 pack .s update list [.s coords -10] [.s coords 40] [.s coords 1000] -} {{62 114} {62 74} {62 14}} +} -cleanup { + deleteWindows +} -result {{62 114} {62 74} {62 14}} + -test scale-11.1 {ScaleEventProc procedure} { +test scale-11.1 {ScaleEventProc procedure} -setup { + deleteWindows +} -body { proc killScale value { - global x - if {$value > 30} { - destroy .s1 - lappend x [winfo exists .s1] [info commands .s1] - } + global x + if {$value > 30} { + destroy .s1 + lappend x [winfo exists .s1] [info commands .s1] + } } - catch {destroy .s1} set x initial scale .s1 -from 0 -to 100 -command killScale .s1 set 20 @@ -606,60 +1016,74 @@ test scale-11.1 {ScaleEventProc procedure} { lappend x [winfo exists .s1] .s1 set 40 update idletasks + return $x +} -cleanup { rename killScale {} - set x -} {initial 1 0 {}} -test scale-11.2 {ScaleEventProc procedure} { deleteWindows +} -result {initial 1 0 {}} +test scale-11.2 {ScaleEventProc procedure} -setup { + deleteWindows + set x {} +} -body { scale .s1 -bg #543210 rename .s1 .s2 - set x {} lappend x [winfo children .] lappend x [.s2 cget -bg] destroy .s1 lappend x [info command .s*] [winfo children .] -} {.s1 #543210 {} {}} +} -cleanup { + deleteWindows +} -result {.s1 #543210 {} {}} -test scale-12.1 {ScaleCmdDeletedProc procedure} { +test scale-12.1 {ScaleCmdDeletedProc procedure} -setup { deleteWindows +} -body { scale .s1 rename .s1 {} list [info command .s*] [winfo children .] -} {{} {}} +} -cleanup { + deleteWindows +} -result {{} {}} -catch {destroy .s} -scale .s -from 0 -to 100 -command {set x} -variable y -pack .s + +# Widget used in 13.* tests +destroy .s +pack [scale .s] update -proc varTrace args { - global traceInfo - set traceInfo $args -} -test scale-13.1 {SetScaleValue procedure} { +test scale-13.1 {SetScaleValue procedure} -body { + .s configure -from 0 -to 100 -command {set x} -variable y + update set x xyzzy .s set 44 set result [list $x $y] update lappend result $x $y -} {xyzzy 44 44 44} -test scale-13.2 {SetScaleValue procedure} { +} -result {xyzzy 44 44 44} +test scale-13.2 {SetScaleValue procedure} -body { .s set -3 .s get -} 0 -test scale-13.3 {SetScaleValue procedure} { +} -result 0 +test scale-13.3 {SetScaleValue procedure} -body { .s set 105 .s get -} 100 +} -result 100 .s configure -from 100 -to 0 -test scale-13.4 {SetScaleValue procedure} { +test scale-13.4 {SetScaleValue procedure} -body { .s set -3 .s get -} 0 -test scale-13.5 {SetScaleValue procedure} { +} -result 0 +test scale-13.5 {SetScaleValue procedure} -body { .s set 105 .s get -} 100 -test scale-13.6 {SetScaleValue procedure} { +} -result 100 +test scale-13.6 {SetScaleValue procedure} -body { + proc varTrace args { + global traceInfo + set traceInfo $args + } + .s configure -from 0 -to 100 -command {set x} -variable y + update + .s set 50 update trace variable y w varTrace @@ -668,127 +1092,201 @@ test scale-13.6 {SetScaleValue procedure} { .s set 50 update list $x $traceInfo -} {untouched empty} +} -result {untouched empty} -catch {destroy .s} -scale .s -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 -orient horizontal -pack .s -update -.s configure -resolution 4.0 + +# Widget used in 14.* tests +destroy .s +pack [scale .s] update -test scale-14.1 {RoundToResolution procedure} { +test scale-14.1 {RoundToResolution procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 84 152 -} 72 -test scale-14.2 {RoundToResolution procedure} { +} -result 72 +test scale-14.2 {RoundToResolution procedure} -body { + .s configure -from 0 -to 100 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 86 152 -} 76 -.s configure -from 100 -to 0 -update -test scale-14.3 {RoundToResolution procedure} { +} -result 76 + +test scale-14.3 {RoundToResolution procedure} -body { + .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 84 152 -} 28 -test scale-14.4 {RoundToResolution procedure} { +} -result 28 +test scale-14.4 {RoundToResolution procedure} -body { + .s configure -from 100 -to 0 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 86 152 -} 24 -.s configure -from -100 -to 0 -update -test scale-14.5 {RoundToResolution procedure} { +} -result 24 + +test scale-14.5 {RoundToResolution procedure} -body { + .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 84 152 -} -28 -test scale-14.6 {RoundToResolution procedure} { +} -result {-28} +test scale-14.6 {RoundToResolution procedure} -body { + .s configure -from -100 -to 0 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 86 152 -} -24 -.s configure -from 0 -to -100 -update -test scale-14.7 {RoundToResolution procedure} { +} -result {-24} + +test scale-14.7 {RoundToResolution procedure} -body { + .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 84 152 -} -72 -test scale-14.8 {RoundToResolution procedure} { +} -result {-72} +test scale-14.8 {RoundToResolution procedure} -body { + .s configure -from 0 -to -100 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 4.0 + update .s get 86 152 -} -76 -.s configure -from 0 -to 2.25 -resolution 0 -update -test scale-14.9 {RoundToResolution procedure} { +} -result {-76} + +test scale-14.9 {RoundToResolution procedure} -body { + .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 0 + update .s get 84 152 -} 1.64 -test scale-14.10 {RoundToResolution procedure} { +} -result {1.64} +test scale-14.10 {RoundToResolution procedure} -body { + .s configure -from 0 -to 2.25 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 0 + update .s get 86 152 -} 1.69 -.s configure -from 0 -to 225 -resolution 0 -digits 5 -update -test scale-14.11 {RoundToResolution procedure} { +} -result {1.69} + +test scale-14.11 {RoundToResolution procedure} -body { + .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 0 -digits 5 + update .s get 84 152 -} 164.25 -test scale-14.12 {RoundToResolution procedure} { +} -result {164.25} +test scale-14.12 {RoundToResolution procedure} -body { + .s configure -from 0 -to 225 -sliderlength 10 -length 114 -bd 2 \ + -orient horizontal -resolution 0 -digits 5 + update .s get 86 152 -} 168.75 +} -result {168.75} +destroy .s -test scale-15.1 {ScaleVarProc procedure} { - catch {destroy .s} + +test scale-15.1 {ScaleVarProc procedure} -setup { + deleteWindows +} -body { set y -130 scale .s -from 0 -to -200 -variable y -orient horizontal -length 150 pack .s - set y -} -130 -test scale-15.2 {ScaleVarProc procedure} { - catch {destroy .s} + return $y +} -result {-130} +test scale-15.2 {ScaleVarProc procedure} -setup { + deleteWindows +} -body { set y -130 scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 pack .s set y -87 .s get -} -87 -test scale-15.3 {ScaleVarProc procedure} { - catch {destroy .s} +} -result {-87} +test scale-15.3 {ScaleVarProc procedure} -setup { + deleteWindows +} -body { set y -130 scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 pack .s - list [catch {set y 40q} msg] $msg [.s get] -} {1 {can't set "y": can't assign non-numeric value to scale variable} -130} -test scale-15.4 {ScaleVarProc procedure} { - catch {destroy .s} + set y 40q +} -cleanup { + deleteWindows +} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable} +test scale-15.4 {ScaleVarProc procedure} -setup { + deleteWindows +} -body { + set y -130 + scale .s -from -200 -to 0 -variable y -orient horizontal -length 150 + pack .s + catch {set y 40q} + .s get +} -cleanup { + deleteWindows +} -result {-130} +test scale-15.5 {ScaleVarProc procedure} -setup { + deleteWindows +} -body { + set y 1 + scale .s -from 1 -to 0 -variable y -orient horizontal -length 150 + pack .s + set y x +} -cleanup { + deleteWindows +} -returnCodes error -result {can't set "y": can't assign non-numeric value to scale variable} +test scale-15.6 {ScaleVarProc procedure} -setup { + deleteWindows +} -body { set y 1 scale .s -from 1 -to 0 -variable y -orient horizontal -length 150 pack .s - list [catch {set y x} msg] $msg [.s get] -} {1 {can't set "y": can't assign non-numeric value to scale variable} 1} -test scale-15.5 {ScaleVarProc procedure, variable deleted} { - catch {destroy .s} + catch {set y x} + .s get +} -cleanup { + deleteWindows +} -result 1 +test scale-15.7 {ScaleVarProc procedure, variable deleted} -setup { + deleteWindows +} -body { set y 6 scale .s -from 10 -to 0 -variable y -orient horizontal -length 150 \ - -command "set x" + -command "set x" pack .s update set x untouched unset y update list [catch {set y} msg] $msg [.s get] $x -} {0 6 6 untouched} -test scale-15.6 {ScaleVarProc procedure, don't call -command} { - catch {destroy .s} +} -cleanup { + deleteWindows +} -result {0 6 6 untouched} +test scale-15.8 {ScaleVarProc procedure, don't call -command} -setup { + deleteWindows +} -body { set y 6 scale .s -from 0 -to 100 -variable y -orient horizontal -length 150 \ - -command "set x" + -command "set x" pack .s update set x untouched set y 60 update list $x [.s get] -} {untouched 60} +} -cleanup { + deleteWindows +} -result {untouched 60} -set l [interp hidden] -deleteWindows -test scale-16.1 {scale widget vs hidden commands} { - catch {destroy .s} +test scale-16.1 {scale widget vs hidden commands} -body { + set l [interp hidden] + deleteWindows scale .s interp hide {} .s destroy .s - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -cleanup { + deleteWindows +} -result 1 + -test scale-17.1 {bug fix 1786} { +test scale-17.1 {bug fix 1786} -setup { + deleteWindows +} -body { # Perhaps x is set to {}, depending on what other tests have run. # If x is unset, or set to something not convertable to a double, # then the scale try to initialize its value with the contents @@ -803,66 +1301,62 @@ test scale-17.1 {bug fix 1786} { # Bug 4833 changed the result to realize that x should pick up # a value from the scale. In an FPE occurs, it is due to the # lack of errno being set to 0 by some libc's. (see bug 4942) - set x -} {100} + return $x +} -cleanup { + deleteWindows +} -result {100} + -test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} { - catch {destroy .s} +test scale-18.1 {DestroyScale, -cursor option [Bug: 3897]} -setup { + deleteWindows +} -body { scale .s -cursor trek destroy .s -} {} - -test scale-18.2 {Scale button 1 events [Bug 787065]} \ - -setup { - catch {destroy .s} - set y 5 - scale .s -from 0 -to 10 -variable y -orient horizontal -length 150 - pack .s - tkwait visibility .s - set ::error {} - proc bgerror {args} {set ::error $args} - } \ - -body { - list [catch { - event generate .s <1> -x 0 -y 0 - event generate .s <ButtonRelease-1> -x 0 -y 0 - update - set ::error - } msg] $msg - } \ - -cleanup { - unset ::error - rename bgerror {} - catch {destroy .s} - } \ - -result {0 {}} - -test scale-18.3 {Scale button 2 events [Bug 787065]} \ - -setup { - catch {destroy .s} - set y 5 - scale .s -from 0 -to 10 -variable y -orient horizontal -length 150 - pack .s - tkwait visibility .s - set ::error {} - proc bgerror {args} {set ::error $args} - } \ - -body { - list [catch { - event generate .s <2> -x 0 -y 0 - event generate .s <ButtonRelease-2> -x 0 -y 0 - update - set ::error - } msg] $msg - } \ - -cleanup { - unset ::error - rename bgerror {} - catch {destroy .s} - } \ - -result {0 {}} - -catch {destroy .s} +} -result {} + +test scale-18.2 {Scale button 1 events [Bug 787065]} -setup { + destroy .s + set ::error {} + proc bgerror {args} {set ::error $args} +} -body { + set y 5 + scale .s -from 0 -to 10 -variable y -orient horizontal -length 150 + pack .s + tkwait visibility .s + list [catch { + event generate .s <1> -x 0 -y 0 + event generate .s <ButtonRelease-1> -x 0 -y 0 + update + set ::error + } msg] $msg +} -cleanup { + unset ::error + rename bgerror {} + destroy .s +} -result {0 {}} + +test scale-18.3 {Scale button 2 events [Bug 787065]} -setup { + destroy .s + set ::error {} + proc bgerror {args} {set ::error $args} +} -body { + set y 5 + scale .s -from 0 -to 10 -variable y -orient horizontal -length 150 + pack .s + tkwait visibility .s + list [catch { + event generate .s <2> -x 0 -y 0 + event generate .s <ButtonRelease-2> -x 0 -y 0 + update + set ::error + } msg] $msg +} -cleanup { + unset ::error + rename bgerror {} + destroy .s +} -result {0 {}} + + option clear # cleanup diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 5d4334f..3addd28 100644 --- a/tests/scrollbar.test +++ b/tests/scrollbar.test @@ -57,7 +57,7 @@ foreach test { {-activebackground #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-activerelief sunken sunken non-existent - {bad relief type "non-existent": must be flat, groove, raised, ridge, solid, or sunken}} + {bad relief "non-existent": must be flat, groove, raised, ridge, solid, or sunken}} {-background #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} {-bd 4 4 badValue {bad screen distance "badValue"}} @@ -75,7 +75,7 @@ foreach test { {-orient horizontal horizontal badValue {bad orientation "badValue": must be vertical or horizontal}} {-orient horizontal horizontal bogus {bad orientation "bogus": must be vertical or horizontal}} - {-relief ridge ridge badValue {bad relief type "badValue": must be flat, groove, raised, ridge, solid, or sunken}} + {-relief ridge ridge badValue {bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken}} {-repeatdelay 140 140 129.3 {expected integer but got "129.3"}} {-repeatinterval 140 140 129.3 {expected integer but got "129.3"}} {-takefocus "any string" "any string" {} {}} @@ -99,7 +99,7 @@ foreach test { destroy .s test scrollbar-2.1 {Tk_ScrollbarCmd procedure} -returnCodes error -body { scrollbar -} -result {wrong # args: should be "scrollbar pathName ?options?"} +} -result {wrong # args: should be "scrollbar pathName ?-option value ...?"} test scrollbar-2.2 {Tk_ScrollbarCmd procedure} -body { scrollbar gorp } -returnCodes error -result {bad window path name "gorp"} @@ -127,7 +127,7 @@ pack .s -side right -fill y update test scrollbar-3.1 {ScrollbarWidgetCmd procedure} { list [catch {.s} msg] $msg -} {1 {wrong # args: should be ".s option ?arg arg ...?"}} +} {1 {wrong # args: should be ".s option ?arg ...?"}} test scrollbar-3.2 {ScrollbarWidgetCmd procedure, "cget" option} { list [catch {.s cget} msg] $msg } {1 {wrong # args: should be ".s cget option"}} diff --git a/tests/select.test b/tests/select.test index 8cbfd39..e4c512d 100644 --- a/tests/select.test +++ b/tests/select.test @@ -1,6 +1,6 @@ # This file is a Tcl script to test out Tk's selection management code, -# especially the "selection" command. It is organized in the standard -# fashion for Tcl tests. +# especially the "selection" command. It is organized in the standard fashion +# for Tcl tests. # # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. @@ -11,12 +11,12 @@ # environment variable TK_ALT_DISPLAY is set to an alternate display. # -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* +namespace import ::tk::test:loadTkCommand eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force ::tk::test:loadTkCommand - global longValue selValue selInfo set selValue {} @@ -109,48 +109,55 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { } # Now we start the main body of the test code - -test select-1.1 {Tk_CreateSelHandler procedure} { + +test select-1.1 {Tk_CreateSelHandler procedure} -setup { setup +} -body { lsort [selection get TARGETS] -} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} -test select-1.2 {Tk_CreateSelHandler procedure} { +} -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} +test select-1.2 {Tk_CreateSelHandler procedure} -setup { setup +} -body { selection handle .f1 {handler TEST} TEST lsort [selection get TARGETS] -} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} -test select-1.3 {Tk_CreateSelHandler procedure} { +} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} +test select-1.3 {Tk_CreateSelHandler procedure} -setup { global selValue selInfo setup +} -body { selection handle .f1 {handler TEST} TEST set selValue "Test value" set selInfo "" list [selection get TEST] $selInfo -} {{Test value} {TEST 0 4000}} -test select-1.4.1 {Tk_CreateSelHandler procedure} unix { +} -result {{Test value} {TEST 0 4000}} +test select-1.4.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { setup +} -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} lsort [selection get TARGETS] -} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} -test select-1.4.2 {Tk_CreateSelHandler procedure} win { +} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} +test select-1.4.2 {Tk_CreateSelHandler procedure} -constraints win -setup { setup +} -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} lsort [selection get TARGETS] -} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} -test select-1.5 {Tk_CreateSelHandler procedure} { +} -result {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} +test select-1.5 {Tk_CreateSelHandler procedure} -setup { global selValue selInfo setup +} -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} set selValue "" set selInfo "" list [selection get] $selInfo -} {{} {STRING 0 4000}} -test select-1.6.1 {Tk_CreateSelHandler procedure} unix { +} -result {{} {STRING 0 4000}} +test select-1.6.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { global selValue selInfo setup +} -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} set selValue "" @@ -159,11 +166,12 @@ test select-1.6.1 {Tk_CreateSelHandler procedure} unix { selection get -type TEST selection handle .f1 {handler TEST2} TEST selection get -type TEST - list [set selInfo] [lsort [selection get TARGETS]] -} {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} -test select-1.6.2 {Tk_CreateSelHandler procedure} win { + list $selInfo [lsort [selection get TARGETS]] +} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} +test select-1.6.2 {Tk_CreateSelHandler procedure} -constraints win -setup { global selValue selInfo setup +} -body { selection handle .f1 {handler TEST} TEST selection handle .f1 {handler STRING} set selValue "" @@ -172,141 +180,157 @@ test select-1.6.2 {Tk_CreateSelHandler procedure} win { selection get -type TEST selection handle .f1 {handler TEST2} TEST selection get -type TEST - list [set selInfo] [lsort [selection get TARGETS]] -} {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-1.7.1 {Tk_CreateSelHandler procedure} unix { + list $selInfo [lsort [selection get TARGETS]] +} -result {{STRING 0 4000 TEST 0 4000 TEST2 0 4000} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-1.7.1 {Tk_CreateSelHandler procedure} -constraints unix -setup { setup +} -body { selection own -selection CLIPBOARD .f1 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST selection handle -selection PRIMARY .f1 {handler TEST2} STRING list [lsort [selection get -selection PRIMARY TARGETS]] \ [lsort [selection get -selection CLIPBOARD TARGETS]] -} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-1.7.2 {Tk_CreateSelHandler procedure} win { +} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-1.7.2 {Tk_CreateSelHandler procedure} -constraints win -setup { setup +} -body { selection own -selection CLIPBOARD .f1 selection handle -selection CLIPBOARD .f1 {handler TEST} TEST selection handle -selection PRIMARY .f1 {handler TEST2} STRING list [lsort [selection get -selection PRIMARY TARGETS]] \ [lsort [selection get -selection CLIPBOARD TARGETS]] -} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-1.8 {Tk_CreateSelHandler procedure} { +} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-1.8 {Tk_CreateSelHandler procedure} -setup { setup +} -body { selection handle -format INTEGER -type TEST .f1 {handler TEST} lsort [selection get TARGETS] -} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} +} -result {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} ############################################################################## -test select-2.1 {Tk_DeleteSelHandler procedure} unix { +test select-2.1 {Tk_DeleteSelHandler procedure} -constraints unix -setup { setup +} -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type TEST .f1 {} lappend result [lsort [selection get TARGETS]] -} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}} -test select-2.2 {Tk_DeleteSelHandler procedure} unix { +} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING}} +test select-2.2 {Tk_DeleteSelHandler procedure} -constraints unix -setup { setup +} -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type USER .f1 {} lappend result [lsort [selection get TARGETS]] -} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} -test select-2.3 {Tk_DeleteSelHandler procedure} unix { +} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER UTF8_STRING} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING}} +test select-2.3 {Tk_DeleteSelHandler procedure} -constraints unix -setup { setup +} -body { selection own -selection CLIPBOARD .f1 selection handle -selection PRIMARY .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {} list [lsort [selection get TARGETS]] \ [lsort [selection get -selection CLIPBOARD TARGETS]] -} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-2.4 {Tk_DeleteSelHandler procedure} win { +} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW UTF8_STRING} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-2.4 {Tk_DeleteSelHandler procedure} -constraints win -setup { setup +} -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type TEST .f1 {} lappend result [lsort [selection get TARGETS]] -} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}} -test select-2.5 {Tk_DeleteSelHandler procedure} win { +} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW USER}} +test select-2.5 {Tk_DeleteSelHandler procedure} -constraints win -setup { setup +} -body { selection handle .f1 {handler STRING} selection handle -type TEST .f1 {handler TEST} selection handle -type USER .f1 {handler USER} set result [list [lsort [selection get TARGETS]]] selection handle -type USER .f1 {} lappend result [lsort [selection get TARGETS]] -} {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-2.6 {Tk_DeleteSelHandler procedure} win { +} -result {{MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW USER} {MULTIPLE STRING TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-2.6 {Tk_DeleteSelHandler procedure} -constraints win -setup { setup +} -body { selection own -selection CLIPBOARD .f1 selection handle -selection PRIMARY .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {} list [lsort [selection get TARGETS]] \ [lsort [selection get -selection CLIPBOARD TARGETS]] -} {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-2.7 {Tk_DeleteSelHandler procedure} { +} -result {{MULTIPLE STRING TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-2.7 {Tk_DeleteSelHandler procedure} -setup { setup +} -body { selection handle .f1 {handler STRING} list [selection handle .f1 {}] [selection handle .f1 {}] -} {{} {}} +} -result {{} {}} ############################################################################## -test select-3.1 {Tk_OwnSelection procedure} { +test select-3.1 {Tk_OwnSelection procedure} -setup { setup +} -body { selection own -} {.f1} -test select-3.2 {Tk_OwnSelection procedure} { +} -result {.f1} +test select-3.2 {Tk_OwnSelection procedure} -body { setup .f1 set result [selection own] setup .f2 lappend result [selection own] -} {.f1 .f2} -test select-3.3 {Tk_OwnSelection procedure} { +} -result {.f1 .f2} +test select-3.3 {Tk_OwnSelection procedure} -setup { setup .f1 setup .f2 +} -body { selection own -selection CLIPBOARD .f1 list [selection own] [selection own -selection CLIPBOARD] -} {.f2 .f1} -test select-3.4 {Tk_OwnSelection procedure} { +} -result {.f2 .f1} +test select-3.4 {Tk_OwnSelection procedure} -setup { global lostSel setup +} -body { set lostSel {owned} selection own -command { set lostSel {lost} } .f1 selection clear .f1 set lostSel -} {lost} -test select-3.5 {Tk_OwnSelection procedure} { +} -result {lost} +test select-3.5 {Tk_OwnSelection procedure} -setup { global lostSel setup .f1 setup .f2 +} -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 selection own -command { set lostSel {lost2} } .f2 list $lostSel [selection own] -} {lost1 .f2} -test select-3.6 {Tk_OwnSelection procedure} { +} -result {lost1 .f2} +test select-3.6 {Tk_OwnSelection procedure} -setup { global lostSel setup +} -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 selection own -command { set lostSel {lost2} } .f1 set result $lostSel selection clear .f1 lappend result $lostSel -} {owned lost2} -test select-3.7 {Tk_OwnSelection procedure} unix { +} -result {owned lost2} +test select-3.7 {Tk_OwnSelection procedure} -constraints unix -setup { global lostSel setup setupbg +} -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 update @@ -316,60 +340,71 @@ test select-3.7 {Tk_OwnSelection procedure} unix { update cleanupbg lappend result $lostSel -} {{} . lost1} +} -result {{} . lost1} # check reentrancy on selection replacement -test select-3.8 {Tk_OwnSelection procedure} { +test select-3.8 {Tk_OwnSelection procedure} -setup { setup +} -body { selection own -selection CLIPBOARD -command { destroy .f1 } .f1 selection own -selection CLIPBOARD . -} {} -test select-3.9 {Tk_OwnSelection procedure} { +} -result {} +test select-3.9 {Tk_OwnSelection procedure} -setup { setup .f2 setup .f1 +} -body { selection own -selection CLIPBOARD -command { destroy .f2 } .f1 selection own -selection CLIPBOARD .f2 -} {} +} -result {} # multiple display tests -test select-3.10 {Tk_OwnSelection procedure} {altDisplay} { +test select-3.10 {Tk_OwnSelection procedure} -constraints { + altDisplay +} -body { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) list [selection own -displayof .f1] [selection own -displayof .f2] -} {.f1 .f2} -test select-3.11 {Tk_OwnSelection procedure} {altDisplay} { +} -result {.f1 .f2} +test select-3.11 {Tk_OwnSelection procedure} -constraints { + altDisplay +} -setup { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg update set result "" +} -body { lappend result [dobg "toplevel .t -screen $env(TK_ALT_DISPLAY); wm geom .t +0+0; selection own .t; update"] lappend result [selection own -displayof .f1] \ [selection own -displayof .f2] +} -cleanup { cleanupbg - set result -} {{} .f1 {}} +} -result {{} .f1 {}} ############################################################################## -test select-4.1 {Tk_ClearSelection procedure} { +test select-4.1 {Tk_ClearSelection procedure} -setup { setup +} -body { set result [selection own] selection clear .f1 lappend result [selection own] -} {.f1 {}} -test select-4.2 {Tk_ClearSelection procedure} { +} -result {.f1 {}} +test select-4.2 {Tk_ClearSelection procedure} -setup { setup +} -body { selection own -selection CLIPBOARD .f1 selection clear .f1 selection own -selection CLIPBOARD -} {.f1} -test select-4.3 {Tk_ClearSelection procedure} { +} -result {.f1} +test select-4.3 {Tk_ClearSelection procedure} -setup { setup +} -body { list [selection clear .f1] [selection clear .f1] -} {{} {}} -test select-4.4 {Tk_ClearSelection procedure} unix { +} -result {{} {}} +test select-4.4 {Tk_ClearSelection procedure} -constraints unix -setup { global lostSel setup setupbg +} -body { set lostSel {owned} selection own -command { set lostSel {lost1} } .f1 update @@ -378,12 +413,15 @@ test select-4.4 {Tk_ClearSelection procedure} unix { update cleanupbg lappend result [selection own] -} {{} {}} +} -result {{} {}} # multiple display tests -test select-4.5 {Tk_ClearSelection procedure} {altDisplay} { +test select-4.5 {Tk_ClearSelection procedure} -constraints { + altDisplay +} -setup { global lostSel lostSel2 setup .f1 setup .f2 $env(TK_ALT_DISPLAY) +} -body { set lostSel {owned} set lostSel2 {owned2} selection own -command { set lostSel {lost1} } .f1 @@ -392,11 +430,14 @@ test select-4.5 {Tk_ClearSelection procedure} {altDisplay} { selection clear -displayof .f2 update list $lostSel $lostSel2 -} {owned lost2} -test select-4.6 {Tk_ClearSelection procedure} {unix altDisplay} { +} -result {owned lost2} +test select-4.6 {Tk_ClearSelection procedure} -constraints { + unix altDisplay +} -setup { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg +} -body { set lostSel {owned} set lostSel2 {owned2} selection own -command { set lostSel {lost1} } .f1 @@ -408,73 +449,79 @@ test select-4.6 {Tk_ClearSelection procedure} {unix altDisplay} { [selection own -displayof .f2] $lostSel $lostSel2 cleanupbg set result -} {{} .f1 {} owned lost2} +} -result {{} .f1 {} owned lost2} ############################################################################## -test select-5.1 {Tk_GetSelection procedure} { +test select-5.1 {Tk_GetSelection procedure} -returnCodes error -setup { setup - list [catch {selection get TEST} msg] $msg -} {1 {PRIMARY selection doesn't exist or form "TEST" not defined}} -test select-5.2 {Tk_GetSelection procedure} { +} -body { + selection get TEST +} -result {PRIMARY selection doesn't exist or form "TEST" not defined} +test select-5.2 {Tk_GetSelection procedure} -setup { setup +} -body { selection get TK_WINDOW -} {.f1} -test select-5.3 {Tk_GetSelection procedure} { +} -result {.f1} +test select-5.3 {Tk_GetSelection procedure} -setup { setup +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST set selValue "Test value" set selInfo "" list [selection get TEST] $selInfo -} {{Test value} {TEST 0 4000}} -test select-5.4 {Tk_GetSelection procedure} { +} -result {{Test value} {TEST 0 4000}} +test select-5.4 {Tk_GetSelection procedure} -setup { setup +} -returnCodes error -body { selection handle .f1 ERROR errHandler - list [catch {selection get ERROR} msg] $msg -} {1 {PRIMARY selection doesn't exist or form "ERROR" not defined}} -test select-5.5 {Tk_GetSelection procedure} { + selection get ERROR +} -result {PRIMARY selection doesn't exist or form "ERROR" not defined} +test select-5.5 {Tk_GetSelection procedure} -setup { setup +} -body { set selValue $longValue set selInfo "" selection handle .f1 {handler STRING} list [selection get] $selInfo -} "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}" -test select-5.6 {Tk_GetSelection procedure} { - proc weirdHandler {type offset count} { - selection handle .f1 {} - handler $type $offset $count - } +} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000}" +test select-5.6 {Tk_GetSelection procedure} -setup { setup +} -returnCodes error -body { set selValue $longValue set selInfo "" - selection handle .f1 {weirdHandler STRING} - list [catch {selection get} msg] $msg -} {1 {PRIMARY selection doesn't exist or form "STRING" not defined}} -test select-5.7 {Tk_GetSelection procedure} { - proc weirdHandler {type offset count} { - destroy .f1 + selection handle .f1 {apply {{type offset count} { + selection handle .f1 {} handler $type $offset $count - } + }} STRING} + selection get +} -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test select-5.7 {Tk_GetSelection procedure} -setup { setup +} -returnCodes error -body { set selValue "Test Value" set selInfo "" - selection handle .f1 {weirdHandler STRING} - list [catch {selection get} msg] $msg -} {1 {PRIMARY selection doesn't exist or form "STRING" not defined}} -test select-5.8 {Tk_GetSelection procedure} { - proc weirdHandler {type offset count} { - selection clear + selection handle .f1 {apply {{type offset count} { + destroy .f1 handler $type $offset $count - } + }} STRING} + selection get +} -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test select-5.8 {Tk_GetSelection procedure} -setup { setup +} -body { set selValue $longValue set selInfo "" - selection handle .f1 {weirdHandler STRING} + selection handle .f1 {apply {{type offset count} { + selection clear + handler $type $offset $count + }} STRING} list [selection get] $selInfo [catch {selection get} msg] $msg -} "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}" -test select-5.9 {Tk_GetSelection procedure} unix { +} -result "$longValue {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000} 1 {PRIMARY selection doesn't exist or form \"STRING\" not defined}" +test select-5.9 {Tk_GetSelection procedure} -constraints unix -setup { setup setupbg +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST update set selValue "Test value" @@ -483,10 +530,11 @@ test select-5.9 {Tk_GetSelection procedure} unix { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{Test value} {TEST 0 4000}} -test select-5.10 {Tk_GetSelection procedure} unix { +} -result {{Test value} {TEST 0 4000}} +test select-5.10 {Tk_GetSelection procedure} -constraints unix -setup { setup setupbg +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST update set selValue "Test value" @@ -496,11 +544,14 @@ test select-5.10 {Tk_GetSelection procedure} unix { lappend result [dobg {selection get TEST} 1] cleanupbg lappend result $selInfo -} {{selection owner didn't respond} {}} +} -result {{selection owner didn't respond} {}} # multiple display tests -test select-5.11 {Tk_GetSelection procedure} {altDisplay} { +test select-5.11 {Tk_GetSelection procedure} -constraints { + altDisplay +} -setup { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection handle -selection PRIMARY .f2 {handler TEST2} TEST set selValue "Test value" @@ -509,11 +560,14 @@ test select-5.11 {Tk_GetSelection procedure} {altDisplay} { set selValue "Test value2" set selInfo "" lappend result [selection get -displayof .f2 TEST] $selInfo -} {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}} -test select-5.12 {Tk_GetSelection procedure} {altDisplay} { +} -result {{Test value} {TEST 0 4000} {Test value2} {TEST2 0 4000}} +test select-5.12 {Tk_GetSelection procedure} -constraints { + altDisplay +} -setup { global lostSel lostSel2 setup .f1 setup .f2 $env(TK_ALT_DISPLAY) +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection handle -selection PRIMARY .f2 {} TEST set selValue "Test value" @@ -523,11 +577,14 @@ test select-5.12 {Tk_GetSelection procedure} {altDisplay} { set selInfo "" lappend result [catch {selection get -displayof .f2 TEST} msg] $msg \ $selInfo -} {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}} -test select-5.13 {Tk_GetSelection procedure} {unix altDisplay} { +} -result {0 {Test value} {TEST 0 4000} 1 {PRIMARY selection doesn't exist or form "TEST" not defined} {}} +test select-5.13 {Tk_GetSelection procedure} -constraints { + unix altDisplay +} -setup { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection own .f1 selection handle -selection PRIMARY .f2 {handler TEST2} TEST @@ -541,11 +598,14 @@ test select-5.13 {Tk_GetSelection procedure} {unix altDisplay} { lappend result [dobg "selection get TEST"] cleanupbg lappend result $selInfo -} {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} -test select-5.14 {Tk_GetSelection procedure} {unix altDisplay} { +} -result {{Test value} {Test value2} {TEST2 0 4000 TEST 0 4000}} +test select-5.14 {Tk_GetSelection procedure} -constraints { + unix altDisplay +} -setup { setup .f1 setup .f2 $env(TK_ALT_DISPLAY) setupbg +} -body { selection handle -selection PRIMARY .f1 {handler TEST} TEST selection own .f1 selection handle -selection PRIMARY .f2 {} TEST @@ -559,215 +619,244 @@ test select-5.14 {Tk_GetSelection procedure} {unix altDisplay} { lappend result [dobg "selection get TEST"] cleanupbg lappend result $selInfo -} {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} +} -result {{PRIMARY selection doesn't exist or form "TEST" not defined} {Test value2} {TEST 0 4000}} +test select-5.15 {Tk_GetSelection procedure} -setup { + setup + if {[llength [info command ::bgerror]]} { + rename ::bgerror ::TMPbgerror + } + set ::bgerrors {} +} -body { + proc ::bgerror msg {lappend ::bgerrors $msg} + selection handle .f1 ERROR errHandler + list [catch {selection get ERROR} msg] $msg [update] {*}$::bgerrors +} -cleanup { + rename ::bgerror {} + if {[llength [info command ::TMPbgerror]]} { + rename ::TMPbgerror ::bgerror + } +} -result {1 {PRIMARY selection doesn't exist or form "ERROR" not defined} {} {selection handler aborted}} ############################################################################## -test select-6.1 {Tk_SelectionCmd procedure} { - list [catch {selection} cmd] $cmd -} {1 {wrong # args: should be "selection option ?arg arg ...?"}} +test select-6.1 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection +} -result {wrong # args: should be "selection option ?arg ...?"} # selection clear -test select-6.2 {Tk_SelectionCmd procedure} { - list [catch {selection clear -selection} cmd] $cmd -} {1 {value for "-selection" missing}} -test select-6.3 {Tk_SelectionCmd procedure} { +test select-6.2 {Tk_SelectionCmd procedure} -body { + selection clear -selection +} -returnCodes error -result {value for "-selection" missing} +test select-6.3 {Tk_SelectionCmd procedure} -setup { setup +} -body { selection own . set result [selection own] selection clear -displayof .f1 lappend result [selection own] -} {. {}} -test select-6.4 {Tk_SelectionCmd procedure} { +} -result {. {}} +test select-6.4 {Tk_SelectionCmd procedure} -setup { setup +} -body { selection own -selection CLIPBOARD .f1 set result [list [selection own] [selection own -selection CLIPBOARD]] selection clear -selection CLIPBOARD .f1 lappend result [selection own] [selection own -selection CLIPBOARD] -} {.f1 .f1 .f1 {}} -test select-6.5 {Tk_SelectionCmd procedure} { +} -result {.f1 .f1 .f1 {}} +test select-6.5 {Tk_SelectionCmd procedure} -setup { setup +} -body { selection own -selection CLIPBOARD . set result [list [selection own] [selection own -selection CLIPBOARD]] selection clear -selection CLIPBOARD -displayof .f1 lappend result [selection own] [selection own -selection CLIPBOARD] -} {.f1 . .f1 {}} -test select-6.6 {Tk_SelectionCmd procedure} { - list [catch {selection clear -badopt foo} cmd] $cmd -} {1 {bad option "-badopt": must be -displayof or -selection}} -test select-6.7 {Tk_SelectionCmd procedure} { - list [catch {selection clear -selectionfoo foo} cmd] $cmd -} {1 {bad option "-selectionfoo": must be -displayof or -selection}} -test select-6.8 {Tk_SelectionCmd procedure} { - catch {destroy .f2} - list [catch {selection clear -displayof .f2} cmd] $cmd -} {1 {bad window path name ".f2"}} -test select-6.9 {Tk_SelectionCmd procedure} { - catch {destroy .f2} - list [catch {selection clear .f2} cmd] $cmd -} {1 {bad window path name ".f2"}} -test select-6.10 {Tk_SelectionCmd procedure} { +} -result {.f1 . .f1 {}} +test select-6.6 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection clear -badopt foo +} -result {bad option "-badopt": must be -displayof or -selection} +test select-6.7 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection clear -selectionfoo foo +} -result {bad option "-selectionfoo": must be -displayof or -selection} +test select-6.8 {Tk_SelectionCmd procedure} -body { + destroy .f2 + selection clear -displayof .f2 +} -returnCodes error -result {bad window path name ".f2"} +test select-6.9 {Tk_SelectionCmd procedure} -body { + destroy .f2 + selection clear .f2 +} -returnCodes error -result {bad window path name ".f2"} +test select-6.10 {Tk_SelectionCmd procedure} -setup { setup +} -body { set result [selection own -selection PRIMARY] selection clear lappend result [selection own -selection PRIMARY] -} {.f1 {}} -test select-6.11 {Tk_SelectionCmd procedure} { +} -result {.f1 {}} +test select-6.11 {Tk_SelectionCmd procedure} -setup { setup +} -body { selection own -selection CLIPBOARD .f1 set result [selection own -selection CLIPBOARD] selection clear -selection CLIPBOARD lappend result [selection own -selection CLIPBOARD] -} {.f1 {}} -test select-6.12 {Tk_SelectionCmd procedure} { - list [catch {selection clear foo bar} cmd] $cmd -} {1 {wrong # args: should be "selection clear ?options?"}} +} -result {.f1 {}} +test select-6.12 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection clear foo bar +} -result {wrong # args: should be "selection clear ?-option value ...?"} # selection get -test select-6.13 {Tk_SelectionCmd procedure} { - list [catch {selection get -selection} cmd] $cmd -} {1 {value for "-selection" missing}} -test select-6.14 {Tk_SelectionCmd procedure} { +test select-6.13 {Tk_SelectionCmd procedure} -body { + selection get -selection +} -returnCodes error -result {value for "-selection" missing} +test select-6.14 {Tk_SelectionCmd procedure} -setup { global selValue selInfo setup +} -body { selection handle .f1 {handler TEST} set selValue "Test value" set selInfo "" list [selection get -displayof .f1] $selInfo -} {{Test value} {TEST 0 4000}} -test select-6.15 {Tk_SelectionCmd procedure} { +} -result {{Test value} {TEST 0 4000}} +test select-6.15 {Tk_SelectionCmd procedure} -setup { global selValue selInfo setup +} -body { selection handle .f1 {handler STRING} selection handle -selection CLIPBOARD .f1 {handler TEST} selection own -selection CLIPBOARD .f1 set selValue "Test value" set selInfo "" list [selection get -selection CLIPBOARD] $selInfo -} {{Test value} {TEST 0 4000}} -test select-6.16 {Tk_SelectionCmd procedure} { +} -result {{Test value} {TEST 0 4000}} +test select-6.16 {Tk_SelectionCmd procedure} -setup { global selValue selInfo setup +} -body { selection handle -type TEST .f1 {handler TEST} selection handle -type STRING .f1 {handler STRING} set selValue "Test value" set selInfo "" list [selection get -type TEST] $selInfo -} {{Test value} {TEST 0 4000}} -test select-6.17 {Tk_SelectionCmd procedure} { - list [catch {selection get -badopt foo} cmd] $cmd -} {1 {bad option "-badopt": must be -displayof, -selection, or -type}} -test select-6.18 {Tk_SelectionCmd procedure} { - list [catch {selection get -selectionfoo foo} cmd] $cmd -} {1 {bad option "-selectionfoo": must be -displayof, -selection, or -type}} -test select-6.19 {Tk_SelectionCmd procedure} { +} -result {{Test value} {TEST 0 4000}} +test select-6.17 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection get -badopt foo +} -result {bad option "-badopt": must be -displayof, -selection, or -type} +test select-6.18 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection get -selectionfoo foo +} -result {bad option "-selectionfoo": must be -displayof, -selection, or -type} +test select-6.19 {Tk_SelectionCmd procedure} -body { catch { destroy .f2 } - list [catch {selection get -displayof .f2} cmd] $cmd -} {1 {bad window path name ".f2"}} -test select-6.20 {Tk_SelectionCmd procedure} { - list [catch {selection get foo bar} cmd] $cmd -} {1 {wrong # args: should be "selection get ?options?"}} -test select-6.21 {Tk_SelectionCmd procedure} { + selection get -displayof .f2 +} -returnCodes error -result {bad window path name ".f2"} +test select-6.20 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection get foo bar +} -result {wrong # args: should be "selection get ?-option value ...?"} +test select-6.21 {Tk_SelectionCmd procedure} -setup { global selValue selInfo setup +} -body { selection handle -type TEST .f1 {handler TEST} selection handle -type STRING .f1 {handler STRING} set selValue "Test value" set selInfo "" list [selection get TEST] $selInfo -} {{Test value} {TEST 0 4000}} +} -result {{Test value} {TEST 0 4000}} # selection handle # most of the handle section has been covered earlier -test select-6.22 {Tk_SelectionCmd procedure} { - list [catch {selection handle -selection} cmd] $cmd -} {1 {value for "-selection" missing}} -test select-6.23 {Tk_SelectionCmd procedure} { +test select-6.22 {Tk_SelectionCmd procedure} -body { + selection handle -selection +} -returnCodes error -result {value for "-selection" missing} +test select-6.23 {Tk_SelectionCmd procedure} -setup { global selValue selInfo setup +} -body { set selValue "Test value" set selInfo "" list [selection handle -format INTEGER .f1 {handler TEST}] [selection get -displayof .f1] $selInfo -} {{} {Test value} {TEST 0 4000}} -test select-6.24 {Tk_SelectionCmd procedure} { - list [catch {selection handle -badopt foo} cmd] $cmd -} {1 {bad option "-badopt": must be -format, -selection, or -type}} -test select-6.25 {Tk_SelectionCmd procedure} { - list [catch {selection handle -selectionfoo foo} cmd] $cmd -} {1 {bad option "-selectionfoo": must be -format, -selection, or -type}} -test select-6.26 {Tk_SelectionCmd procedure} { - list [catch {selection handle} cmd] $cmd -} {1 {wrong # args: should be "selection handle ?options? window command"}} -test select-6.27 {Tk_SelectionCmd procedure} { - list [catch {selection handle .} cmd] $cmd -} {1 {wrong # args: should be "selection handle ?options? window command"}} -test select-6.28 {Tk_SelectionCmd procedure} { - list [catch {selection handle . foo bar baz blat} cmd] $cmd -} {1 {wrong # args: should be "selection handle ?options? window command"}} -test select-6.29 {Tk_SelectionCmd procedure} { +} -result {{} {Test value} {TEST 0 4000}} +test select-6.24 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection handle -badopt foo +} -result {bad option "-badopt": must be -format, -selection, or -type} +test select-6.25 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection handle -selectionfoo foo +} -result {bad option "-selectionfoo": must be -format, -selection, or -type} +test select-6.26 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection handle +} -result {wrong # args: should be "selection handle ?-option value ...? window command"} +test select-6.27 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection handle . +} -result {wrong # args: should be "selection handle ?-option value ...? window command"} +test select-6.28 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection handle . foo bar baz blat +} -result {wrong # args: should be "selection handle ?-option value ...? window command"} +test select-6.29 {Tk_SelectionCmd procedure} -body { catch { destroy .f2 } - list [catch {selection handle .f2 dummy} cmd] $cmd -} {1 {bad window path name ".f2"}} + selection handle .f2 dummy +} -returnCodes error -result {bad window path name ".f2"} # selection own -test select-6.30 {Tk_SelectionCmd procedure} { - list [catch {selection own -selection} cmd] $cmd -} {1 {value for "-selection" missing}} -test select-6.31 {Tk_SelectionCmd procedure} { +test select-6.30 {Tk_SelectionCmd procedure} -body { + selection own -selection +} -returnCodes error -result {value for "-selection" missing} +test select-6.31 {Tk_SelectionCmd procedure} -setup { setup +} -body { selection own . selection own -displayof .f1 -} {.} -test select-6.32 {Tk_SelectionCmd procedure} { +} -result {.} +test select-6.32 {Tk_SelectionCmd procedure} -setup { setup +} -body { selection own . selection own -selection CLIPBOARD .f1 list [selection own] [selection own -selection CLIPBOARD] -} {. .f1} -test select-6.33 {Tk_SelectionCmd procedure} { +} -result {. .f1} +test select-6.33 {Tk_SelectionCmd procedure} -setup { global lostSel setup +} -body { set lostSel owned selection own -command { set lostSel lost } . selection own -selection CLIPBOARD .f1 set result $lostSel selection own .f1 lappend result $lostSel -} {owned lost} -test select-6.34 {Tk_SelectionCmd procedure} { - list [catch {selection own -badopt foo} cmd] $cmd -} {1 {bad option "-badopt": must be -command, -displayof, or -selection}} -test select-6.35 {Tk_SelectionCmd procedure} { - list [catch {selection own -selectionfoo foo} cmd] $cmd -} {1 {bad option "-selectionfoo": must be -command, -displayof, or -selection}} -test select-6.36 {Tk_SelectionCmd procedure} { - catch {destroy .f2} - list [catch {selection own -displayof .f2} cmd] $cmd -} {1 {bad window path name ".f2"}} -test select-6.37 {Tk_SelectionCmd procedure} { - catch {destroy .f2} - list [catch {selection own .f2} cmd] $cmd -} {1 {bad window path name ".f2"}} -test select-6.38 {Tk_SelectionCmd procedure} { - list [catch {selection own foo bar baz} cmd] $cmd -} {1 {wrong # args: should be "selection own ?options? ?window?"}} -test select-6.39 {Tk_SelectionCmd procedure} { - list [catch {selection foo} cmd] $cmd -} {1 {bad option "foo": must be clear, get, handle, or own}} +} -result {owned lost} +test select-6.34 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection own -badopt foo +} -result {bad option "-badopt": must be -command, -displayof, or -selection} +test select-6.35 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection own -selectionfoo foo +} -result {bad option "-selectionfoo": must be -command, -displayof, or -selection} +test select-6.36 {Tk_SelectionCmd procedure} -body { + destroy .f2 + selection own -displayof .f2 +} -returnCodes error -result {bad window path name ".f2"} +test select-6.37 {Tk_SelectionCmd procedure} -body { + destroy .f2 + selection own .f2 +} -returnCodes error -result {bad window path name ".f2"} +test select-6.38 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection own foo bar baz +} -result {wrong # args: should be "selection own ?-option value ...? ?window?"} +test select-6.39 {Tk_SelectionCmd procedure} -returnCodes error -body { + selection foo +} -result {bad option "foo": must be clear, get, handle, or own} ############################################################################## -# This test is non-portable because some old X11/News servers ignore -# a selection request when the window doesn't exist, which causes a -# different error message. -test select-7.1 {TkSelDeadWindow procedure} nonPortable { +# This test is non-portable because some old X11/News servers ignore a +# selection request when the window doesn't exist, which causes a different +# error message. +test select-7.1 {TkSelDeadWindow procedure} -constraints nonPortable -setup { setup +} -body { selection handle .f1 { handler TEST } set result [selection own] destroy .f1 lappend result [selection own] [catch {selection get} msg] $msg -} {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}} +} -result {.f1 {} 1 {PRIMARY selection doesn't exist or form "STRING" not defined}} ############################################################################## # Check reentrancy on losing selection - test select-8.1 {TkSelEventProc procedure} -constraints unix -setup { setup setupbg @@ -788,16 +877,17 @@ test select-9.1 {SelCvtToX and SelCvtFromX procedures} -setup { set selValue "1024" set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ - .f1 {handler TEST} + .f1 {handler TEST} update set result "" lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo } -result {{0x400 } {TEST 0 4000}} -test select-9.2 {SelCvtToX and SelCvtFromX procedures} unix { +test select-9.2 {SelCvtToX and SelCvtFromX procedures} -setup { setup setupbg +} -constraints unix -body { set selValue "1024 0xffff 2048 -2 " set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ @@ -806,10 +896,11 @@ test select-9.2 {SelCvtToX and SelCvtFromX procedures} unix { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}} -test select-9.3 {SelCvtToX and SelCvtFromX procedures} unix { +} -result {{0x400 0xffff 0x800 0xfffffffe } {TEST 0 4000}} +test select-9.3 {SelCvtToX and SelCvtFromX procedures} -setup { setup setupbg +} -constraints unix -body { set selValue " " set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ @@ -818,10 +909,11 @@ test select-9.3 {SelCvtToX and SelCvtFromX procedures} unix { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{ } {TEST 0 4000}} -test select-9.4 {SelCvtToX and SelCvtFromX procedures} unix { +} -result {{ } {TEST 0 4000}} +test select-9.4 {SelCvtToX and SelCvtFromX procedures} -setup { setup setupbg +} -constraints unix -body { set selValue "16 foobar 32" set selInfo "" selection handle -selection PRIMARY -format INTEGER -type TEST \ @@ -830,7 +922,7 @@ test select-9.4 {SelCvtToX and SelCvtFromX procedures} unix { lappend result [dobg {selection get TEST}] cleanupbg lappend result $selInfo -} {{0x10 0x0 0x20 } {TEST 0 4000}} +} -result {{0x10 0x0 0x20 } {TEST 0 4000}} test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { setup setupbg @@ -841,19 +933,21 @@ test select-9.5 {SelCvtToX and SelCvtFromX procedures} -setup { set selInfo "" set selType {text/x-tk-test;detail="foo bar"} selection handle -selection PRIMARY -format STRING -type $selType \ - .f1 [list handler $selType] + .f1 [list handler $selType] lsort [dobg {selection get TARGETS}] } -cleanup { cleanupbg } -result {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW {text/x-tk-test;detail="foo bar"}} ############################################################################## - # note, we are not testing MULTIPLE style selections # most control paths have been exercised above -test select-10.1 {ConvertSelection procedure, race with selection clear} unix { +test select-10.1 {ConvertSelection procedure, race with selection clear} -constraints { + unix +} -setup { setup +} -body { proc Ready {fd} { variable x lappend x [gets $fd] @@ -867,7 +961,7 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} unix { set selInfo "" selection handle .f1 {handler STRING} update - puts $fd {puts "[catch {selection get} msg] $msg"; puts **DONE**; flush stdout} + puts $fd {puts "[catch {selection get} msg]:$msg"; puts **DONE**; flush stdout} flush $fd after 200 selection own . @@ -879,10 +973,11 @@ test select-10.1 {ConvertSelection procedure, race with selection clear} unix { # a "broken pipe" error when Tk was actually [load]ed in the child. catch {close $fd} lappend x $selInfo -} {{1 PRIMARY selection doesn't exist or form "STRING" not defined} {}} -test select-10.2 {ConvertSelection procedure} unix { +} -result {{1:PRIMARY selection doesn't exist or form "STRING" not defined} {}} +test select-10.2 {ConvertSelection procedure} -constraints unix -setup { setup setupbg +} -body { set selValue [string range $longValue 0 3999] set selInfo "" selection handle .f1 {handler STRING} @@ -890,21 +985,24 @@ test select-10.2 {ConvertSelection procedure} unix { lappend result [dobg {selection get}] cleanupbg lappend result $selInfo -} [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}] -test select-10.3 {ConvertSelection procedure} unix { +} -result [list [string range $longValue 0 3999] {STRING 0 4000 STRING 4000 4000 STRING 0 4000 STRING 4000 4000}] +test select-10.3 {ConvertSelection procedure} -constraints unix -setup { setup setupbg +} -body { selection handle .f1 ERROR errHandler - set result "" - lappend result [dobg {selection get ERROR}] + dobg {selection get ERROR} +} -cleanup { cleanupbg - set result -} {{PRIMARY selection doesn't exist or form "ERROR" not defined}} +} -result {PRIMARY selection doesn't exist or form "ERROR" not defined} # testing timers # This one hangs in Exceed -test select-10.4 {ConvertSelection procedure} {unix noExceed} { +test select-10.4 {ConvertSelection procedure} -constraints { + unix noExceed +} -setup { setup setupbg +} -body { set selValue $longValue set selInfo "" selection handle .f1 {errIncrHandler STRING} @@ -913,10 +1011,13 @@ test select-10.4 {ConvertSelection procedure} {unix noExceed} { lappend result [dobg {selection get}] cleanupbg lappend result $selInfo -} {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}} -test select-10.5 {ConvertSelection procedure, reentrancy issues} unix { +} -result {{selection owner didn't respond} {STRING 0 4000 STRING 4000 4000 STRING 8000 4000 STRING 12000 4000 STRING 16000 4000 STRING 0 4000 STRING 4000 4000}} +test select-10.5 {ConvertSelection procedure, reentrancy issues} -constraints { + unix +} -setup { setup setupbg +} -body { set selValue "Test value" set selInfo "" selection handle -type TEST .f1 { handler TEST } @@ -925,14 +1026,17 @@ test select-10.5 {ConvertSelection procedure, reentrancy issues} unix { lappend result [dobg {selection get}] cleanupbg lappend result $selInfo -} {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}} -test select-10.6 {ConvertSelection procedure, reentrancy issues} unix { +} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000}} +test select-10.6 {ConvertSelection procedure, reentrancy issues} -constraints { + unix +} -setup { + setup + setupbg +} -body { proc weirdHandler {type offset count} { destroy .f1 handler $type $offset $count } - setup - setupbg set selValue $longValue set selInfo "" selection handle .f1 {weirdHandler STRING} @@ -940,14 +1044,15 @@ test select-10.6 {ConvertSelection procedure, reentrancy issues} unix { lappend result [dobg {selection get}] cleanupbg lappend result $selInfo -} {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}} +} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {STRING 0 4000}} ############################################################################## # testing reentrancy -test select-11.1 {TkSelPropProc procedure} unix { +test select-11.1 {TkSelPropProc procedure} -constraints unix -setup { setup setupbg +} -body { set selValue $longValue set selInfo "" selection handle -type TEST .f1 { handler TEST } @@ -957,28 +1062,28 @@ test select-11.1 {TkSelPropProc procedure} unix { lappend result [dobg {selection get}] cleanupbg lappend result $selInfo -} {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}} +} -result {{selection owner didn't respond} {.f1 STRING 0 4000 .f1 STRING 4000 4000 .f1 STRING 8000 4000 .f1 STRING 12000 4000 .f1 STRING 16000 4000 .f1 STRING 0 4000 .f1 STRING 4000 4000}} ############################################################################## # Note, this assumes we are using CurrentTtime -test select-12.1 {DefaultSelection procedure} unix { +test select-12.1 {DefaultSelection procedure} -constraints unix -body { setup set result [selection get -type TIMESTAMP] setupbg lappend result [dobg {selection get -type TIMESTAMP}] cleanupbg set result -} {0x0 {0x0 }} -test select-12.2 {DefaultSelection procedure} unix { +} -result {0x0 {0x0 }} +test select-12.2 {DefaultSelection procedure} -constraints unix -body { setup set result [lsort [list [selection get -type TARGETS]]] setupbg lappend result [dobg {lsort [selection get -type TARGETS]}] cleanupbg set result -} {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-12.3 {DefaultSelection procedure} unix { +} -result {{MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-12.3 {DefaultSelection procedure} -constraints unix -body { setup selection handle .f1 {handler TEST} TEST set result [list [lsort [selection get -type TARGETS]]] @@ -986,25 +1091,26 @@ test select-12.3 {DefaultSelection procedure} unix { lappend result [dobg {lsort [selection get -type TARGETS]}] cleanupbg set result -} {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-12.4 {DefaultSelection procedure} unix { +} -result {{MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW} {MULTIPLE TARGETS TEST TIMESTAMP TK_APPLICATION TK_WINDOW}} +test select-12.4 {DefaultSelection procedure} -constraints unix -setup { setup set result "" +} -body { lappend result [selection get -type TK_APPLICATION] setupbg lappend result [dobg {selection get -type TK_APPLICATION}] cleanupbg set result -} [list [winfo name .] [winfo name .]] -test select-12.5 {DefaultSelection procedure} unix { +} -result [list [winfo name .] [winfo name .]] +test select-12.5 {DefaultSelection procedure} -constraints unix -body { setup set result [selection get -type TK_WINDOW] setupbg lappend result [dobg {selection get -type TK_WINDOW}] cleanupbg set result -} {.f1 .f1} -test select-12.6 {DefaultSelection procedure} { +} -result {.f1 .f1} +test select-12.6 {DefaultSelection procedure} -body { setup selection handle .f1 {handler TARGETS.f1} TARGETS set selValue "Targets value" @@ -1012,9 +1118,14 @@ test select-12.6 {DefaultSelection procedure} { set result [list [selection get TARGETS] $selInfo] selection handle .f1 {} TARGETS lappend result [selection get TARGETS] -} {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} +} -result {{Targets value} {TARGETS.f1 0 4000} {MULTIPLE TARGETS TIMESTAMP TK_APPLICATION TK_WINDOW}} -test select-13.1 {SelectionSize procedure, handler deleted} unix { +test select-13.1 {SelectionSize procedure, handler deleted} -constraints { + unix +} -setup { + setup + setupbg +} -body { proc badHandler {path type offset count} { global selValue selInfo abortCount incr abortCount -1 @@ -1028,8 +1139,6 @@ test select-13.1 {SelectionSize procedure, handler deleted} unix { } string range $selValue $offset [expr $numBytes+$offset] } - setup - setupbg set selValue $longValue set selInfo "" selection handle .f1 {badHandler .f1 STRING} @@ -1038,10 +1147,14 @@ test select-13.1 {SelectionSize procedure, handler deleted} unix { lappend result [dobg {selection get}] cleanupbg lappend result $selInfo -} {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}} - +} -result {{PRIMARY selection doesn't exist or form "STRING" not defined} {.f1 STRING 0 4000 .f1 STRING 4000 4000}} + catch {rename weirdHandler {}} # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/send.test b/tests/send.test index d3fce3b..e3156a1 100644 --- a/tests/send.test +++ b/tests/send.test @@ -230,10 +230,10 @@ test send-8.4 {Tk_SendCmd procedure, options} {secureserver} { } {1 {bad option "-gorp": must be -async, -displayof, or --}} test send-8.5 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -async foo} msg] $msg -} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}} test send-8.6 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send foo} msg] $msg -} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}} test send-8.7 {Tk_SendCmd procedure, local execution} {secureserver} { set a initial send [tk appname] {set a new} diff --git a/tests/spinbox.test b/tests/spinbox.test index 0fe1c33..b8170c5 100644 --- a/tests/spinbox.test +++ b/tests/spinbox.test @@ -1,238 +1,1240 @@ # This file is a Tcl script to test spinbox widgets in Tk. It is # organized in the standard fashion for Tcl tests. # -# Copyright (c) 1998-2000 by Scriptics Corporation. +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +# For xscrollcommand proc scroll args { - global scrollInfo - set scrollInfo $args + global scrollInfo + set scrollInfo $args +} +# For trace variable +proc override args { + global x + set x 12345 } -# Create additional widget that's used to hold the selection at times. - -spinbox .sel -.sel insert end "This is some sample text" - -# Font names - -set big -adobe-helvetica-medium-r-normal--24-240-75-75-p-*-iso8859-1 -set fixed -adobe-courier-medium-r-normal--12-120-75-75-m-*-iso8859-1 - -# Create entries in the option database to be sure that geometry options -# like border width have predictable values. - -option add *Spinbox.borderWidth 2 -option add *Spinbox.highlightThickness 2 -option add *Spinbox.font {Helvetica -12} - -spinbox .e -bd 2 -relief sunken -pack .e -update - -set i 1 -foreach test { - {-activebackground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-background #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-bd 4 4 badValue {bad screen distance "badValue"}} - {-bg #ff0000 #ff0000 non-existent {unknown color name "non-existent"}} - {-borderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-buttonbackground #ff0000 #ff0000 non-existent - {unknown color name "non-existent"}} - {-buttoncursor arrow arrow badValue {bad cursor spec "badValue"}} - {-command {a command} {a command} {} {}} - {-cursor arrow arrow badValue {bad cursor spec "badValue"}} - {-disabledbackground green green non-existent - {unknown color name "non-existent"}} - {-disabledforeground #110022 #110022 bogus {unknown color name "bogus"}} - {-exportselection yes 1 xyzzy {expected boolean value but got "xyzzy"}} - {-fg #110022 #110022 bogus {unknown color name "bogus"}} - {-font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* - -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* {} - {font "" doesn't exist}} - {-foreground #110022 #110022 bogus {unknown color name "bogus"}} - {-format %0.5f %0.5f %d {bad spinbox format specifier "%d"}} - {-from -10 -10.0 bogus {expected floating-point number but got "bogus"}} - {-highlightbackground #123456 #123456 ugly {unknown color name "ugly"}} - {-highlightcolor #123456 #123456 bogus {unknown color name "bogus"}} - {-highlightthickness 6 6 bogus {bad screen distance "bogus"}} - {-highlightthickness -2 0 {} {}} - {-increment 1.0 1.0 bogus {expected floating-point number but got "bogus"}} - {-insertbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-insertborderwidth 1.3 1 2.6x {bad screen distance "2.6x"}} - {-insertofftime 100 100 3.2 {expected integer but got "3.2"}} - {-insertontime 100 100 3.2 {expected integer but got "3.2"}} - {-invalidcommand "a command" "a command" {} {}} - {-invcmd "a command" "a command" {} {}} - {-justify right right bogus {bad justification "bogus": must be left, right, or center}} - {-readonlybackground green green non-existent - {unknown color name "non-existent"}} - {-relief groove groove 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - {-repeatdelay 500 500 3p {expected integer but got "3p"}} - {-repeatinterval -500 -500 3p {expected integer but got "3p"}} - {-selectbackground #110022 #110022 bogus {unknown color name "bogus"}} - {-selectborderwidth 1.3 1 badValue {bad screen distance "badValue"}} - {-selectforeground #654321 #654321 bogus {unknown color name "bogus"}} - {-state n normal bogus {bad state "bogus": must be disabled, normal, or readonly}} - {-takefocus "any string" "any string" {} {}} - {-textvariable i i {} {}} - {-to 14.9 14.9 bogus {expected floating-point number but got "bogus"}} - {-validate "key" "key" "bogus" {bad validate "bogus": must be all, key, focus, focusin, focusout, or none}} - {-validatecommand "a command" "a command" {} {}} - {-values {mon tue wed thur} {mon tue wed thur} {bad {}list} {list element in braces followed by "list" instead of space}} - {-vcmd "a command" "a command" {} {}} - {-width 402 402 3p {expected integer but got "3p"}} - {-wrap yes 1 xyzzy {expected boolean value but got "xyzzy"}} - {-xscrollcommand {Some command} {Some command} {} {}} -} { - set name [lindex $test 0] - test spinbox-1.$i {configuration options} { - .e configure $name [lindex $test 1] - list [lindex [.e configure $name] 4] [.e cget $name] - } [list [lindex $test 2] [lindex $test 2]] - incr i - if {[lindex $test 3] != ""} { - test spinbox-1.$i {configuration options} { - list [catch {.e configure $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .e configure $name [lindex [.e configure $name] 3] - incr i +# Procedures used in widget VALIDATION tests +proc doval {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 1 +} +proc doval2 {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + set ::e mydata + return 1 +} +proc doval3 {W d i P s S v V} { + set ::vVals [list $W $d $i $P $s $S $v $V] + return 0 } -test spinbox-2.1 {Tk_SpinboxCmd procedure} { - list [catch {spinbox} msg] $msg -} {1 {wrong # args: should be "spinbox pathName ?options?"}} -test spinbox-2.2 {Tk_SpinboxCmd procedure} { - list [catch {spinbox gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test spinbox-2.3 {Tk_SpinboxCmd procedure} { - catch {destroy .e} +set cy [font metrics {Courier -12} -linespace] + +test spinbox-1.1 {configuration option: "activebackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -activebackground #ff0000 + .e cget -activebackground +} -cleanup { + destroy .e +} -result {#ff0000} +test spinbox-1.2 {configuration option: "activebackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -activebackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test spinbox-1.3 {configuration option: "background"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -background #ff0000 + .e cget -background +} -cleanup { + destroy .e +} -result {#ff0000} +test spinbox-1.4 {configuration option: "background" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -background non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test spinbox-1.5 {configuration option: "bd"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -bd 4 + .e cget -bd +} -cleanup { + destroy .e +} -result {4} +test spinbox-1.6 {configuration option: "bd" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -bd badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test spinbox-1.7 {configuration option: "bg"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -bg #ff0000 + .e cget -bg +} -cleanup { + destroy .e +} -result {#ff0000} +test spinbox-1.8 {configuration option: "bg" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -bg non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test spinbox-1.9 {configuration option: "borderwidth"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -borderwidth 1.3 + .e cget -borderwidth +} -cleanup { + destroy .e +} -result {1} +test spinbox-1.10 {configuration option: "borderwidth" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -borderwidth badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test spinbox-1.11 {configuration option: "buttonbackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -buttonbackground #ff0000 + .e cget -buttonbackground +} -cleanup { + destroy .e +} -result {#ff0000} +test spinbox-1.12 {configuration option: "buttonbackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -buttonbackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test spinbox-1.13 {configuration option: "buttoncursor"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -buttoncursor arrow + .e cget -buttoncursor +} -cleanup { + destroy .e +} -result {arrow} +test spinbox-1.14 {configuration option: "buttoncursor" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -buttoncursor badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad cursor spec "badValue"} + +test spinbox-1.15 {configuration option: "command"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -command {a command} + .e cget -command +} -cleanup { + destroy .e +} -result {a command} + +test spinbox-1.16 {configuration option: "cursor"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -cursor arrow + .e cget -cursor +} -cleanup { + destroy .e +} -result {arrow} +test spinbox-1.17 {configuration option: "cursor" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -cursor badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad cursor spec "badValue"} + +test spinbox-1.18 {configuration option: "disabledbackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -disabledbackground green + .e cget -disabledbackground +} -cleanup { + destroy .e +} -result {green} +test spinbox-1.19 {configuration option: "disabledbackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -disabledbackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test spinbox-1.20 {configuration option: "disabledforeground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -disabledforeground #110022 + .e cget -disabledforeground +} -cleanup { + destroy .e +} -result {#110022} +test spinbox-1.21 {configuration option: "disabledforeground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -disabledforeground bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.22 {configuration option: "exportselection"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -exportselection yes + .e cget -exportselection +} -cleanup { + destroy .e +} -result {1} +test spinbox-1.23 {configuration option: "exportselection" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -exportselection xyzzy +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected boolean value but got "xyzzy"} + +test spinbox-1.24 {configuration option: "fg"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -fg #110022 + .e cget -fg +} -cleanup { + destroy .e +} -result {#110022} +test spinbox-1.25 {configuration option: "fg" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -fg bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.26 {configuration option: "font"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -font -Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-* + .e cget -font +} -cleanup { + destroy .e +} -result {-Adobe-Helvetica-Medium-R-Normal--*-120-*-*-*-*-*-*} +test spinbox-1.27 {configuration option: "font" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -font {} +} -cleanup { + destroy .e +} -returnCodes {error} -result {font "" doesn't exist} + +test spinbox-1.28 {configuration option: "foreground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -foreground #110022 + .e cget -foreground +} -cleanup { + destroy .e +} -result {#110022} +test spinbox-1.29 {configuration option: "foreground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -foreground bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.30 {configuration option: "format"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -format %0.5f + .e cget -format +} -cleanup { + destroy .e +} -result {%0.5f} +test spinbox-1.31 {configuration option: "format" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -format %d +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad spinbox format specifier "%d"} + +test spinbox-1.32 {configuration option: "from"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -from -10 + .e cget -from +} -cleanup { + destroy .e +} -result {-10.0} +test spinbox-1.33 {configuration option: "from" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -from bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected floating-point number but got "bogus"} + +test spinbox-1.34 {configuration option: "highlightbackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightbackground #123456 + .e cget -highlightbackground +} -cleanup { + destroy .e +} -result {#123456} +test spinbox-1.35 {configuration option: "highlightbackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightbackground ugly +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "ugly"} + +test spinbox-1.36 {configuration option: "highlightcolor"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightcolor #123456 + .e cget -highlightcolor +} -cleanup { + destroy .e +} -result {#123456} +test spinbox-1.37 {configuration option: "highlightcolor" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightcolor bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.38 {configuration option: "highlightthickness"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightthickness 6 + .e cget -highlightthickness +} -cleanup { + destroy .e +} -result {6} +test spinbox-1.39 {configuration option: "highlightthickness" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightthickness bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "bogus"} + +test spinbox-1.40 {configuration option: "highlightthickness"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -highlightthickness -2 + .e cget -highlightthickness +} -cleanup { + destroy .e +} -result {0} + +test spinbox-1.41 {configuration option: "increment"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -increment 1.0 + .e cget -increment +} -cleanup { + destroy .e +} -result {1.0} +test spinbox-1.42 {configuration option: "increment" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -increment bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected floating-point number but got "bogus"} + +test spinbox-1.43 {configuration option: "insertbackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertbackground #110022 + .e cget -insertbackground +} -cleanup { + destroy .e +} -result {#110022} +test spinbox-1.44 {configuration option: "insertbackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertbackground bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.45 {configuration option: "insertborderwidth"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertborderwidth 1.3 + .e cget -insertborderwidth +} -cleanup { + destroy .e +} -result {1} +test spinbox-1.46 {configuration option: "insertborderwidth" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertborderwidth 2.6x +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "2.6x"} + +test spinbox-1.47 {configuration option: "insertofftime"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertofftime 100 + .e cget -insertofftime +} -cleanup { + destroy .e +} -result {100} +test spinbox-1.48 {configuration option: "insertofftime" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertofftime 3.2 +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3.2"} + +test spinbox-1.49 {configuration option: "insertontime"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertontime 100 + .e cget -insertontime +} -cleanup { + destroy .e +} -result {100} +test spinbox-1.50 {configuration option: "insertontime" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -insertontime 3.2 +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3.2"} + +test spinbox-1.51 {configuration option: "invalidcommand"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -invalidcommand "a command" + .e cget -invalidcommand +} -cleanup { + destroy .e +} -result {a command} + +test spinbox-1.52 {configuration option: "invcmd"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -invcmd "a command" + .e cget -invcmd +} -cleanup { + destroy .e +} -result {a command} + +test spinbox-1.53 {configuration option: "justify"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -justify right + .e cget -justify +} -cleanup { + destroy .e +} -result {right} +test spinbox-1.54 {configuration option: "justify" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -justify bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad justification "bogus": must be left, right, or center} + +test spinbox-1.55 {configuration option: "readonlybackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -readonlybackground green + .e cget -readonlybackground +} -cleanup { + destroy .e +} -result {green} +test spinbox-1.56 {configuration option: "readonlybackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -readonlybackground non-existent +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "non-existent"} + +test spinbox-1.57 {configuration option: "relief"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -relief groove + .e cget -relief +} -cleanup { + destroy .e +} -result {groove} +test spinbox-1.58 {configuration option: "relief" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -relief 1.5 +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} + +test spinbox-1.59 {configuration option: "repeatdelay"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -repeatdelay 500 + .e cget -repeatdelay +} -cleanup { + destroy .e +} -result {500} +test spinbox-1.60 {configuration option: "repeatdelay" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -repeatdelay 3p +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3p"} + +test spinbox-1.61 {configuration option: "repeatinterval"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -repeatinterval -500 + .e cget -repeatinterval +} -cleanup { + destroy .e +} -result {-500} +test spinbox-1.62 {configuration option: "repeatinterval" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -repeatinterval 3p +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3p"} + +test spinbox-1.63 {configuration option: "selectbackground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -selectbackground #110022 + .e cget -selectbackground +} -cleanup { + destroy .e +} -result {#110022} +test spinbox-1.64 {configuration option: "selectbackground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -selectbackground bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.65 {configuration option: "selectborderwidth"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -selectborderwidth 1.3 + .e cget -selectborderwidth +} -cleanup { + destroy .e +} -result {1} +test spinbox-1.66 {configuration option: "selectborderwidth" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -selectborderwidth badValue +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad screen distance "badValue"} + +test spinbox-1.67 {configuration option: "selectforeground"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -selectforeground #654321 + .e cget -selectforeground +} -cleanup { + destroy .e +} -result {#654321} +test spinbox-1.68 {configuration option: "selectforeground" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -selectforeground bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {unknown color name "bogus"} + +test spinbox-1.69 {configuration option: "state"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -state n + .e cget -state +} -cleanup { + destroy .e +} -result {normal} +test spinbox-1.70 {configuration option: "state" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -state bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad state "bogus": must be disabled, normal, or readonly} + +test spinbox-1.71 {configuration option: "takefocus"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -takefocus "any string" + .e cget -takefocus +} -cleanup { + destroy .e +} -result {any string} + +test spinbox-1.72 {configuration option: "textvariable"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -textvariable i + .e cget -textvariable +} -cleanup { + destroy .e +} -result {i} + +test spinbox-1.73 {configuration option: "to"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -to 14.9 + .e cget -to +} -cleanup { + destroy .e +} -result {14.9} +test spinbox-1.74 {configuration option: "to" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -to bogus +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected floating-point number but got "bogus"} + +test spinbox-1.75 {configuration option: "validate"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -validate "key" + .e cget -validate +} -cleanup { + destroy .e +} -result {key} +test spinbox-1.76 {configuration option: "validate" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -validate "bogus" +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad validate "bogus": must be all, key, focus, focusin, focusout, or none} + +test spinbox-1.77 {configuration option: "validatecommand"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -validatecommand "a command" + .e cget -validatecommand +} -cleanup { + destroy .e +} -result {a command} + +test spinbox-1.78 {configuration option: "values"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -values {mon tue wed thur} + .e cget -values +} -cleanup { + destroy .e +} -result {mon tue wed thur} +test spinbox-1.79 {configuration option: "values" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -values {bad {}list} +} -cleanup { + destroy .e +} -returnCodes {error} -result {list element in braces followed by "list" instead of space} + +test spinbox-1.80 {configuration option: "vcmd"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -vcmd "a command" + .e cget -vcmd +} -cleanup { + destroy .e +} -result {a command} + +test spinbox-1.81 {configuration option: "width"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -width 402 + .e cget -width +} -cleanup { + destroy .e +} -result {402} +test spinbox-1.82 {configuration option: "width" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -width 3p +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected integer but got "3p"} + +test spinbox-1.83 {configuration option: "wrap"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -wrap yes + .e cget -wrap +} -cleanup { + destroy .e +} -result {1} +test spinbox-1.84 {configuration option: "wrap" for spinbox} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -wrap xyzzy +} -cleanup { + destroy .e +} -returnCodes {error} -result {expected boolean value but got "xyzzy"} + +test spinbox-1.85 {configuration option: "xscrollcommand"} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 -font {Helvetica -12} \ + -relief sunken + pack .e + update +} -body { + .e configure -xscrollcommand {Some command} + .e cget -xscrollcommand +} -cleanup { + destroy .e +} -result {Some command} + + +test spinbox-2.1 {Tk_SpinboxCmd procedure} -body { + spinbox +} -returnCodes error -result {wrong # args: should be "spinbox pathName ?-option value ...?"} +test spinbox-2.2 {Tk_SpinboxCmd procedure} -body { + spinbox gorp +} -returnCodes error -result {bad window path name "gorp"} +test spinbox-2.3 {Tk_SpinboxCmd procedure} -body { spinbox .e + pack .e + update list [winfo exists .e] [winfo class .e] [info commands .e] -} {1 Spinbox .e} -test spinbox-2.4 {Tk_SpinboxCmd procedure} { - catch {destroy .e} - list [catch {spinbox .e -gorp foo} msg] $msg [winfo exists .e] \ - [info commands .e] -} {1 {unknown option "-gorp"} 0 {}} -test spinbox-2.5 {Tk_SpinboxCmd procedure} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {1 Spinbox .e} +test spinbox-2.4 {Tk_SpinboxCmd procedure} -body { + spinbox .e -gorp foo +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "-gorp"} +test spinbox-2.4.1 {Tk_SpinboxCmd procedure} -body { + catch {spinbox .e -gorp foo} + list [winfo exists .e] [info commands .e] +} -cleanup { + destroy .e +} -result {0 {}} +test spinbox-2.5 {Tk_SpinboxCmd procedure} -body { spinbox .e -} {.e} - -catch {destroy .e} -spinbox .e -font $fixed -pack .e -update - -set cx [font measure $fixed a] -set cy [font metrics $fixed -linespace] -set ux [font measure $fixed \u4e4e] - -test spinbox-3.1 {SpinboxWidgetCmd procedure} { - list [catch {.e} msg] $msg -} {1 {wrong # args: should be ".e option ?arg arg ...?"}} -test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} { - list [catch {.e bbox} msg] $msg -} {1 {wrong # args: should be ".e bbox index"}} -test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} { - list [catch {.e bbox a b} msg] $msg -} {1 {wrong # args: should be ".e bbox index"}} -test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} { - list [catch {.e bbox bogus} msg] $msg -} {1 {bad spinbox index "bogus"}} -test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} { - .e delete 0 end - .e bbox 0 -} [list 5 5 0 $cy] -test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): no utf chars +} -cleanup { + destroy .e +} -result {.e} - .e delete 0 end + +test spinbox-3.1 {SpinboxWidgetCmd procedure} -setup { + spinbox .e + pack .e + update +} -body { + .e +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e option ?arg ...?"} +test spinbox-3.2 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e bbox +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e bbox index"} +test spinbox-3.3 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e bbox a b +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e bbox index"} +test spinbox-3.4 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e bbox bogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "bogus"} +test spinbox-3.5 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e bbox 0 +} -cleanup { + destroy .e +} -result [list 5 5 0 $cy] + +# Oryginaly the result was count using measurements +# and metrics. It was changed to less verbose solution - the result is the one +# that passes fonts constraint (this concerns tests 3.6, 3.7, 3.8, 3.10) +test spinbox-3.6 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): no utf chars .e insert 0 "abc" list [.e bbox 3] [.e bbox end] -} [list "[expr 5+2*$cx] 5 $cx $cy" "[expr 5+2*$cx] 5 $cx $cy"] -test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): utf at end - .e delete 0 end +} -cleanup { + destroy .e +} -result {{19 5 7 13} {19 5 7 13}} +test spinbox-3.7 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): utf at end .e insert 0 "ab\u4e4e" .e bbox end -} "[expr 5+2*$cx] 5 $ux $cy" -test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): utf before index - .e delete 0 end +} -cleanup { + destroy .e +} -result {19 5 12 13} +test spinbox-3.8 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): utf before index .e insert 0 "ab\u4e4ec" .e bbox 3 -} "[expr 5+2*$cx+$ux] 5 $cx $cy" -test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} { - # Tcl_UtfAtIndex(): no chars - .e delete 0 end +} -cleanup { + destroy .e +} -result {31 5 7 13} +test spinbox-3.9 {SpinboxWidgetCmd procedure, "bbox" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { +# Tcl_UtfAtIndex(): no chars .e bbox end -} "5 5 0 $cy" -test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result "5 5 0 $cy" +test spinbox-3.10 {SpinboxWidgetCmd procedure, "bbox" widget command} -constraints { + fonts +} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { .e insert 0 "abcdefghij\u4e4eklmnop" list [.e bbox 0] [.e bbox 1] [.e bbox 10] [.e bbox end] -} [list "5 5 $cx $cy" "[expr 5+$cx] 5 $cx $cy" "[expr 5+10*$cx] 5 $ux $cy" "[expr 5+$ux+15*$cx] 5 $cx $cy"] -test spinbox-3.11 {SpinboxWidgetCmd procedure, "cget" widget command} { - list [catch {.e cget} msg] $msg -} {1 {wrong # args: should be ".e cget option"}} -test spinbox-3.12 {SpinboxWidgetCmd procedure, "cget" widget command} { - list [catch {.e cget a b} msg] $msg -} {1 {wrong # args: should be ".e cget option"}} -test spinbox-3.13 {SpinboxWidgetCmd procedure, "cget" widget command} { - list [catch {.e cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} { +} -cleanup { + destroy .e +} -result {{5 5 7 13} {12 5 7 13} {75 5 12 13} {122 5 7 13}} +test spinbox-3.11 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { + spinbox .e +} -body { + .e cget +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e cget option"} +test spinbox-3.12 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { + spinbox .e +} -body { + .e cget a b +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e cget option"} +test spinbox-3.13 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { + spinbox .e +} -body { + .e cget -gorp +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "-gorp"} +test spinbox-3.14 {SpinboxWidgetCmd procedure, "cget" widget command} -setup { + spinbox .e +} -body { .e configure -bd 4 .e cget -bd -} {4} -test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} { +} -cleanup { + destroy .e +} -result {4} +test spinbox-3.15 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { + spinbox .e + pack .e + update +} -body { llength [.e configure] -} {49} -test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} { - list [catch {.e configure -foo} msg] $msg -} {1 {unknown option "-foo"}} -test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} { +} -cleanup { + destroy .e +} -result {49} +test spinbox-3.16 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { + spinbox .e +} -body { + .e configure -foo +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "-foo"} +test spinbox-3.17 {SpinboxWidgetCmd procedure, "configure" widget command} -setup { + spinbox .e +} -body { .e configure -bd 4 .e configure -bg #ffffff lindex [.e configure -bd] 4 -} {4} -test spinbox-3.18 {SpinboxWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete} msg] $msg -} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test spinbox-3.19 {SpinboxWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete a b c} msg] $msg -} {1 {wrong # args: should be ".e delete firstIndex ?lastIndex?"}} -test spinbox-3.20 {SpinboxWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete foo} msg] $msg -} {1 {bad spinbox index "foo"}} -test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} { - list [catch {.e delete 0 bar} msg] $msg -} {1 {bad spinbox index "bar"}} -test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test spinbox-3.18 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e +} -body { + .e delete +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} +test spinbox-3.19 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e +} -body { + .e delete a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e delete firstIndex ?lastIndex?"} +test spinbox-3.20 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e +} -body { + .e delete foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "foo"} +test spinbox-3.21 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e +} -body { + .e delete 0 bar +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "bar"} +test spinbox-3.22 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "01234567890" .e delete 2 4 .e get -} {014567890} -test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {014567890} +test spinbox-3.23 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e +} -body { .e insert end "01234567890" .e delete 6 .e get -} {0123457890} -test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} { - # UTF +} -cleanup { + destroy .e +} -result {0123457890} +test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e + pack .e + update set x {} - .e delete 0 end +} -body { +# UTF .e insert end "01234\u4e4e67890" .e delete 6 lappend x [.e get] @@ -244,277 +1246,659 @@ test spinbox-3.24 {SpinboxWidgetCmd procedure, "delete" widget command} { .e insert end "0123456\u4e4e890" .e delete 6 lappend x [.e get] -} [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] -test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result [list "01234\u4e4e7890" "0123457890" "012345\u4e4e890"] +test spinbox-3.25 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "01234567890" .e delete 6 5 .e get -} {01234567890} -test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {01234567890} +test spinbox-3.26 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "01234567890" .e configure -state disabled .e delete 2 8 .e configure -state normal .e get -} {01234567890} -test spinbox-3.27 {SpinboxWidgetCmd procedure, "get" widget command} { - list [catch {.e get foo} msg] $msg -} {1 {wrong # args: should be ".e get"}} -test spinbox-3.28 {SpinboxWidgetCmd procedure, "icursor" widget command} { - list [catch {.e icursor} msg] $msg -} {1 {wrong # args: should be ".e icursor pos"}} -test spinbox-3.29 {SpinboxWidgetCmd procedure, "icursor" widget command} { - list [catch {.e icursor foo} msg] $msg -} {1 {bad spinbox index "foo"}} -test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {01234567890} +test spinbox-3.26.1 {SpinboxWidgetCmd procedure, "delete" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e insert end "01234567890" + .e configure -state readonly + .e delete 2 8 + .e configure -state normal + .e get +} -cleanup { + destroy .e +} -result {01234567890} +test spinbox-3.27 {SpinboxWidgetCmd procedure, "get" widget command} -setup { + spinbox .e +} -body { + .e get foo +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e get"} +test spinbox-3.28 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup { + spinbox .e +} -body { + .e icursor +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e icursor pos"} +test spinbox-3.29 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup { + spinbox .e +} -body { + .e icursor foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "foo"} +test spinbox-3.30 {SpinboxWidgetCmd procedure, "icursor" widget command} -setup { + spinbox .e +} -body { .e insert end "01234567890" .e icursor 4 .e index insert -} {4} -test spinbox-3.31 {SpinboxWidgetCmd procedure, "index" widget command} { - list [catch {.e in} msg] $msg -} {1 {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}} -test spinbox-3.32 {SpinboxWidgetCmd procedure, "index" widget command} { - list [catch {.e index} msg] $msg -} {1 {wrong # args: should be ".e index string"}} -test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} { - list [catch {.e index foo} msg] $msg -} {1 {bad spinbox index "foo"}} -test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} { - list [catch {.e index 0} msg] $msg -} {0 0} -test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} { - # UTF - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test spinbox-3.31 {SpinboxWidgetCmd procedure, "index" widget command} -setup { + spinbox .e +} -body { + .e in +} -cleanup { + destroy .e +} -returnCodes error -result {ambiguous option "in": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview} +test spinbox-3.32 {SpinboxWidgetCmd procedure, "index" widget command} -setup { + spinbox .e +} -body { + .e index +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e index string"} +test spinbox-3.33 {SpinboxWidgetCmd procedure, "index" widget command} -setup { + spinbox .e +} -body { + .e index foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "foo"} +test spinbox-3.34 {SpinboxWidgetCmd procedure, "index" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e index 0 +} -cleanup { + destroy .e +} -returnCodes {ok} -match glob -result {*} +test spinbox-3.35 {SpinboxWidgetCmd procedure, "index" widget command} -setup { + spinbox .e + pack .e + update +} -body { +# UTF .e insert 0 abc\u4e4e\u0153def list [.e index 3] [.e index 4] [.e index end] -} {3 4 8} -test spinbox-3.36 {SpinboxWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert a} msg] $msg -} {1 {wrong # args: should be ".e insert index text"}} -test spinbox-3.37 {SpinboxWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert a b c} msg] $msg -} {1 {wrong # args: should be ".e insert index text"}} -test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert foo Text} msg] $msg -} {1 {bad spinbox index "foo"}} -test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 4 8} +test spinbox-3.36 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e +} -body { + .e insert a +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e insert index text"} +test spinbox-3.37 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e +} -body { + .e insert a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e insert index text"} +test spinbox-3.38 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e +} -body { + .e insert foo Text +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "foo"} +test spinbox-3.39 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "01234567890" .e insert 3 xxx .e get -} {012xxx34567890} -test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {012xxx34567890} +test spinbox-3.40 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "01234567890" .e configure -state disabled .e insert 3 xxx .e configure -state normal .e get -} {01234567890} -test spinbox-3.41 {SpinboxWidgetCmd procedure, "insert" widget command} { - list [catch {.e insert a b c} msg] $msg -} {1 {wrong # args: should be ".e insert index text"}} -test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan a} msg] $msg -} {1 {wrong # args: should be ".e scan mark|dragto x"}} -test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan a b c} msg] $msg -} {1 {wrong # args: should be ".e scan mark|dragto x"}} -test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan foobar 20} msg] $msg -} {1 {bad scan option "foobar": must be mark or dragto}} -test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} { - list [catch {.e scan mark 20.1} msg] $msg -} {1 {expected integer but got "20.1"}} -# This test is non-portable because character sizes vary. +} -cleanup { + destroy .e +} -result {01234567890} +test spinbox-3.40.1 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e insert end "01234567890" + .e configure -state readonly + .e insert 3 xxx + .e configure -state normal + .e get +} -cleanup { + destroy .e +} -result {01234567890} +test spinbox-3.41 {SpinboxWidgetCmd procedure, "insert" widget command} -setup { + spinbox .e +} -body { + .e insert a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e insert index text"} +test spinbox-3.42 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e scan a +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"} +test spinbox-3.43 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e scan a b c +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e scan mark|dragto x"} +test spinbox-3.44 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e scan foobar 20 +} -cleanup { + destroy .e +} -returnCodes error -result {bad scan option "foobar": must be mark or dragto} +test spinbox-3.45 {SpinboxWidgetCmd procedure, "scan" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e scan mark 20.1 +} -cleanup { + destroy .e +} -returnCodes error -result {expected integer but got "20.1"} -test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} {fonts} { - .e delete 0 end +# This test is non-portable because character sizes vary. +test spinbox-3.46 {SpinboxWidgetCmd procedure, "scan" widget command} -constraints { + fonts +} -setup { + spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 + pack .e update +} -body { .e insert end "This is quite a long string, in fact a " .e insert end "very very long string" .e scan mark 30 .e scan dragto 28 .e index @0 -} {2} -test spinbox-3.47 {SpinboxWidgetCmd procedure, "select" widget command} { - list [catch {.e select} msg] $msg -} {1 {wrong # args: should be ".e selection option ?index?"}} -test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} { - list [catch {.e select foo} msg] $msg -} {1 {bad selection option "foo": must be adjust, clear, element, from, present, range, or to}} -test spinbox-3.49 {SpinboxWidgetCmd procedure, "select clear" widget command} { - list [catch {.e select clear gorp} msg] $msg -} {1 {wrong # args: should be ".e selection clear"}} -test spinbox-3.50 {SpinboxWidgetCmd procedure, "select clear" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2} +test spinbox-3.47 {SpinboxWidgetCmd procedure, "select" widget command} -setup { + spinbox .e +} -body { + .e select +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection option ?index?"} +test spinbox-3.48 {SpinboxWidgetCmd procedure, "select" widget command} -setup { + spinbox .e +} -body { + .e select foo +} -cleanup { + destroy .e +} -returnCodes error -result {bad selection option "foo": must be adjust, clear, element, from, present, range, or to} + +test spinbox-3.49 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup { + spinbox .e +} -body { + .e select clear gorp +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection clear"} +test spinbox-3.50 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup { + spinbox .e +} -body { .e insert end "0123456789" .e select from 1 .e select to 4 update .e select clear - list [catch {selection get} msg] $msg [selection own] -} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} .e} -test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget command} { - list [catch {.e selection present foo} msg] $msg -} {1 {wrong # args: should be ".e selection present"}} -test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget command} { - .e delete 0 end + selection get +} -cleanup { + destroy .e +} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test spinbox-3.50.1 {SpinboxWidgetCmd procedure, "select clear" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e insert end "0123456789" + .e select from 1 + .e select to 4 + update + .e select clear + catch {selection get} + selection own +} -cleanup { + destroy .e +} -result {.e} + +test spinbox-3.51 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { + spinbox .e +} -body { + .e selection present foo +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection present"} +test spinbox-3.52 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 6 .e selection present -} {1} -test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test spinbox-3.53 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 6 .e configure -exportselection false .e selection present -} {1} -.e configure -exportselection true -test spinbox-3.54 {SpinboxWidgetCmd procedure, "selection present" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test spinbox-3.54 {SpinboxWidgetCmd procedure, "selection present" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 6 .e delete 0 end .e selection present -} {0} -test spinbox-3.55 {SpinboxWidgetCmd procedure, "selection adjust" widget command} { - list [catch {.e select adjust x} msg] $msg -} {1 {bad spinbox index "x"}} -test spinbox-3.56 {SpinboxWidgetCmd procedure, "selection adjust" widget command} { - list [catch {.e select adjust 2 3} msg] $msg -} {1 {wrong # args: should be ".e selection adjust index"}} -test spinbox-3.57 {SpinboxWidgetCmd procedure, "selection adjust" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0} +test spinbox-3.55 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup { + spinbox .e +} -body { + .e select adjust x +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "x"} +test spinbox-3.56 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup { + spinbox .e +} -body { + .e select adjust 2 3 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection adjust index"} +test spinbox-3.57 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "0123456789" .e select from 1 .e select to 5 update .e select adjust 4 selection get -} {123} -test spinbox-3.58 {SpinboxWidgetCmd procedure, "selection adjust" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {123} +test spinbox-3.58 {SpinboxWidgetCmd procedure, "selection adjust" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end "0123456789" .e select from 1 .e select to 5 update .e select adjust 2 selection get -} {234} -test spinbox-3.59 {SpinboxWidgetCmd procedure, "selection from" widget command} { - list [catch {.e select from 2 3} msg] $msg -} {1 {wrong # args: should be ".e selection from index"}} -test spinbox-3.60 {SpinboxWidgetCmd procedure, "selection range" widget command} { - list [catch {.e select range 2} msg] $msg -} {1 {wrong # args: should be ".e selection range start end"}} -test spinbox-3.61 {SpinboxWidgetCmd procedure, "selection range" widget command} { - list [catch {.e selection range 2 3 4} msg] $msg -} {1 {wrong # args: should be ".e selection range start end"}} -test spinbox-3.62 {SpinboxWidgetCmd procedure, "selection range" widget command} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {234} +test spinbox-3.59 {SpinboxWidgetCmd procedure, "selection from" widget command} -setup { + spinbox .e +} -body { + .e select from 2 3 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection from index"} + +test spinbox-3.60 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup { + spinbox .e +} -body { + .e select range 2 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection range start end"} +test spinbox-3.61 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup { + spinbox .e +} -body { + .e selection range 2 3 4 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection range start end"} +test spinbox-3.62 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup { + spinbox .e +} -body { .e insert end 0123456789 .e select from 1 .e select to 5 .e select range 4 4 - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test spinbox-3.63 {SpinboxWidgetCmd procedure, "selection range" widget command} { - .e delete 0 end + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test spinbox-3.63 {SpinboxWidgetCmd procedure, "selection range" widget command} -setup { + spinbox .e + pack .e + update +} -body { .e insert end 0123456789 .e select from 3 .e select to 7 .e select range 2 9 list [.e index sel.first] [.e index sel.last] [.e index anchor] -} {2 9 3} -.e delete 0 end -.e insert end "This is quite a long text string, so long that it " -.e insert end "runs off the end of the window quite a bit." -test spinbox-3.64 {SpinboxWidgetCmd procedure, "selection to" widget command} { - list [catch {.e select to 2 3} msg] $msg -} {1 {wrong # args: should be ".e selection to index"}} -test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {2 9 3} +test spinbox-3.64 {SpinboxWidgetCmd procedure, "selection to" widget command} -setup { + spinbox .e + pack .e + update + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." +} -body { + .e select to 2 3 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e selection to index"} +test spinbox-3.64.1 {SpinboxWidgetCmd procedure, "selection" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e insert end 0123456789 + .e selection range 0 end + .e configure -state disabled + .e selection range 2 4 + .e configure -state normal + list [.e index sel.first] [.e index sel.last] +} -cleanup { + destroy .e +} -result {0 10} +test spinbox-3.64.2 {SpinboxWidgetCmd procedure, "selection" widget command} -setup { + spinbox .e + pack .e + update +} -body { + .e insert end 0123456789 + .e selection range 0 end + .e configure -state readonly + .e selection range 2 4 + .e configure -state normal + list [.e index sel.first] [.e index sel.last] +} -cleanup { + destroy .e +} -result {2 4} + +test spinbox-3.65 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview 5 format {%.6f %.6f} {*}[.e xview] -} {0.053763 0.268817} -test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview gorp} msg] $msg -} {1 {bad spinbox index "gorp"}} -test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.053763 0.268817} +test spinbox-3.66 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e xview gorp +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "gorp"} +test spinbox-3.67 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview 0 .e icursor 10 .e xview insert format {%.6f %.6f} {*}[.e xview] -} {0.107527 0.322581} -test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview moveto foo bar} msg] $msg -} {1 {wrong # args: should be ".e xview moveto fraction"}} -test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview moveto foo} msg] $msg -} {1 {expected floating-point number but got "foo"}} -test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.107527 0.322581} +test spinbox-3.68 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e xview moveto foo bar +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e xview moveto fraction"} +test spinbox-3.69 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e xview moveto foo +} -cleanup { + destroy .e +} -returnCodes error -result {expected floating-point number but got "foo"} +test spinbox-3.70 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview moveto 0.5 format {%.6f %.6f} {*}[.e xview] -} {0.505376 0.72043} -test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview scroll 24} msg] $msg -} {1 {wrong # args: should be ".e xview scroll number units|pages"}} -test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview scroll gorp units} msg] $msg -} {1 {expected integer but got "gorp"}} -test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.505376 0.720430} +test spinbox-3.71 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + .e xview scroll 24 +} -cleanup { + destroy .e +} -returnCodes error -result {wrong # args: should be ".e xview scroll number units|pages"} +test spinbox-3.72 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update + .e xview scroll gorp units +} -cleanup { + destroy .e +} -returnCodes error -result {expected integer but got "gorp"} +test spinbox-3.73 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview moveto 0 .e xview scroll 1 pages format {%.6f %.6f} {*}[.e xview] -} {0.193548 0.408602} -test spinbox-3.74 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.193548 0.408602} +test spinbox-3.74 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview moveto .9 update .e xview scroll -2 p format {%.6f %.6f} {*}[.e xview] -} {0.397849 0.612903} -test spinbox-3.75 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0.397849 0.612903} +test spinbox-3.75 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview 30 update .e xview scroll 2 units .e index @0 -} {32} -test spinbox-3.76 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {32} +test spinbox-3.76 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview 30 update .e xview scroll -1 units .e index @0 -} {29} -test spinbox-3.77 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview scroll 23 foobars} msg] $msg -} {1 {bad argument "foobars": must be units or pages}} -test spinbox-3.78 {SpinboxWidgetCmd procedure, "xview" widget command} { - list [catch {.e xview eat 23 hamburgers} msg] $msg -} {1 {unknown option "eat": must be moveto or scroll}} -test spinbox-3.79 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {29} +test spinbox-3.77 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update + .e xview scroll 23 foobars +} -cleanup { + destroy .e +} -returnCodes error -result {bad argument "foobars": must be units or pages} +test spinbox-3.78 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update + .e xview eat 23 hamburgers +} -cleanup { + destroy .e +} -returnCodes error -result {unknown option "eat": must be moveto or scroll} +test spinbox-3.79 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." .e xview 0 update .e xview -4 .e index @0 -} {0} -test spinbox-3.80 {SpinboxWidgetCmd procedure, "xview" widget command} { +} -cleanup { + destroy .e +} -result {0} +test spinbox-3.80 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + update .e xview 300 .e index @0 -} {73} -.e insert 10 \u4e4e -test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} { - # UTF - # If Tcl_NumUtfChars wasn't used, wrong answer would be: - # 0.106383 0.117021 0.117021 - +} -cleanup { + destroy .e +} -result {73} +test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e +} -body { + .e insert end "This is quite a long text string, so long that it " + .e insert end "runs off the end of the window quite a bit." + .e insert 10 \u4e4e + update +# UTF +# If Tcl_NumUtfChars wasn't used, wrong answer would be: +# 0.106383 0.117021 0.117021 set x {} .e xview moveto .1 lappend x [format {%.6f} [lindex [.e xview] 0]] @@ -522,221 +1906,327 @@ test spinbox-3.81 {SpinboxWidgetCmd procedure, "xview" widget command} { lappend x [format {%.6f} [lindex [.e xview] 0]] .e xview moveto .12 lappend x [format {%.6f} [lindex [.e xview] 0]] -} {0.095745 0.106383 0.117021} -test spinbox-3.82 {SpinboxWidgetCmd procedure} { - list [catch {.e gorp} msg] $msg -} {1 {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview}} - -frame .f -width 200 -height 50 -relief raised -bd 2 -pack .f -side right -test spinbox-5.1 {ConfigureSpinbox procedure, -textvariable} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {0.095745 0.106383 0.117021} + +test spinbox-3.82 {SpinboxWidgetCmd procedure} -setup { + spinbox .e -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .e + update +} -body { + .e gorp +} -cleanup { + destroy .e +} -returnCodes error -result {bad option "gorp": must be bbox, cget, configure, delete, get, icursor, identify, index, insert, invoke, scan, selection, set, validate, or xview} + +test spinbox-5.1 {ConfigureSpinbox procedure, -textvariable} -body { set x 12345 spinbox .e -textvariable x .e get -} {12345} -test spinbox-5.2 {ConfigureSpinbox procedure, -textvariable} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {12345} +test spinbox-5.2 {ConfigureSpinbox procedure, -textvariable} -body { set x 12345 spinbox .e -textvariable x set y abcde .e configure -textvariable y set x 54321 .e get -} {abcde} -test spinbox-5.3 {ConfigureSpinbox procedure, -textvariable} { - catch {destroy .e} - catch {unset x} +} -cleanup { + destroy .e +} -result {abcde} +test spinbox-5.3 {ConfigureSpinbox procedure, -textvariable} -setup { + unset -nocomplain x spinbox .e +} -body { .e insert 0 "Some text" .e configure -textvariable x set x -} {Some text} -test spinbox-5.4 {ConfigureSpinbox procedure, -textvariable} { - proc override args { - global x - set x 12345 - } - catch {destroy .e} - catch {unset x} - trace variable x w override +} -cleanup { + destroy .e +} -result {Some text} +test spinbox-5.4 {ConfigureSpinbox procedure, -textvariable} -setup { + unset -nocomplain x spinbox .e +} -body { + trace variable x w override .e insert 0 "Some text" .e configure -textvariable x - set result [list $x [.e get]] - unset x; rename override {} - set result -} {12345 12345} -test spinbox-5.5 {ConfigureSpinbox procedure} { - catch {destroy .e} - spinbox .e -exportselection false - pack .e - .e insert end "0123456789" - .sel select from 0 - .sel select to 10 + list $x [.e get] +} -cleanup { + destroy .e + trace vdelete x w override +} -result {12345 12345} + +test spinbox-5.5 {ConfigureSpinbox procedure} -setup { set x {} + spinbox .e1 + spinbox .e2 +} -body { + .e2 insert end "This is some sample text" + .e1 configure -exportselection false + .e1 insert end "0123456789" + pack .e1 .e2 + .e2 select from 0 + .e2 select to 10 lappend x [selection get] - .e select from 1 - .e select to 5 + .e1 select from 1 + .e1 select to 5 lappend x [selection get] - .e configure -exportselection 1 + .e1 configure -exportselection 1 lappend x [selection get] set x -} {{This is so} {This is so} 1234} -test spinbox-5.6 {ConfigureSpinbox procedure} { - catch {destroy .e} +} -cleanup { + destroy .e1 .e2 +} -result {{This is so} {This is so} 1234} +test spinbox-5.6 {ConfigureSpinbox procedure} -setup { + spinbox .e + pack .e +} -body { + .e insert end "0123456789" + .e select from 1 + .e select to 5 + .e configure -exportselection 0 + selection get +} -cleanup { + destroy .e +} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test spinbox-5.6.1 {ConfigureSpinbox procedure} -setup { spinbox .e pack .e +} -body { .e insert end "0123456789" .e select from 1 .e select to 5 .e configure -exportselection 0 - list [catch {selection get} msg] $msg [.e index sel.first] \ - [.e index sel.last] -} {1 {PRIMARY selection doesn't exist or form "STRING" not defined} 1 5} -test spinbox-5.7 {ConfigureSpinbox procedure} { - catch {destroy .e} - spinbox .e -font $fixed -width 4 -xscrollcommand scroll + catch {selection get} + list [.e index sel.first] [.e index sel.last] +} -cleanup { + destroy .e +} -result {1 5} + +test spinbox-5.7 {ConfigureSpinbox procedure} -setup { + spinbox .e -font {Helvetica -12} -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -width 4 -xscrollcommand scroll .e insert end "01234567890" update .e configure -width 5 format {%.6f %.6f} {*}$scrollInfo -} {0.000000 0.363636} -test spinbox-5.8 {ConfigureSpinbox procedure} {fonts} { - catch {destroy .e} - spinbox .e -width 0 +} -cleanup { + destroy .e +} -result {0.000000 0.363636} + +test spinbox-5.8 {ConfigureSpinbox procedure} -constraints { + fonts +} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -width 0 -font {Helvetica -12} .e insert end "0123" update - .e configure -font $big + .e configure -font {Helvetica -24} update winfo geom .e -} {79x37+0+0} -test spinbox-5.9 {ConfigureSpinbox procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised +} -cleanup { + destroy .e +} -result {79x37+0+0} +test spinbox-5.9 {ConfigureSpinbox procedure} -constraints { + fonts +} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised .e insert end "0123" update list [.e index @10] [.e index @11] [.e index @12] [.e index @13] -} {0 0 1 1} -test spinbox-5.10 {ConfigureSpinbox procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief flat +} -cleanup { + destroy .e +} -result {0 0 1 1} +test spinbox-5.10 {ConfigureSpinbox procedure} -constraints { + fonts +} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief flat .e insert end "0123" update list [.e index @10] [.e index @11] [.e index @12] [.e index @13] -} {0 0 1 1} -test spinbox-5.11 {ConfigureSpinbox procedure} { - # If "0" in selected font had 0 width, caused divide-by-zero error. - - catch {destroy .e} - pack [spinbox .e -font {{open look glyph}}] +} -cleanup { + destroy .e +} -result {0 0 1 1} +test spinbox-5.11 {ConfigureSpinbox procedure} -setup { + spinbox .e -borderwidth 2 -highlightthickness 2 + pack .e +} -body { +# If "0" in selected font had 0 width, caused divide-by-zero error. + .e configure -font {{open look glyph}} .e scan dragto 30 update -} {} +} -cleanup { + destroy .e +} -result {} # No tests for DisplaySpinbox. -test spinbox-6.1 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised -width 20 -highlightthickness 3 +test spinbox-6.1 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -highlightthickness 3 .e insert end 012\t45 update list [.e index @61] [.e index @62] -} {3 4} -test spinbox-6.2 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised -width 20 -justify center \ - -highlightthickness 3 +} -cleanup { + destroy .e +} -result {3 4} +test spinbox-6.2 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -justify center \ + -highlightthickness 3 .e insert end 012\t45 update list [.e index @96] [.e index @97] -} {3 4} -test spinbox-6.3 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised -width 20 -justify right \ - -highlightthickness 3 +} -cleanup { + destroy .e +} -result {3 4} +test spinbox-6.3 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 20 -justify right \ + -highlightthickness 3 .e insert end 012\t45 update list [.e index @131] [.e index @132] -} {3 4} -test spinbox-6.4 {SpinboxComputeGeometry procedure} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised -width 5 +} -cleanup { + destroy .e +} -result {3 4} +test spinbox-6.4 {SpinboxComputeGeometry procedure} -setup { + spinbox .e pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 5 .e insert end "01234567890" update .e xview 6 .e index @0 -} {6} -test spinbox-6.5 {SpinboxComputeGeometry procedure} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised -width 5 +} -cleanup { + destroy .e +} -result {6} +test spinbox-6.5 {SpinboxComputeGeometry procedure} -setup { + spinbox .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 5 .e insert end "01234567890" update .e xview 7 .e index @0 -} {6} -test spinbox-6.6 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $fixed -bd 2 -relief raised -width 10 +} -cleanup { + destroy .e +} -result {6} +test spinbox-6.6 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Courier -12} -bd 2 -relief raised -width 10 .e insert end "01234\t67890" update .e xview 3 list [.e index @39] [.e index @40] -} {5 6} -test spinbox-6.7 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $big -bd 3 -relief raised -width 5 +} -cleanup { + destroy .e +} -result {5 6} +test spinbox-6.7 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 5 .e insert end "01234567" update list [winfo reqwidth .e] [winfo reqheight .e] -} {94 39} -test spinbox-6.8 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $big -bd 3 -relief raised -width 0 +} -cleanup { + destroy .e +} -result {94 39} +test spinbox-6.8 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 .e insert end "01234567" update list [winfo reqwidth .e] [winfo reqheight .e] -} {133 39} -test spinbox-6.9 {SpinboxComputeGeometry procedure} {fonts} { - catch {destroy .e} - spinbox .e -font $big -bd 3 -relief raised -width 0 -highlightthickness 2 +} -cleanup { + destroy .e +} -result {133 39} +test spinbox-6.9 {SpinboxComputeGeometry procedure} -constraints { + fonts +} -setup { + spinbox .e -highlightthickness 2 pack .e +} -body { + .e configure -font {Helvetica -24} -bd 3 -relief raised -width 0 update list [winfo reqwidth .e] [winfo reqheight .e] -} {42 39} +} -cleanup { + destroy .e +} -result {42 39} -catch {destroy .e} -spinbox .e -width 10 -font $fixed -textvariable contents -xscrollcommand scroll -pack .e -focus .e -test spinbox-7.1 {InsertChars procedure} { - .e delete 0 end + +test spinbox-7.1 {InsertChars procedure} -setup { + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 2 XXX update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abXXXcde abXXXcde {0.000000 1.000000}} -test spinbox-7.2 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abXXXcde abXXXcde {0.000000 1.000000}} + +test spinbox-7.2 {InsertChars procedure} -setup { + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e insert 500 XXX update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abcdeXXX abcdeXXX {0.000000 1.000000}} -test spinbox-7.3 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abcdeXXX abcdeXXX {0.000000 1.000000}} +test spinbox-7.3 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -744,9 +2234,13 @@ test spinbox-7.3 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {5 9 5 8} -test spinbox-7.4 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {5 9 5 8} +test spinbox-7.4 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -754,9 +2248,13 @@ test spinbox-7.4 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {2 9 2 8} -test spinbox-7.5 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 9 2 8} +test spinbox-7.5 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -764,9 +2262,13 @@ test spinbox-7.5 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {2 9 2 8} -test spinbox-7.6 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 9 2 8} +test spinbox-7.6 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e select from 2 .e select to 6 @@ -774,70 +2276,118 @@ test spinbox-7.6 {InsertChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 5 lappend x [.e index sel.first] [.e index sel.last] -} {2 6 2 5} -test spinbox-7.7 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {2 6 2 5} +test spinbox-7.7 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -xscrollcommand scroll .e insert 0 0123456789 .e icursor 4 .e insert 4 XXX .e index insert -} {7} -test spinbox-7.8 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {7} +test spinbox-7.8 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789 .e icursor 4 .e insert 5 XXX .e index insert -} {4} -test spinbox-7.9 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test spinbox-7.9 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 "This is a very long string" update .e xview 4 .e insert 3 XXX .e index @0 -} {7} -test spinbox-7.10 {InsertChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {7} +test spinbox-7.10 {InsertChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 "This is a very long string" update .e xview 4 .e insert 4 XXX .e index @0 -} {4} -.e configure -width 0 -test spinbox-7.11 {InsertChars procedure} {fonts} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} + +test spinbox-7.11 {InsertChars procedure} -constraints { + fonts +} -setup { + spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 "xyzzy" update .e insert 2 00 winfo reqwidth .e -} {70} +} -cleanup { + destroy .e +} -result {70} -.e configure -width 10 -test spinbox-8.1 {DeleteChars procedure} { - .e delete 0 end +test spinbox-8.1 {DeleteChars procedure} -setup { + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 2 4 update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abe abe {0.000000 1.000000}} -test spinbox-8.2 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abe abe {0.000000 1.000000}} +test spinbox-8.2 {DeleteChars procedure} -setup { + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete -2 2 update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {cde cde {0.000000 1.000000}} -test spinbox-8.3 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {cde cde {0.000000 1.000000}} +test spinbox-8.3 {DeleteChars procedure} -setup { + unset -nocomplain contents + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { + .e configure -textvariable contents -xscrollcommand scroll .e insert 0 abcde .e delete 3 1000 update list [.e get] $contents [format {%.6f %.6f} {*}$scrollInfo] -} {abc abc {0.000000 1.000000}} -test spinbox-8.4 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {abc abc {0.000000 1.000000}} +test spinbox-8.4 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -846,9 +2396,14 @@ test spinbox-8.4 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 5 lappend x [.e index sel.first] [.e index sel.last] -} {1 6 1 5} -test spinbox-8.5 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1 6 1 5} +test spinbox-8.5 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -857,9 +2412,14 @@ test spinbox-8.5 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 4 lappend x [.e index sel.first] [.e index sel.last] -} {1 5 1 4} -test spinbox-8.6 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1 5 1 4} +test spinbox-8.6 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -868,17 +2428,28 @@ test spinbox-8.6 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 5 lappend x [.e index sel.first] [.e index sel.last] -} {1 2 1 5} -test spinbox-8.7 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1 2 1 5} +test spinbox-8.7 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 .e delete 1 8 - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test spinbox-8.8 {DeleteChars procedure} { - .e delete 0 end + update + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test spinbox-8.8 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 @@ -887,17 +2458,27 @@ test spinbox-8.8 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {3 4 3 8} -test spinbox-8.9 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 4 3 8} +test spinbox-8.9 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e +} -body { .e insert 0 0123456789abcde .e select from 3 .e select to 8 .e delete 3 8 - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test spinbox-8.10 {DeleteChars procedure} { - .e delete 0 end + update + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test spinbox-8.10 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 8 .e select to 3 @@ -906,9 +2487,14 @@ test spinbox-8.10 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 8 lappend x [.e index sel.first] [.e index sel.last] -} {3 5 5 8} -test spinbox-8.11 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 5 5 8} +test spinbox-8.11 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e select from 8 .e select to 3 @@ -917,124 +2503,185 @@ test spinbox-8.11 {DeleteChars procedure} { set x "[.e index sel.first] [.e index sel.last]" .e select to 4 lappend x [.e index sel.first] [.e index sel.last] -} {3 8 4 8} -test spinbox-8.12 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {3 8 4 8} +test spinbox-8.12 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e icursor 4 .e delete 1 4 + update .e index insert -} {1} -test spinbox-8.13 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test spinbox-8.13 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e icursor 4 .e delete 1 5 + update .e index insert -} {1} -test spinbox-8.14 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test spinbox-8.14 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 0123456789abcde .e icursor 4 .e delete 4 6 + update .e index insert -} {4} -test spinbox-8.15 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test spinbox-8.15 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "This is a very long string" .e xview 4 .e delete 1 4 + update .e index @0 -} {1} -test spinbox-8.16 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test spinbox-8.16 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "This is a very long string" .e xview 4 .e delete 1 5 + update .e index @0 -} {1} -test spinbox-8.17 {DeleteChars procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {1} +test spinbox-8.17 {DeleteChars procedure} -setup { + spinbox .e -width 10 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "This is a very long string" .e xview 4 .e delete 4 6 + update .e index @0 -} {4} -.e configure -width 0 -test spinbox-8.18 {DeleteChars procedure} {fonts} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {4} +test spinbox-8.18 {DeleteChars procedure} -setup { + spinbox .e -width 0 -font {Courier -12} -highlightthickness 2 -bd 2 + pack .e + focus .e +} -body { .e insert 0 "xyzzy" update .e delete 2 4 winfo reqwidth .e -} {42} +} -cleanup { + destroy .e +} -result {42} -test spinbox-9.1 {SpinboxValueChanged procedure} { - catch {destroy .e} - proc override args { - global x - set x 12345 - } - catch {unset x} +test spinbox-9.1 {SpinboxValueChanged procedure} -setup { + unset -nocomplain x +} -body { trace variable x w override - spinbox .e -textvariable x + spinbox .e -textvariable x -width 0 .e insert 0 foo - set result [list $x [.e get]] - unset x; rename override {} - set result -} {12345 12345} - -catch {destroy .e} -spinbox .e -pack .e -.e configure -width 0 -test spinbox-10.1 {SpinboxSetValue procedure} {fonts} { + list $x [.e get] +} -cleanup { + destroy .e + trace vdelete x w override +} -result {12345 12345} + + +test spinbox-10.1 {SpinboxSetValue procedure} -constraints fonts -body { set x abcde set y ab - .e configure -textvariable x - update + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 -width 0 + pack .e + .e configure -textvariable x .e configure -textvariable y update list [.e get] [winfo reqwidth .e] -} {ab 35} -test spinbox-10.2 {SpinboxSetValue procedure, updating selection} { - catch {destroy .e} - spinbox .e -textvariable x +} -cleanup { + destroy .e +} -result {ab 35} +test spinbox-10.2 {SpinboxSetValue procedure, updating selection} -setup { + unset -nocomplain x + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -textvariable x .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 set x "a" - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test spinbox-10.3 {SpinboxSetValue procedure, updating selection} { - catch {destroy .e} - spinbox .e -textvariable x + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} +test spinbox-10.3 {SpinboxSetValue procedure, updating selection} -setup { + unset -nocomplain x + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -textvariable x .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 set x "abcdefg" list [.e index sel.first] [.e index sel.last] -} {4 7} -test spinbox-10.4 {SpinboxSetValue procedure, updating selection} { - catch {destroy .e} - spinbox .e -textvariable x +} -cleanup { + destroy .e +} -result {4 7} +test spinbox-10.4 {SpinboxSetValue procedure, updating selection} -setup { + unset -nocomplain x + spinbox .e -font {Helvetica -12} -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -textvariable x .e insert 0 "abcdefghjklmnopqrstu" .e selection range 4 10 set x "abcdefghijklmn" list [.e index sel.first] [.e index sel.last] -} {4 10} -test spinbox-10.5 {SpinboxSetValue procedure, updating display position} { - catch {destroy .e} - spinbox .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {4 10} +test spinbox-10.5 {SpinboxSetValue procedure, updating display position} -setup { + unset -nocomplain x + spinbox .e -highlightthickness 2 -bd 2 pack .e +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 update set x "abcdefg" update .e index @0 -} {0} -test spinbox-10.6 {SpinboxSetValue procedure, updating display position} { - catch {destroy .e} - spinbox .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {0} +test spinbox-10.6 {SpinboxSetValue procedure, updating display position} -setup { + unset -nocomplain x + spinbox .e -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e xview 10 @@ -1042,177 +2689,444 @@ test spinbox-10.6 {SpinboxSetValue procedure, updating display position} { set x "1234567890123456789012" update .e index @0 -} {10} -test spinbox-10.7 {SpinboxSetValue procedure, updating insertion cursor} { - catch {destroy .e} - spinbox .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {10} +test spinbox-10.7 {SpinboxSetValue procedure, updating insertion cursor} -setup { + unset -nocomplain x + spinbox .e -highlightthickness 2 -bd 2 + pack .e + update +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 set x "123" .e index insert -} {3} -test spinbox-10.8 {SpinboxSetValue procedure, updating insertion cursor} { - catch {destroy .e} - spinbox .e -width 10 -font $fixed -textvariable x +} -cleanup { + destroy .e +} -result {3} +test spinbox-10.8 {SpinboxSetValue procedure, updating insertion cursor} -setup { + unset -nocomplain x + spinbox .e -highlightthickness 2 -bd 2 + pack .e +} -body { + .e configure -width 10 -font {Courier -12} -textvariable x pack .e .e insert 0 "abcdefghjklmnopqrstuvwxyz" .e icursor 5 set x "123456" .e index insert -} {5} +} -cleanup { + destroy .e +} -result {5} -test spinbox-11.1 {SpinboxEventProc procedure} { - catch {destroy .e} - spinbox .e +test spinbox-11.1 {SpinboxEventProc procedure} -setup { + spinbox .e -highlightthickness 2 -bd 2 -font {Helvetica -12} + pack .e +} -body { .e insert 0 abcdefg destroy .e update -} {} -test spinbox-11.2 {SpinboxEventProc procedure} { - deleteWindows +} -cleanup { + destroy .e +} -result {} +test spinbox-11.2 {SpinboxEventProc procedure} -setup { + set x {} +} -body { spinbox .e1 -fg #112233 rename .e1 .e2 - set x {} lappend x [winfo children .] lappend x [.e2 cget -fg] destroy .e1 lappend x [info command .e*] [winfo children .] -} {.e1 #112233 {} {}} - -test spinbox-12.1 {SpinboxCmdDeletedProc procedure} { - deleteWindows - button .e1 -text "xyz_123" - rename .e1 {} - list [info command .e*] [winfo children .] -} {{} {}} - -catch {destroy .e} -spinbox .e -font $fixed -width 5 -bd 2 -relief sunken -pack .e -.e insert 0 012345678901234567890 -.e xview 4 -update -test spinbox-13.1 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e1 +} -result {.e1 #112233 {} {}} + +test spinbox-12.1 {SpinboxCmdDeletedProc procedure} -body { + button .b -text "xyz_123" + rename .b {} + list [info command .b*] [winfo children .] +} -cleanup { + destroy .b +} -result {{} {}} + + +test spinbox-13.1 {GetSpinboxIndex procedure} -setup { + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e index end -} {21} -test spinbox-13.2 {GetSpinboxIndex procedure} { - list [catch {.e index abogus} msg] $msg -} {1 {bad spinbox index "abogus"}} -test spinbox-13.3 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {21} +test spinbox-13.2 {GetSpinboxIndex procedure} -body { + spinbox .e + .e index abogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "abogus"} +test spinbox-13.3 {GetSpinboxIndex procedure} -setup { + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 1 .e select to 6 .e index anchor -} {1} -test spinbox-13.4 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {1} +test spinbox-13.4 {GetSpinboxIndex procedure} -setup { + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 4 .e select to 1 .e index anchor -} {4} -test spinbox-13.5 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {4} +test spinbox-13.5 {GetSpinboxIndex procedure} -setup { + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 3 .e select to 15 .e select adjust 4 .e index anchor -} {15} -test spinbox-13.6 {GetSpinboxIndex procedure} { - list [catch {.e index ebogus} msg] $msg -} {1 {bad spinbox index "ebogus"}} -test spinbox-13.7 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {15} +test spinbox-13.6 {GetSpinboxIndex procedure} -setup { + spinbox .e +} -body { + .e index ebogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "ebogus"} +test spinbox-13.7 {GetSpinboxIndex procedure} -setup { + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update .e icursor 2 .e index insert -} {2} -test spinbox-13.8 {GetSpinboxIndex procedure} { - list [catch {.e index ibogus} msg] $msg -} {1 {bad spinbox index "ibogus"}} -test spinbox-13.9 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {2} +test spinbox-13.8 {GetSpinboxIndex procedure} -setup { + spinbox .e +} -body { + .e index ibogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "ibogus"} +test spinbox-13.9 {GetSpinboxIndex procedure} -setup { + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e +} -body { + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +} -cleanup { + destroy .e +} -result {1 6} + +test spinbox-13.10 {GetSpinboxIndex procedure} -constraints unix -body { +# On unix, when selection is cleared, spinbox widget's internal +# selection range is reset. +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index sel.first +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} + +test spinbox-13.11 {GetSpinboxIndex procedure} -constraints win -body { +# On mac and pc, when selection is cleared, spinbox widget remembers +# last selected range. When selection ownership is restored to +# spinbox, the old range will be rehighlighted. +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + catch {selection get} + .e index sel.first +} -cleanup { + destroy .e +} -result {1} + +test spinbox-13.12 {GetSpinboxIndex procedure} -constraints unix -body { +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index sbogus +} -cleanup { + destroy .e +} -returnCodes error -result {selection isn't in widget .e} + +test spinbox-13.12.1 {GetSpinboxIndex procedure} -constraints unix -body { +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index bogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "bogus"} + +test spinbox-13.13 {GetSpinboxIndex procedure} -constraints win -body { +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + .e index sbogus +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "sbogus"} + +test spinbox-13.14 {GetSpinboxIndex procedure} -constraints win -body { +# On mac and pc, when selection is cleared, spinbox widget remembers +# last selected range. When selection ownership is restored to +# spinbox, the old range will be rehighlighted. +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e select from 1 + .e select to 6 + list [.e index sel.first] [.e index sel.last] +# Testing: + selection clear .e + selection get +} -cleanup { + destroy .e +} -returnCodes error -match glob -result {*} + +test spinbox-13.14.1 {GetSpinboxIndex procedure} -constraints win -body { +# On mac and pc, when selection is cleared, spinbox widget remembers +# last selected range. When selection ownership is restored to +# spinbox, the old range will be rehighlighted. +# Previous settings: + spinbox .e -font {Courier -12} -width 5 -bd 2 -relief sunken + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e select from 1 .e select to 6 list [.e index sel.first] [.e index sel.last] -} {1 6} -selection clear .e -test spinbox-13.10 {GetSpinboxIndex procedure} unix { - # On unix, when selection is cleared, spinbox widget's internal - # selection range is reset. - - list [catch {.e index sel.first} msg] $msg -} {1 {selection isn't in widget .e}} -test spinbox-13.11 {GetSpinboxIndex procedure} win { - # On mac and pc, when selection is cleared, spinbox widget remembers - # last selected range. When selection ownership is restored to - # spinbox, the old range will be rehighlighted. - - list [catch {selection get}] [.e index sel.first] -} {1 1} -test spinbox-13.12 {GetSpinboxIndex procedure} unix { - list [catch {.e index sbogus} msg] $msg -} {1 {selection isn't in widget .e}} -test spinbox-13.13 {GetSpinboxIndex procedure} win { - list [catch {.e index sbogus} msg] $msg -} {1 {bad spinbox index "sbogus"}} -test spinbox-13.14 {GetSpinboxIndex procedure} win { - list [catch {selection get}] [catch {.e index sbogus}] -} {1 1} -test spinbox-13.15 {GetSpinboxIndex procedure} { - list [catch {.e index @xyz} msg] $msg -} {1 {bad spinbox index "@xyz"}} -test spinbox-13.16 {GetSpinboxIndex procedure} {fonts} { +# Testing: + selection clear .e + catch {selection get} + .e index sbogus +} -cleanup { + destroy .e +} -returnCodes error -match glob -result {*} + +test spinbox-13.15 {GetSpinboxIndex procedure} -body { + spinbox .e + selection clear .e + .e index @xyz +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "@xyz"} + +test spinbox-13.16 {GetSpinboxIndex procedure} -constraints fonts -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @4 -} {4} -test spinbox-13.17 {GetSpinboxIndex procedure} {fonts} { +} -cleanup { + destroy .e +} -result {4} +test spinbox-13.17 {GetSpinboxIndex procedure} -constraints fonts -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @11 -} {4} -test spinbox-13.18 {GetSpinboxIndex procedure} {fonts} { +} -cleanup { + destroy .e +} -result {4} +test spinbox-13.18 {GetSpinboxIndex procedure} -constraints fonts -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @12 -} {5} -test spinbox-13.19 {GetSpinboxIndex procedure} {fonts} { - # 11 is the minimum button width - .e index @[expr [winfo width .e] - 6 - 11] -} {8} -test spinbox-13.20 {GetSpinboxIndex procedure} {fonts} { - .e index @[expr [winfo width .e] - 5] -} {9} -test spinbox-13.21 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {5} +test spinbox-13.19 {GetSpinboxIndex procedure} -constraints fonts -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e index @[expr {[winfo width .e] - 6-11}] +} -cleanup { + destroy .e +} -result {8} +test spinbox-13.20 {GetSpinboxIndex procedure} -constraints fonts -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update + .e index @[expr {[winfo width .e] - 5}] +} -cleanup { + destroy .e +} -result {9} +test spinbox-13.21 {GetSpinboxIndex procedure} -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index @1000 -} {9} -test spinbox-13.22 {GetSpinboxIndex procedure} { - list [catch {.e index 1xyz} msg] $msg -} {1 {bad spinbox index "1xyz"}} -test spinbox-13.23 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {9} +test spinbox-13.22 {GetSpinboxIndex procedure} -setup { + spinbox .e + pack .e + update +} -body { + .e index 1xyz +} -cleanup { + destroy .e +} -returnCodes error -result {bad spinbox index "1xyz"} +test spinbox-13.23 {GetSpinboxIndex procedure} -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index -10 -} {0} -test spinbox-13.24 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {0} +test spinbox-13.24 {GetSpinboxIndex procedure} -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index 12 -} {12} -test spinbox-13.25 {GetSpinboxIndex procedure} { +} -cleanup { + destroy .e +} -result {12} +test spinbox-13.25 {GetSpinboxIndex procedure} -body { + spinbox .e -width 5 -relief sunken -highlightthickness 2 -bd 2 \ + -font {Courier -12} + pack .e + .e insert 0 012345678901234567890 + .e xview 4 + update .e index 49 -} {21} +} -cleanup { + destroy .e +} -result {21} # XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo. -set x {} -for {set i 1} {$i <= 500} {incr i} { - append x "This is line $i, out of 500\n" -} -test spinbox-14.1 {SpinboxFetchSelection procedure} { - catch {destroy .e} +test spinbox-14.1 {SpinboxFetchSelection procedure} -body { spinbox .e .e insert end "This is a test string" .e select from 1 .e select to 18 selection get -} {his is a test str} -test spinbox-14.3 {SpinboxFetchSelection procedure} { - catch {destroy .e} +} -cleanup { + destroy .e +} -result {his is a test str} +test spinbox-14.3 {SpinboxFetchSelection procedure} -setup { + set x {} + for {set i 1} {$i <= 500} {incr i} { + append x "This is line $i, out of 500\n" +} +} -body { spinbox .e - .e insert end $x + .e insert end $x .e select from 0 .e select to end string compare [selection get] $x -} 0 +} -cleanup { + destroy .e +} -result {0} -test spinbox-15.1 {SpinboxLostSelection} { - catch {destroy .e} +test spinbox-15.1 {SpinboxLostSelection} -body { spinbox .e .e insert 0 "Text" .e select from 0 @@ -1222,265 +3136,546 @@ test spinbox-15.1 {SpinboxLostSelection} { .e select from 0 .e select to 4 lappend result [selection get] -} {Text Text} - -# No tests for EventuallyRedraw. +} -cleanup { + destroy .e +} -result {Text Text} -catch {destroy .e} -spinbox .e -width 10 -xscrollcommand scroll -pack .e -update -test spinbox-16.1 {SpinboxVisibleRange procedure} {fonts} { - .e delete 0 end - .e insert 0 ............................. +test spinbox-16.1 {SpinboxVisibleRange procedure} -constraints fonts -body { + spinbox .e -width 10 -font {Helvetica -12} + pack .e + update + .e insert 0 "............................." format {%.6f %.6f} {*}[.e xview] -} {0.000000 0.827586} -test spinbox-16.2 {SpinboxVisibleRange procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.000000 0.827586} +test spinbox-16.2 {SpinboxVisibleRange procedure} -body { + spinbox .e format {%.6f %.6f} {*}[.e xview] -} {0.000000 1.000000} +} -cleanup { + destroy .e +} -result {0.000000 1.000000} -catch {destroy .e} -spinbox .e -width 10 -xscrollcommand scroll -font $fixed -pack .e -update -test spinbox-17.1 {SpinboxUpdateScrollbar procedure} { + +test spinbox-17.1 {SpinboxUpdateScrollbar procedure} -body { + spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} + pack .e .e delete 0 end .e insert 0 123 update format {%.6f %.6f} {*}$scrollInfo -} {0.000000 1.000000} -test spinbox-17.2 {SpinboxUpdateScrollbar procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.000000 1.000000} +test spinbox-17.2 {SpinboxUpdateScrollbar procedure} -body { + spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} + pack .e .e insert 0 0123456789abcdef .e xview 3 update format {%.6f %.6f} {*}$scrollInfo -} {0.187500 0.812500} -test spinbox-17.3 {SpinboxUpdateScrollbar procedure} { - .e delete 0 end +} -cleanup { + destroy .e +} -result {0.187500 0.812500} +test spinbox-17.3 {SpinboxUpdateScrollbar procedure} -body { + spinbox .e -width 10 -xscrollcommand scroll -font {Courier -12} + pack .e .e insert 0 abcdefghijklmnopqrs .e xview 6 update format {%.6f %.6f} {*}$scrollInfo -} {0.315789 0.842105} -test spinbox-17.4 {SpinboxUpdateScrollbar procedure} { +} -cleanup { destroy .e - set x "Background error did not happen" +} -result {0.315789 0.842105} +test spinbox-17.4 {SpinboxUpdateScrollbar procedure} -setup { proc bgerror msg { global x set x $msg - } +} +} -body { spinbox .e -width 5 -xscrollcommand thisisnotacommand pack .e update - rename bgerror {} list $x $errorInfo -} {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" +} -cleanup { + destroy .e + rename bgerror {} +} -result {{invalid command name "thisisnotacommand"} {invalid command name "thisisnotacommand" while executing "thisisnotacommand 0.0 1.0" (horizontal scrolling command executed by .e)}} -set l [interp hidden] -deleteWindows -test spinbox-18.1 {Spinbox widget vs hiding} { - destroy .e +test spinbox-18.1 {Spinbox widget vs hiding} -setup { spinbox .e +} -body { + set l [interp hidden] interp hide {} .e destroy .e - list [winfo children .] [interp hidden] -} [list {} $l] + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 == $res2} +} -result {1} ## ## Spinbox widget VALIDATION tests ## - -destroy .e -catch {unset ::e} -catch {unset ::vVals} -spinbox .e -validate all \ - -validatecommand [list doval %W %d %i %P %s %S %v %V] \ - -invalidcommand bell \ - -textvariable ::e \ - -background red -foreground white -pack .e -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 1 -} - # The validation tests build each one upon the previous, so cascading # failures aren't good # -test spinbox-19.1 {spinbox widget validation} { +# 19.* test cases in previous version highly depended on the previous +# test cases. This was replaced by inserting recently set configurations +# that matters for the test case +test spinbox-19.1 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e .e insert 0 a set ::vVals -} {.e 1 0 a {} a all key} -test spinbox-19.2 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e 1 0 a {} a all key} + +test spinbox-19.2 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 a ;# previous settings .e insert 1 b set ::vVals -} {.e 1 1 ab a b all key} -test spinbox-19.3 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e 1 1 ab a b all key} + +test spinbox-19.3 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 ab ;# previous settings .e insert end c set ::vVals -} {.e 1 2 abc ab c all key} -test spinbox-19.4 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e 1 2 abc ab c all key} + +test spinbox-19.4 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 abc ;# previous settings .e insert 1 123 list $::vVals $::e -} {{.e 1 1 a123bc abc 123 all key} a123bc} -test spinbox-19.5 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {{.e 1 1 a123bc abc 123 all key} a123bc} + +test spinbox-19.5 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 a123bc ;# previous settings .e delete 2 set ::vVals -} {.e 0 2 a13bc a123bc 2 all key} -test spinbox-19.6 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e 0 2 a13bc a123bc 2 all key} + +test spinbox-19.6 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 a13bc ;# previous settings .e configure -validate key .e delete 1 3 set ::vVals -} {.e 0 1 abc a13bc 13 key key} -test spinbox-19.7 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e 0 1 abc a13bc 13 key key} + +test spinbox-19.7 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focus \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abc ;# previous settings set ::vVals {} - .e configure -validate focus .e insert end d set ::vVals -} {} -test spinbox-19.8 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {} + +test spinbox-19.8 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e configure -validate focus ;# previous settings + .e insert end abcd ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update set ::vVals -} {.e -1 -1 abcd abcd {} focus focusin} -test spinbox-19.9 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focus focusin} + +test spinbox-19.9 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focus \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + focus -force .e ;# previous settings + update ;# previous settings +# update necessary to process FocusIn event focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update set ::vVals -} {.e -1 -1 abcd abcd {} focus focusout} -.e configure -validate all -test spinbox-19.10 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focus focusout} + +test spinbox-19.10 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update set ::vVals -} {.e -1 -1 abcd abcd {} all focusin} -test spinbox-19.11 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} all focusin} + +test spinbox-19.11 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + focus -force .e ;# previous settings +# update necessary to process FocusIn event + update ;# previous settings focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update set ::vVals -} {.e -1 -1 abcd abcd {} all focusout} -.e configure -validate focusin -test spinbox-19.12 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} all focusout} + +test spinbox-19.12 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focusin \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert 0 abcd ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update set ::vVals -} {.e -1 -1 abcd abcd {} focusin focusin} -test spinbox-19.13 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focusin focusin} + +test spinbox-19.13 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focusin \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings set ::vVals {} focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update set ::vVals -} {} -.e configure -validate focuso -test spinbox-19.14 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {} + +test spinbox-19.14 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + set ::vVals {} ;# previous settings focus -force .e - # update necessary to process FocusIn event +# update necessary to process FocusIn event update set ::vVals -} {} -test spinbox-19.15 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {} + +test spinbox-19.15 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + set ::vVals {} ;# previous settings + focus -force .e ;# previous settings +# update necessary to process FocusIn event + update ;# previous settings focus -force . - # update necessary to process FocusOut event +# update necessary to process FocusOut event update set ::vVals -} {.e -1 -1 abcd abcd {} focusout focusout} -test spinbox-19.16 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {.e -1 -1 abcd abcd {} focusout focusout} + +# the same as 19.16 but added [.e validate] to returned list +test spinbox-19.16 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings + set ::vVals {} ;# previous settings + focus -force .e ;# previous settings +# update necessary to process FocusIn event + update ;# previous settings + focus -force . +# update necessary to process FocusOut event + update list [.e validate] $::vVals -} {1 {.e -1 -1 abcd abcd {} all forced}} -test spinbox-19.17 {spinbox widget validation} { +} -cleanup { + destroy .e +} -result {1 {.e -1 -1 abcd abcd {} all forced}} + + +test spinbox-19.17 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate focuso \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + .e insert end abcd ;# previous settings set ::e newdata list [.e cget -validate] $::vVals -} {focusout {.e -1 -1 newdata abcd {} focusout forced}} +} -cleanup { + destroy .e +} -result {focusout {.e -1 -1 newdata abcd {} focusout forced}} -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - return 0 -} -.e configure -validate all -test spinbox-19.18 {spinbox widget validation} { +# proc doval changed - returns 0 +test spinbox-19.18 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + set ::e newdata ;# previous settings + .e configure -validate all set ::e nextdata list [.e cget -validate] $::vVals -} {none {.e -1 -1 nextdata newdata {} all forced}} +} -cleanup { + destroy .e +} -result {none {.e -1 -1 nextdata newdata {} all forced}} -proc doval {W d i P s S v V} { - set ::vVals [list $W $d $i $P $s $S $v $V] - set ::e mydata - return 1 -} -.e configure -validate all ## This sets validate to none because it shows that we prevent a possible ## loop condition in the validation, when the spinbox textvar is also set -test spinbox-19.19 {spinbox widget validation} { +# proc doval2 used +test spinbox-19.19 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval3 %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + set ::e nextdata ;# previous settings + + .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] .e validate list [.e cget -validate] [.e get] $::vVals -} {none mydata {.e -1 -1 nextdata nextdata {} all forced}} - -.e configure -validate all +} -cleanup { + destroy .e +} -result {none mydata {.e -1 -1 nextdata nextdata {} all forced}} ## This leaves validate alone because we trigger validation through the ## textvar (a write trace), and the write during validation triggers ## nothing (by definition of avoiding loops on var traces). This is ## one of those "dangerous" conditions where the user will have a ## different value in the spinbox widget shown as is in the textvar. -test spinbox-19.20 {spinbox widget validation} { +test spinbox-19.20 {spinbox widget validation} -setup { + unset -nocomplain ::e ::vVals +} -body { + spinbox .e -validate all \ + -validatecommand [list doval %W %d %i %P %s %S %v %V] \ + -invalidcommand bell \ + -textvariable ::e \ + -background red -foreground white + pack .e + set ::e nextdata ;# previous settings + .e configure -validatecommand [list doval2 %W %d %i %P %s %S %v %V] ;# prev + .e validate ;# previous settings + + .e configure -validate all set ::e testdata list [.e cget -validate] [.e get] $::e $::vVals -} {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} +} -cleanup { + destroy .e +} -result {all testdata mydata {.e -1 -1 testdata mydata {} all forced}} +## +## End validation tests +## -# A format specifier is allowed to be of the form %[-+ 0]{0,1}\d.?\d?f -# -destroy .e -spinbox .e -test spinbox-20.1 {spinbox config, -format specifier} { - list [catch {.e config -format %2f} msg] $msg -} {0 {}} -test spinbox-20.2 {spinbox config, -format specifier} { - list [catch {.e config -format %2.2f} msg] $msg -} {0 {}} -test spinbox-20.3 {spinbox config, -format specifier} { - list [catch {.e config -format %.2f} msg] $msg -} {0 {}} -test spinbox-20.4 {spinbox config, -format specifier} { - list [catch {.e config -format %2.f} msg] $msg -} {0 {}} -test spinbox-20.5 {spinbox config, -format specifier} { - list [catch {.e config -format %2e-1f} msg] $msg -} {1 {bad spinbox format specifier "%2e-1f"}} -test spinbox-20.6 {spinbox config, -format specifier} { - list [catch {.e config -format 2.2} msg] $msg -} {1 {bad spinbox format specifier "2.2"}} -test spinbox-20.7 {spinbox config, -format specifier} { - list [catch {.e config -format %2.-2f} msg] $msg -} {1 {bad spinbox format specifier "%2.-2f"}} -test spinbox-20.8 {spinbox config, -format specifier} { - list [catch {.e config -format %-2.02f} msg] $msg -} {0 {}} -test spinbox-20.9 {spinbox config, -format specifier} { - list [catch {.e config -format "% 2.02f"} msg] $msg -} {0 {}} -test spinbox-20.10 {spinbox config, -format specifier} { - list [catch {.e config -format "% -2.200f"} msg] $msg -} {0 {}} -test spinbox-20.11 {spinbox config, -format specifier} { - list [catch {.e config -format "%09.200f"} msg] $msg -} {0 {}} -test spinbox-20.12 {spinbox config, -format specifier does something} { +test spinbox-20.1 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %2f +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.2 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %2.2f +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.3 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %.2f +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.4 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %2.f +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.5 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %2e-1f +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad spinbox format specifier "%2e-1f"} +test spinbox-20.6 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format 2.2 +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad spinbox format specifier "2.2"} +test spinbox-20.7 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %2.-2f +} -cleanup { + destroy .e +} -returnCodes {error} -result {bad spinbox format specifier "%2.-2f"} +test spinbox-20.8 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format %-2.02f +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.9 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format "% 2.02f" +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.10 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format "% -2.200f" +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.11 {spinbox config, -format specifier} -body { + spinbox .e + .e config -format "%09.200f" +} -cleanup { + destroy .e +} -returnCodes ok +test spinbox-20.12 {spinbox config, -format specifier does something} -setup { + spinbox .e set out {} +} -body { .e config -format "%02.f" .e config -values {} -from 0 -to 10 -increment 1 lappend out [.e set 0]; # set currently doesn't force format @@ -1489,10 +3684,12 @@ test spinbox-20.12 {spinbox config, -format specifier does something} { lappend out [.e set 3]; # set currently doesn't force format .e config -format "%03.f" lappend out [.e set]; # changing -format should cause formatting -} {0 01 3 003} - -test spinbox-21.1 {spinbox button, out of range checking} { +} -cleanup { destroy .e +} -result {0 01 3 003} + + +test spinbox-21.1 {spinbox button, out of range checking} -body { spinbox .e -from -10 -to 20 -increment 2 set out {} lappend out [.e get]; # -10 @@ -1550,50 +3747,60 @@ test spinbox-21.1 {spinbox button, out of range checking} { lappend out [.e get]; # 18 .e invoke buttonup; # no wrap lappend out [.e get]; # 20 +} -cleanup { + destroy .e +} -result {-10 20 20 -10 -10 -10 20 20 18 -10 -10 -8 -10 -8 -10 20 18 20} -} {-10 20 20 -10 -10 -10 20 20 18 -10 -10 -8 -10 -8 -10 20 18 20} - -test spinbox-22.1 {spinbox config, -from changes SF bug 559078} { +test spinbox-22.1 {spinbox config, -from changes SF bug 559078} -body { set val 5 - destroy .s - spinbox .s -from 1 -to 10 -textvariable val + spinbox .e -from 1 -to 10 -textvariable val set val -} {5} -test spinbox-22.2 {spinbox config, -from changes SF bug 559078} { - .s configure -from 3 -to 10 +} -cleanup { + destroy .e +} -result {5} +test spinbox-22.2 {spinbox config, -from changes SF bug 559078} -body { + set val 5 + spinbox .e -from 1 -to 10 -textvariable val + .e configure -from 3 -to 10 set val -} {5} -test spinbox-22.3 {spinbox config, -from changes SF bug 559078} { - .s configure -from 6 -to 10 +} -cleanup { + destroy .e +} -result {5} +test spinbox-22.3 {spinbox config, -from changes SF bug 559078} -body { + set val 5 + spinbox .e -from 3 -to 10 -textvariable val + .e configure -from 6 -to 10 set val -} {6} - -test entry-23.1 {selection present while disabled, bug 637828} { +} -cleanup { destroy .e - entry .e +} -result {6} + +test spinbox-23.1 {selection present while disabled, bug 637828} -body { + spinbox .e .e insert end 0123456789 .e select from 3 .e select to 6 set out [.e selection present] .e configure -state disabled - # still return 1 when disabled, because 'selection get' will work, - # but selection cannot be changed (new behavior since 8.4) +# still return 1 when disabled, because 'selection get' will work, +# but selection cannot be changed (new behavior since 8.4) .e select to 9 lappend out [.e selection present] [selection get] -} {1 1 345} +} -cleanup { + destroy .e +} -result {1 1 345} -destroy .e -catch {unset ::e ::vVals} - -## -## End validation tests -## +# Collected comments about lacks from the test # XXX Still need to write tests for SpinboxBlinkProc, SpinboxFocusProc, # and SpinboxTextVarProc. +# No tests for DisplaySpinbox. +# XXX Still need to write tests for SpinboxScanTo and SpinboxSelectTo. +# No tests for EventuallyRedraw -option clear - +# option clear # cleanup cleanupTests return + + diff --git a/tests/text.test b/tests/text.test index 17fcf29..6cd1a07 100644 --- a/tests/text.test +++ b/tests/text.test @@ -6,344 +6,1443 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands namespace import -force tcltest::test -# Create entries in the option database to be sure that geometry options -# like border width have predictable values. - -option add *Text.borderWidth 2 -option add *Text.highlightThickness 2 -option add *Text.font {Courier -12} - -text .t -width 20 -height 10 -pack append . .t {top expand fill} -update -.t debug on -wm geometry . {} - # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. - +wm geometry . {} wm withdraw . wm minsize . 1 1 wm positionfrom . user wm deiconify . + +test text-1.1 {configuration option: "autoseparators"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -autoseparators yes + .t cget -autoseparators +} -cleanup { + destroy .t +} -result {1} +test text-1.2 {configuration option: "autoseparators"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -autoseparators nah +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.3 {configuration option: "background"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -background #ff00ff + .t cget -background +} -cleanup { + destroy .t +} -result {#ff00ff} +test text-1.4 {configuration option: "background"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -background <gorp> +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.5 {configuration option: "bd"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -bd 4 + .t cget -bd +} -cleanup { + destroy .t +} -result {4} +test text-1.6 {configuration option: "bd"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -bd foo +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.7 {configuration option: "bg"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -bg blue + .t cget -bg +} -cleanup { + destroy .t +} -result {blue} +test text-1.8 {configuration option: "bg"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -bg #xx +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.9 {configuration option: "blockcursor"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -blockcursor 0 + .t cget -blockcursor +} -cleanup { + destroy .t +} -result {0} +test text-1.10 {configuration option: "blockcursor"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -blockcursor xx +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.11 {configuration option: "borderwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -borderwidth 7 + .t cget -borderwidth +} -cleanup { + destroy .t +} -result {7} +test text-1.12 {configuration option: "borderwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -borderwidth ++ +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.13 {configuration option: "cursor"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -cursor watch + .t cget -cursor +} -cleanup { + destroy .t +} -result {watch} +test text-1.14 {configuration option: "cursor"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -cursor lousy +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.15 {configuration option: "exportselection"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -exportselection no + .t cget -exportselection +} -cleanup { + destroy .t +} -result {0} +test text-1.16 {configuration option: "exportselection"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -exportselection maybe +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.17 {configuration option: "fg"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -fg red + .t cget -fg +} -cleanup { + destroy .t +} -result {red} +test text-1.18 {configuration option: "fg"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -fg stupid +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.19 {configuration option: "font"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -font fixed + .t cget -font +} -cleanup { + destroy .t +} -result {fixed} +test text-1.20 {configuration option: "font"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -font {} +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.21 {configuration option: "foreground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -foreground #012 + .t cget -foreground +} -cleanup { + destroy .t +} -result {#012} +test text-1.22 {configuration option: "foreground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -foreground bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.23 {configuration option: "height"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -height 5 + .t cget -height +} -cleanup { + destroy .t +} -result {5} +test text-1.24 {configuration option: "height"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -height bad +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.25 {configuration option: "highlightbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -highlightbackground #123 + .t cget -highlightbackground +} -cleanup { + destroy .t +} -result {#123} +test text-1.26 {configuration option: "highlightbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -highlightbackground bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.27 {configuration option: "highlightcolor"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -highlightcolor #234 + .t cget -highlightcolor +} -cleanup { + destroy .t +} -result {#234} +test text-1.28 {configuration option: "highlightcolor"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -highlightcolor bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.29 {configuration option: "highlightthickness"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -highlightthickness -2 + .t cget -highlightthickness +} -cleanup { + destroy .t +} -result {0} +test text-1.30 {configuration option: "highlightthickness"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -highlightthickness bad +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.31 {configuration option: "inactiveselectbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -inactiveselectbackground #ffff01234567 + .t cget -inactiveselectbackground +} -cleanup { + destroy .t +} -result {#ffff01234567} +test text-1.32 {configuration option: "inactiveselectbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -inactiveselectbackground bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.33 {configuration option: "insertbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertbackground green + .t cget -insertbackground +} -cleanup { + destroy .t +} -result {green} +test text-1.34 {configuration option: "insertbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertbackground <bogus> +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.35 {configuration option: "insertborderwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertborderwidth 45 + .t cget -insertborderwidth +} -cleanup { + destroy .t +} -result {45} +test text-1.36 {configuration option: "insertborderwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertborderwidth bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.37 {configuration option: "insertofftime"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertofftime 100 + .t cget -insertofftime +} -cleanup { + destroy .t +} -result {100} +test text-1.38 {configuration option: "insertofftime"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertofftime 2.4 +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.39 {configuration option: "insertontime"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertontime 47 + .t cget -insertontime +} -cleanup { + destroy .t +} -result {47} +test text-1.40 {configuration option: "insertontime"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertontime e1 +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.41 {configuration option: "insertwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertwidth 2.3 + .t cget -insertwidth +} -cleanup { + destroy .t +} -result {2} +test text-1.42 {configuration option: "insertwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertwidth 47d +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.43 {configuration option: "maxundo"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -maxundo 5 + .t cget -maxundo +} -cleanup { + destroy .t +} -result {5} +test text-1.44 {configuration option: "maxundo"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -maxundo noway +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.45 {configuration option: "padx"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -padx 3.4 + .t cget -padx +} -cleanup { + destroy .t +} -result {3} +test text-1.46 {configuration option: "padx"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -padx 2.4. +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.47 {configuration option: "pady"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -pady 82 + .t cget -pady +} -cleanup { + destroy .t +} -result {82} +test text-1.48 {configuration option: "pady"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -pady bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.49 {configuration option: "relief"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -relief raised + .t cget -relief +} -cleanup { + destroy .t +} -result {raised} +test text-1.50 {configuration option: "relief"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -relief bumpy +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.51 {configuration option: "selectbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -selectbackground #ffff01234567 + .t cget -selectbackground +} -cleanup { + destroy .t +} -result {#ffff01234567} +test text-1.52 {configuration option: "selectbackground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -selectbackground bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.53 {configuration option: "selectborderwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -selectborderwidth 21 + .t cget -selectborderwidth +} -cleanup { + destroy .t +} -result {21} +test text-1.54 {configuration option: "selectborderwidth"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -selectborderwidth 3x +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.55 {configuration option: "selectforeground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -selectforeground yellow + .t cget -selectforeground +} -cleanup { + destroy .t +} -result {yellow} +test text-1.56 {configuration option: "selectforeground"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -selectforeground #12345 +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.57 {configuration option: "spacing1"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing1 20 + .t cget -spacing1 +} -cleanup { + destroy .t +} -result {20} +test text-1.58 {configuration option: "spacing1"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing1 1.3x +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.59 {configuration option: "spacing1"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing1 -5 + .t cget -spacing1 +} -cleanup { + destroy .t +} -result {0} +test text-1.60 {configuration option: "spacing1"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing1 bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.61 {configuration option: "spacing2"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing2 5 + .t cget -spacing2 +} -cleanup { + destroy .t +} -result {5} +test text-1.62 {configuration option: "spacing2"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing2 bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.63 {configuration option: "spacing2"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing2 -1 + .t cget -spacing2 +} -cleanup { + destroy .t +} -result {0} +test text-1.64 {configuration option: "spacing2"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing2 bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.65 {configuration option: "spacing3"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing3 20 + .t cget -spacing3 +} -cleanup { + destroy .t +} -result {20} +test text-1.66 {configuration option: "spacing3"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing3 bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.67 {configuration option: "spacing3"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing3 -10 + .t cget -spacing3 +} -cleanup { + destroy .t +} -result {0} +test text-1.68 {configuration option: "spacing3"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -spacing3 bogus +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.69 {configuration option: "state"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -state d + .t cget -state +} -cleanup { + destroy .t +} -result {disabled} +test text-1.70 {configuration option: "state"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -state foo +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.71 {configuration option: "tabs"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -tabs {1i 2i 3i 4i} + .t cget -tabs +} -cleanup { + destroy .t +} -result {1i 2i 3i 4i} +test text-1.72 {configuration option: "tabs"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -tabs bad_tabs +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.73 {configuration option: "tabstyle"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -tabstyle wordprocessor + .t cget -tabstyle +} -cleanup { + destroy .t +} -result {wordprocessor} +test text-1.74 {configuration option: "tabstyle"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -tabstyle garbage +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.75 {configuration option: "undo"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -undo 1 + .t cget -undo +} -cleanup { + destroy .t +} -result {1} +test text-1.76 {configuration option: "undo"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -undo eh +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.77 {configuration option: "width"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -width 73 + .t cget -width +} -cleanup { + destroy .t +} -result {73} +test text-1.78 {configuration option: "width"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -width 2.4 +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.79 {configuration option: "wrap"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -wrap w + .t cget -wrap +} -cleanup { + destroy .t +} -result {word} +test text-1.80 {configuration option: "wrap"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -wrap bad_wrap +} -cleanup { + destroy .t +} -match glob -returnCodes {error} -result {*} +test text-1.81 {text options} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -takefocus "any old thing" + .t cget -takefocus +} -cleanup { + destroy .t +} -result {any old thing} +test text-1.82 {text options} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -xscrollcommand "x scroll command" + .t configure -xscrollcommand +} -cleanup { + destroy .t +} -result {-xscrollcommand xScrollCommand ScrollCommand {} {x scroll command}} +test text-1.83 {text options} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -yscrollcommand "test command" + .t configure -yscrollcommand +} -cleanup { + destroy .t +} -result {-yscrollcommand yScrollCommand ScrollCommand {} {test command}} +test text-1.83.1 {configuration option: "insertunfocussed"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertunfocussed none + .t cget -insertunfocussed +} -cleanup { + destroy .t +} -result none +test text-1.84 {configuration option: "insertunfocussed"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertunfocussed hollow + .t cget -insertunfocussed +} -cleanup { + destroy .t +} -result hollow +test text-1.85 {configuration option: "insertunfocussed"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -body { + .t configure -insertunfocussed solid + .t cget -insertunfocussed +} -cleanup { + destroy .t +} -result solid +test text-1.86 {configuration option: "insertunfocussed"} -setup { + text .t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} + pack .t + update +} -returnCodes error -body { + .t configure -insertunfocussed gorp +} -cleanup { + destroy .t +} -result {bad insertunfocussed "gorp": must be hollow, none, or solid} + + +test text-2.1 {Tk_TextCmd procedure} -body { + text +} -returnCodes {error} -result {wrong # args: should be "text pathName ?-option value ...?"} +test text-2.2 {Tk_TextCmd procedure} -body { + text foobar +} -returnCodes {error} -result {bad window path name "foobar"} +test text-2.3 {Tk_TextCmd procedure} -body { + text .t -gorp nofun +} -cleanup { + destroy .t +} -returnCodes {error} -result {unknown option "-gorp"} +test text-2.4 {Tk_TextCmd procedure} -body { + catch {text .t -gorp nofun} + winfo exists .t +} -cleanup { + destroy .t +} -result 0 +test text-2.5 {Tk_TextCmd procedure} -body { + text .t -bd 2 -fg red +} -cleanup { + destroy .t +} -returnCodes ok -result {.t} +test text-2.6 {Tk_TextCmd procedure} -body { + text .t -bd 2 -fg red + list [lindex [.t config -bd] 4] [lindex [.t config -fg] 4] +} -cleanup { + destroy .t +} -result {2 red} +test text-2.7 {Tk_TextCmd procedure} -constraints { + win +} -body { + catch {destroy .t} + text .t + .t tag cget sel -relief +} -cleanup { + destroy .t +} -result {flat} +test text-2.8 {Tk_TextCmd procedure} -constraints { + aqua +} -body { + catch {destroy .t} + text .t + .t tag cget sel -relief +} -cleanup { + destroy .t +} -result {solid} +test text-2.9 {Tk_TextCmd procedure} -constraints { + unix +} -body { + catch {destroy .t} + text .t + .t tag cget sel -relief +} -cleanup { + destroy .t +} -result {raised} +test text-2.10 {Tk_TextCmd procedure} -body { + list [text .t] [winfo class .t] +} -cleanup { + destroy .t +} -result {.t Text} + + +test text-3.1 {TextWidgetCmd procedure, basics} -setup { + text .t +} -body { + .t +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t option ?arg ...?"} +test text-3.2 {TextWidgetCmd procedure} -setup { + text .t +} -body { + .t gorp 1.0 z 1.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} + +test text-4.1 {TextWidgetCmd procedure, "bbox" option} -setup { + text .t +} -body { + .t bbox +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t bbox index"} +test text-4.2 {TextWidgetCmd procedure, "bbox" option} -setup { + text .t +} -body { + .t bbox a b +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t bbox index"} +test text-4.3 {TextWidgetCmd procedure, "bbox" option} -setup { + text .t +} -body { + .t bbox bad_mark +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "bad_mark"} + +test text-5.1 {TextWidgetCmd procedure, "cget" option} -setup { + text .t +} -body { + .t cget +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t cget option"} +test text-5.2 {TextWidgetCmd procedure, "cget" option} -setup { + text .t +} -body { + .t cget a b +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t cget option"} +test text-5.3 {TextWidgetCmd procedure, "cget" option} -setup { + text .t +} -body { + .t cget -gorp +} -cleanup { + destroy .t +} -returnCodes {error} -result {unknown option "-gorp"} +test text-5.4 {TextWidgetCmd procedure, "cget" option} -setup { + text .t +} -body { + .t configure -bd 17 + .t cget -bd +} -cleanup { + destroy .t +} -result {17} -entry .t.e -.t.e insert end abcdefg -.t.e select from 0 -.t insert 1.0 "Line 1 +test text-6.1 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t compare a b +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t compare index1 op index2"} +test text-6.2 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t compare a b c d +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t compare index1 op index2"} +test text-6.3 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t compare @x == 1.0 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@x"} +test text-6.4 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t compare 1.0 < @y +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@y"} +test text-6.5 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 abcdefghijklm 12345 Line 4 bOy GIrl .#@? x_yz !@#$% Line 7" - -catch {destroy .t2} -text .t2 -set i 0 -foreach test { - {-autoseparators yes 1 nah} - {-background #ff00ff #ff00ff <gorp>} - {-bd 4 4 foo} - {-bg blue blue #xx} - {-blockcursor 0 0 xx} - {-borderwidth 7 7 ++} - {-cursor watch watch lousy} - {-exportselection no 0 maybe} - {-fg red red stupid} - {-font fixed fixed {}} - {-foreground #012 #012 bogus} - {-height 5 5 bad} - {-highlightbackground #123 #123 bogus} - {-highlightcolor #234 #234 bogus} - {-highlightthickness -2 0 bad} - {-inactiveselectbackground #ffff01234567 #ffff01234567 bogus} - {-insertbackground green green <bogus>} - {-insertborderwidth 45 45 bogus} - {-insertofftime 100 100 2.4} - {-insertontime 47 47 e1} - {-insertwidth 2.3 2 47d} - {-maxundo 5 5 noway} - {-padx 3.4 3 2.4.} - {-pady 82 82 bogus} - {-relief raised raised bumpy} - {-selectbackground #ffff01234567 #ffff01234567 bogus} - {-selectborderwidth 21 21 3x} - {-selectforeground yellow yellow #12345} - {-spacing1 20 20 1.3x} - {-spacing1 -5 0 bogus} - {-spacing2 5 5 bogus} - {-spacing2 -1 0 bogus} - {-spacing3 20 20 bogus} - {-spacing3 -10 0 bogus} - {-state d disabled foo} - {-tabs {1i 2i 3i 4i} {1i 2i 3i 4i} bad_tabs} - {-tabstyle wordprocessor wordprocessor garbage} - {-undo 1 1 eh} - {-width 73 73 2.4} - {-wrap w word bad_wrap} -} { - test text-1.[incr i] {text options} { - set result {} - lappend result [catch {.t2 configure [lindex $test 0] [lindex $test 3]}] - .t2 configure [lindex $test 0] [lindex $test 1] - lappend result [.t2 cget [lindex $test 0]] - } [list 1 [lindex $test 2]] -} -test text-1.[incr i] {text options} { - .t2 configure -takefocus "any old thing" - .t2 cget -takefocus -} {any old thing} -test text-1.[incr i] {text options} { - .t2 configure -xscrollcommand "x scroll command" - .t2 configure -xscrollcommand -} {-xscrollcommand xScrollCommand ScrollCommand {} {x scroll command}} -test text-1.[incr i] {text options} { - .t2 configure -yscrollcommand "test command" - .t2 configure -yscrollcommand -} {-yscrollcommand yScrollCommand ScrollCommand {} {test command}} -test text-1.[incr i] {text options} { - set result {} - foreach i [.t2 configure] { - lappend result [lindex $i 4] - } - set result -} {1 blue {} {} 0 7 watch {} 0 {} fixed #012 5 #123 #234 0 #ffff01234567 green 45 100 47 2 5 3 82 raised #ffff01234567 21 yellow 0 0 0 0 {} disabled {1i 2i 3i 4i} wordprocessor {any old thing} 1 73 word {x scroll command} {test command}} - -test text-2.1 {Tk_TextCmd procedure} { - list [catch {text} msg] $msg -} {1 {wrong # args: should be "text pathName ?options?"}} -test text-2.2 {Tk_TextCmd procedure} { - list [catch {text foobar} msg] $msg -} {1 {bad window path name "foobar"}} -test text-2.3 {Tk_TextCmd procedure} { - catch {destroy .t2} - list [catch {text .t2 -gorp nofun} msg] $msg [winfo exists .t2] -} {1 {unknown option "-gorp"} 0} -test text-2.4 {Tk_TextCmd procedure} { - catch {destroy .t2} - list [catch {text .t2 -bd 2 -fg red} msg] $msg \ - [lindex [.t2 config -bd] 4] [lindex [.t2 config -fg] 4] -} {0 .t2 2 red} -if {$tcl_platform(platform) == "windows"} { - set relief flat -} elseif {[tk windowingsystem] eq "aqua"} { - set relief solid -} else { - set relief raised -} -test text-2.5 {Tk_TextCmd procedure} { - catch {destroy .t2} - text .t2 - .t2 tag cget sel -relief -} $relief -test text-2.6 {Tk_TextCmd procedure} { - catch {destroy .t2} - list [text .t2] [winfo class .t2] -} {.t2 Text} - -test text-3.1 {TextWidgetCmd procedure, basics} { - list [catch {.t} msg] $msg -} {1 {wrong # args: should be ".t option ?arg arg ...?"}} -test text-3.2 {TextWidgetCmd procedure} { - list [catch {.t gorp 1.0 z 1.2} msg] $msg -} {1 {bad option "gorp": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} - -test text-4.1 {TextWidgetCmd procedure, "bbox" option} { - list [catch {.t bbox} msg] $msg -} {1 {wrong # args: should be ".t bbox index"}} -test text-4.2 {TextWidgetCmd procedure, "bbox" option} { - list [catch {.t bbox a b} msg] $msg -} {1 {wrong # args: should be ".t bbox index"}} -test text-4.3 {TextWidgetCmd procedure, "bbox" option} { - list [catch {.t bbox bad_mark} msg] $msg -} {1 {bad text index "bad_mark"}} - -test text-5.1 {TextWidgetCmd procedure, "cget" option} { - list [catch {.t cget} msg] $msg -} {1 {wrong # args: should be ".t cget option"}} -test text-5.2 {TextWidgetCmd procedure, "cget" option} { - list [catch {.t cget a b} msg] $msg -} {1 {wrong # args: should be ".t cget option"}} -test text-5.3 {TextWidgetCmd procedure, "cget" option} { - list [catch {.t cget -gorp} msg] $msg -} {1 {unknown option "-gorp"}} -test text-5.4 {TextWidgetCmd procedure, "cget" option} { - .t configure -bd 17 - .t cget -bd -} {17} -.t configure -bd [lindex [.t configure -bd] 3] - -test text-6.1 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare a b} msg] $msg -} {1 {wrong # args: should be ".t compare index1 op index2"}} -test text-6.2 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare a b c d} msg] $msg -} {1 {wrong # args: should be ".t compare index1 op index2"}} -test text-6.3 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare @x == 1.0} msg] $msg -} {1 {bad text index "@x"}} -test text-6.4 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare 1.0 < @y} msg] $msg -} {1 {bad text index "@y"}} -test text-6.5 {TextWidgetCmd procedure, "compare" option} { list [.t compare 1.1 < 1.0] [.t compare 1.1 < 1.1] [.t compare 1.1 < 1.2] -} {0 0 1} -test text-6.6 {TextWidgetCmd procedure, "compare" option} { +} -cleanup { + destroy .t +} -result {0 0 1} +test text-6.6 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" list [.t compare 1.1 <= 1.0] [.t compare 1.1 <= 1.1] [.t compare 1.1 <= 1.2] -} {0 1 1} -test text-6.7 {TextWidgetCmd procedure, "compare" option} { +} -cleanup { + destroy .t +} -result {0 1 1} +test text-6.7 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" list [.t compare 1.1 == 1.0] [.t compare 1.1 == 1.1] [.t compare 1.1 == 1.2] -} {0 1 0} -test text-6.8 {TextWidgetCmd procedure, "compare" option} { +} -cleanup { + destroy .t +} -result {0 1 0} +test text-6.8 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" list [.t compare 1.1 >= 1.0] [.t compare 1.1 >= 1.1] [.t compare 1.1 >= 1.2] -} {1 1 0} -test text-6.9 {TextWidgetCmd procedure, "compare" option} { +} -cleanup { + destroy .t +} -result {1 1 0} +test text-6.9 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" list [.t compare 1.1 > 1.0] [.t compare 1.1 > 1.1] [.t compare 1.1 > 1.2] -} {1 0 0} -test text-6.10 {TextWidgetCmd procedure, "compare" option} { +} -cleanup { + destroy .t +} -result {1 0 0} +test text-6.10 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" list [.t com 1.1 != 1.0] [.t compare 1.1 != 1.1] [.t compare 1.1 != 1.2] -} {1 0 1} -test text-6.11 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare 1.0 <x 1.2} msg] $msg -} {1 {bad comparison operator "<x": must be <, <=, ==, >=, >, or !=}} -test text-6.12 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare 1.0 >> 1.2} msg] $msg -} {1 {bad comparison operator ">>": must be <, <=, ==, >=, >, or !=}} -test text-6.13 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t compare 1.0 z 1.2} msg] $msg -} {1 {bad comparison operator "z": must be <, <=, ==, >=, >, or !=}} -test text-6.14 {TextWidgetCmd procedure, "compare" option} { - list [catch {.t co 1.0 z 1.2} msg] $msg -} {1 {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} - +} -cleanup { + destroy .t +} -result {1 0 1} +test text-6.11 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t compare 1.0 <x 1.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad comparison operator "<x": must be <, <=, ==, >=, >, or !=} +test text-6.12 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t compare 1.0 >> 1.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad comparison operator ">>": must be <, <=, ==, >=, >, or !=} +test text-6.13 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t compare 1.0 z 1.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad comparison operator "z": must be <, <=, ==, >=, >, or !=} +test text-6.14 {TextWidgetCmd procedure, "compare" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t co 1.0 z 1.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {ambiguous option "co": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} # "configure" option is already covered above -test text-7.1 {TextWidgetCmd procedure, "debug" option} { - list [catch {.t debug 0 1} msg] $msg -} {1 {wrong # args: should be ".t debug boolean"}} -test text-7.2 {TextWidgetCmd procedure, "debug" option} { - list [catch {.t de 0 1} msg] $msg -} {1 {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} -test text-7.3 {TextWidgetCmd procedure, "debug" option} { +test text-7.1 {TextWidgetCmd procedure, "debug" option} -setup { + text .t +} -body { + .t debug 0 1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t debug boolean"} +test text-7.2 {TextWidgetCmd procedure, "debug" option} -setup { + text .t +} -body { + .t de 0 1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {ambiguous option "de": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} +test text-7.3 {TextWidgetCmd procedure, "debug" option} -setup { + text .t +} -body { .t debug true .t deb -} 1 -test text-7.4 {TextWidgetCmd procedure, "debug" option} { +} -cleanup { + destroy .t +} -result {1} +test text-7.4 {TextWidgetCmd procedure, "debug" option} -setup { + text .t +} -body { .t debug false .t debug -} 0 -.t debug - -test text-8.1 {TextWidgetCmd procedure, "delete" option} { - list [catch {.t delete} msg] $msg -} {1 {wrong # args: should be ".t delete index1 ?index2 ...?"}} -test text-8.2 {TextWidgetCmd procedure, "delete" option} { - list [catch {.t delete a b c} msg] $msg -} {1 {bad text index "a"}} -test text-8.3 {TextWidgetCmd procedure, "delete" option} { - list [catch {.t delete @x 2.2} msg] $msg -} {1 {bad text index "@x"}} -test text-8.4 {TextWidgetCmd procedure, "delete" option} { - list [catch {.t delete 2.3 @y} msg] $msg -} {1 {bad text index "@y"}} -test text-8.5 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {0} + + +test text-8.1 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t delete +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t delete index1 ?index2 ...?"} +test text-8.2 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t delete a b c +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "a"} +test text-8.3 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t delete @x 2.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@x"} +test text-8.4 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345" + .t delete 2.3 @y +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@y"} +test text-8.5 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t configure -state disabled .t delete 2.3 .t g 2.0 2.end -} abcdefghijklm -.t configure -state normal -test text-8.6 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {abcdefghijklm} +test text-8.6 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t delete 2.3 .t get 2.0 2.end -} abcefghijklm -test text-8.7 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {abcefghijklm} +test text-8.7 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t delete 2.1 2.3 .t get 2.0 2.end -} aefghijklm -test text-8.8 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {adefghijklm} +test text-8.8 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345" # All indices are checked before we actually delete anything - list [catch {.t delete 2.1 2.3 foo} msg] $msg \ - [.t get 2.0 2.end] -} {1 {bad text index "foo"} aefghijklm} -set prevtext [.t get 1.0 end-1c] -test text-8.9 {TextWidgetCmd procedure, "delete" option} { + .t delete 2.1 2.3 foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "foo"} +test text-8.9 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345" +# All indices are checked before we actually delete anything + catch {.t delete 2.1 2.3 foo} + .t get 2.0 2.end +} -cleanup { + destroy .t +} -result {abcdefghijklm} +test text-8.10 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" # auto-forward one byte if the last "pair" is just one - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t delete 1.0 end + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.1 2.3 2.3 .t get 1.0 end-1c -} foo\naefghijklm -test text-8.10 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {foo +aefghijklm} +test text-8.11 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # all indices will be ordered before deletion - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.3 2.7 2.9 2.4 .t get 1.0 end-1c -} foo\ndfgjklm -test text-8.11 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {foo +dfgjklm} +test text-8.12 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # and check again with even pairs - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.2 2.7 2.9 2.4 2.5 .t get 1.0 end-1c -} foo\ncdfgjklm -test text-8.12 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {foo +cdfgjklm} +test text-8.13 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # we should get the longest range on equal start indices - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.2 2.0 2.5 2.0 2.3 2.8 2.7 .t get 1.0 end-1c -} foo\nfghijklm -test text-8.13 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {foo +fghijklm} +test text-8.14 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # we should get the longest range on equal start indices - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.2 1.2 2.6 2.0 2.5 .t get 1.0 end-1c -} foghijklm -test text-8.14 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {foghijklm} +test text-8.15 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # we should get the longest range on equal start indices - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.2 2.0 2.5 1.1 2.3 2.8 2.7 .t get 1.0 end-1c -} ffghijklm -test text-8.15 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {ffghijklm} +test text-8.16 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # we should get the watch for overlapping ranges - they should # essentially be merged into one span. - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.6 2.2 2.8 .t get 1.0 end-1c -} foo\nijklm -test text-8.16 {TextWidgetCmd procedure, "delete" option} { +} -cleanup { + destroy .t +} -result {foo +ijklm} +test text-8.17 {TextWidgetCmd procedure, "delete" option} -setup { + text .t +} -body { # we should get the watch for overlapping ranges - they should # essentially be merged into one span. - .t delete 1.0 end; .t insert 1.0 "foo\nabcdefghijklm" + .t insert 1.0 "foo\nabcdefghijklm" .t delete 2.0 2.6 2.2 2.4 .t get 1.0 end-1c -} foo\nghijklm -.t delete 1.0 end; .t insert 1.0 $prevtext -test text-8.17 {TextWidgetCmd procedure, "replace" option} { - list [catch {.t replace 1.3 2.3} err] $err -} {1 {wrong # args: should be ".t replace index1 index2 chars ?tagList chars tagList ...?"}} -test text-8.18 {TextWidgetCmd procedure, "replace" option} { - list [catch {.t replace 3.1 2.3 foo} err] $err -} {1 {Index "2.3" before "3.1" in the text}} -test text-8.19 {TextWidgetCmd procedure, "replace" option} { - list [catch {.t replace 2.1 2.3 foo} err] $err -} {0 {}} -.t delete 1.0 end; .t insert 1.0 $prevtext -test text-8.20 {TextWidgetCmd procedure, "replace" option with undo} { +} -cleanup { + destroy .t +} -result {foo +ghijklm} +test text-8.18 {TextWidgetCmd procedure, "replace" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345" + .t replace 1.3 2.3 +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t replace index1 index2 chars ?tagList chars tagList ...?"} +test text-8.19 {TextWidgetCmd procedure, "replace" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345" + .t replace 3.1 2.3 foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {Index "2.3" before "3.1" in the text} +test text-8.20 {TextWidgetCmd procedure, "replace" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t replace 2.1 2.3 foo +} -cleanup { + destroy .t +} -returnCodes ok -result {} +test text-8.21 {TextWidgetCmd procedure, "replace" option with undo} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +abcdefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + set prevtext [.t get 1.0 end-1c] .t configure -undo 0 .t configure -undo 1 # Ensure it is treated as a single undo action .t replace 2.1 2.3 foo .t edit undo - .t configure -undo 0 string equal [.t get 1.0 end-1c] $prevtext -} {1} -test text-8.21 {TextWidgetCmd procedure, "replace" option with undo} { +} -cleanup { + destroy .t +} -result {1} +test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} -setup { + text .t + set res {} +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t configure -undo 0 .t configure -undo 1 .t replace 2.1 2.3 foo @@ -352,15 +1451,25 @@ test text-8.21 {TextWidgetCmd procedure, "replace" option with undo} { # to do this, then we should be able to change this test. The # behaviour tested for here is not, strictly speaking, documented. rename .t test.t - set res {} proc .t {args} { lappend ::res $args ; uplevel 1 test.t $args } .t edit undo + return $res +} -cleanup { rename .t {} rename test.t .t - .t configure -undo 0 - set res -} {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}} -test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} { + destroy .t +} -result {{edit undo} {delete 2.1 2.4} {mark set insert 2.1} {see insert} {insert 2.1 ef} {mark set insert 2.3} {see insert}} +test text-8.23 {TextWidgetCmd procedure, "replace" option with undo} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + set prevtext [.t get 1.0 end-1c] .t configure -undo 0 .t configure -undo 1 # Ensure that undo (even composite undo like 'replace') @@ -370,330 +1479,1150 @@ test text-8.22 {TextWidgetCmd procedure, "replace" option with undo} { .t edit undo .t configure -start {} -end {} .t configure -undo 0 - if {![string equal [.t get 1.0 end-1c] $prevtext]} { - set res [list [.t get 1.0 end-1c] ne $prevtext] - } else { - set res 1 - } -} {1} -.t delete 1.0 end; .t insert 1.0 $prevtext -test text-8.23 {TextWidgetCmd procedure, "replace" option with peers, undo} { + string equal [.t get 1.0 end-1c] $prevtext +} -cleanup { + destroy .t +} -result {1} +test text-8.24 {TextWidgetCmd procedure, "replace" option with peers, undo} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + set prevtext [.t get 1.0 end-1c] .t configure -undo 0 .t configure -undo 1 .t peer create .tt -undo 1 - # Ensure that undo (even composite undo like 'replace') - # works when the the event took place in one peer, which - # is then deleted, before the undo takes place in another peer. +# Ensure that undo (even composite undo like 'replace') +# works when the the event took place in one peer, which +# is then deleted, before the undo takes place in another peer. .tt replace 2.1 2.3 foo .tt configure -start 1 -end 1 destroy .tt .t edit undo .t configure -start {} -end {} .t configure -undo 0 - if {![string equal [.t get 1.0 end-1c] $prevtext]} { - set res [list [.t get 1.0 end-1c] ne $prevtext] - } else { - set res 1 - } -} {1} -.t delete 1.0 end; .t insert 1.0 $prevtext -test text-8.24 {TextWidgetCmd procedure, "replace" option with peers, undo} { + string equal [.t get 1.0 end-1c] $prevtext +} -cleanup { + destroy .t +} -result {1} +test text-8.25 {TextWidgetCmd procedure, "replace" option with peers, undo} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + set prevtext [.t get 1.0 end-1c] .t configure -undo 0 .t configure -undo 1 .t peer create .tt -undo 1 - # Ensure that undo (even composite undo like 'replace') - # works when the the event took place in one peer, which - # is then deleted, before the undo takes place in another peer - # which isn't showing everything. +# Ensure that undo (even composite undo like 'replace') +# works when the the event took place in one peer, which +# is then deleted, before the undo takes place in another peer +# which isn't showing everything. .tt replace 2.1 2.3 foo set res [.tt get 2.1 2.4] .tt configure -start 1 -end 1 destroy .tt .t configure -start 3 -end 4 - # msg will actually be set to a silently ignored error message here, - # (that the .tt command doesn't exist), but that is not important. - lappend res [catch {.t edit undo} msg] +# msg will actually be set to a silently ignored error message here, +# (that the .tt command doesn't exist), but that is not important. + lappend res [catch {.t edit undo}] .t configure -undo 0 .t configure -start {} -end {} - if {![string equal [.t get 1.0 end-1c] $prevtext]} { - lappend res [list [.t get 1.0 end-1c] ne $prevtext] - } else { - lappend res 1 - } -} {foo 0 1} -test text-8.25 {TextWidgetCmd procedure, "replace" option crash} -setup { - destroy .tt -} -body { + lappend res [string equal [.t get 1.0 end-1c] $prevtext] +} -cleanup { + destroy .t +} -result {foo 0 1} +test text-8.26 {TextWidgetCmd procedure, "replace" option crash} -setup { text .tt +} -body { .tt insert 0.0 foo\n .tt replace end-1l end bar } -cleanup { destroy .tt } -result {} -.t delete 1.0 end; .t insert 1.0 $prevtext - -test text-9.1 {TextWidgetCmd procedure, "get" option} { - list [catch {.t get} msg] $msg -} {1 {wrong # args: should be ".t get ?-displaychars? ?--? index1 ?index2 ...?"}} -test text-9.2 {TextWidgetCmd procedure, "get" option} { - list [catch {.t get a b c} msg] $msg -} {1 {bad text index "a"}} -test text-9.3 {TextWidgetCmd procedure, "get" option} { - list [catch {.t get @q 3.1} msg] $msg -} {1 {bad text index "@q"}} -test text-9.4 {TextWidgetCmd procedure, "get" option} { - list [catch {.t get 3.1 @r} msg] $msg -} {1 {bad text index "@r"}} -test text-9.5 {TextWidgetCmd procedure, "get" option} { + +test text-9.1 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t get +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t get ?-displaychars? ?--? index1 ?index2 ...?"} +test text-9.2 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t get a b c +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "a"} +test text-9.3 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t get @q 3.1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@q"} +test text-9.4 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t get 3.1 @r +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@r"} +test text-9.5 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.7 5.3 -} {} -test text-9.6 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {} +test text-9.6 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.3 5.5 -} { G} -test text-9.7 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result { G} +test text-9.7 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.3 end -} { GIrl .#@? x_yz +} -cleanup { + destroy .t +} -result { GIrl .#@? x_yz !@#$% Line 7 } -.t mark set a 5.3 -.t mark set b 5.3 -.t mark set c 5.5 -test text-9.8 {TextWidgetCmd procedure, "get" option} { +test text-9.8 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.7 -} {y GIr} -test text-9.9 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {y GIr} +test text-9.9 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 -} {y} -test text-9.10 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {y} +test text-9.10 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.4 -} {y } -test text-9.11 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {y } +test text-9.11 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.4 5.4 -} {{y } G} -test text-9.12 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {{y } G} +test text-9.12 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.4 5.4 5.5 -} {{y } G} -test text-9.13 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {{y } G} +test text-9.13 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.4 5.5 "5.5+5c" -} {{y } {Irl .}} -test text-9.14 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {{y } {Irl .}} +test text-9.14 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.4 5.4 5.5 end-3c -} {{y } G { }} -test text-9.15 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {{y } G { }} +test text-9.15 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.4 5.4 5.5 end-3c end -} {{y } G { 7 +} -cleanup { + destroy .t +} -result {{y } G { 7 }} -test text-9.16 {TextWidgetCmd procedure, "get" option} { +test text-9.16 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t get 5.2 5.3 5.4 5.3 -} {y} -test text-9.17 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {y} +test text-9.17 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t index "5.2 +3 indices" -} {5.5} -test text-9.17a {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.5} +test text-9.18 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t index "5.2 +3chars" -} {5.5} -test text-9.17b {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.5} +test text-9.19 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t index "5.2 +3displayindices" -} {5.5} -.t tag configure elide -elide 1 -.t tag add elide 5.2 5.4 -test text-9.18 {TextWidgetCmd procedure, "get" option} { - list [catch {.t get 5.2 5.4 5.5 foo} msg] $msg -} {1 {bad text index "foo"}} -test text-9.19 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.5} +test text-9.20 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 + .t get 5.2 5.4 5.5 foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "foo"} +test text-9.21 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 .t get 5.2 5.4 5.4 5.5 end-3c end -} {{y } G { 7 +} -cleanup { + destroy .t +} -result {{y } G { 7 }} -test text-9.20 {TextWidgetCmd procedure, "get" option} { +test text-9.22 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 .t get -displaychars 5.2 5.4 5.4 5.5 end-3c end -} {{} G { 7 +} -cleanup { + destroy .t +} -result {{} G { 7 }} -test text-9.21 {TextWidgetCmd procedure, "get" option} { +test text-9.23 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 list [.t index "5.1 +4indices"] [.t index "5.1+4d indices"] -} {5.5 5.7} -test text-9.22 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.5 5.7} +test text-9.24 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 list [.t index "5.1 +4a chars"] [.t index "5.1+4d chars"] -} {5.5 5.7} -test text-9.23 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.5 5.7} +test text-9.25 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 list [.t index "5.5 -4indices"] [.t index "5.7-4d indices"] -} {5.1 5.1} -test text-9.24 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.1 5.1} +test text-9.26 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 list [.t index "5.5 -4a chars"] [.t index "5.7-4d chars"] -} {5.1 5.1} -.t window create 5.4 -test text-9.25 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.1 5.1} +test text-9.27 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 + .t window create 5.4 list [.t index "5.1 +4indices"] [.t index "5.1+4d indices"] -} {5.5 5.7} -test text-9.25a {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.5 5.7} +test text-9.28 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 + .t window create 5.4 list [.t index "5.1 +4a chars"] [.t index "5.1+4d chars"] -} {5.6 5.8} -test text-9.26 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.6 5.8} +test text-9.29 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 + .t window create 5.4 list [.t index "5.5 -4indices"] [.t index "5.7-4d indices"] -} {5.1 5.1} -test text-9.26a {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.1 5.1} +test text-9.30 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 + .t window create 5.4 list [.t index "5.6 -4a chars"] [.t index "5.8-4d chars"] -} {5.1 5.1} -.t delete 5.4 -.t tag add elide 5.5 5.6 -test text-9.27 {TextWidgetCmd procedure, "get" option} { +} -cleanup { + destroy .t +} -result {5.1 5.1} +test text-9.31 {TextWidgetCmd procedure, "get" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 5.2 5.4 + .t window create 5.4 + .t delete 5.4 + .t tag add elide 5.5 5.6 .t get -displaychars 5.2 5.8 -} {Grl} -.t tag delete elide -.t mark unset a -.t mark unset b -.t mark unset c -test text-9.2.1 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count} msg] $msg -} {1 {wrong # args: should be ".t count ?options? index1 index2"}} -test text-9.2.2.1 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count blah 1.0 2.0} msg] $msg -} {1 {bad option "blah" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels}} -test text-9.2.2 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count a b} msg] $msg -} {1 {bad text index "a"}} -test text-9.2.3 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count @q 3.1} msg] $msg -} {1 {bad text index "@q"}} -test text-9.2.4 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count 3.1 @r} msg] $msg -} {1 {bad text index "@r"}} -test text-9.2.5 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {Grl} + + +test text-10.1 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t count +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t count ?-option value ...? index1 index2"} +test text-10.2 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t count blah 1.0 2.0 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad option "blah" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels} +test text-10.3 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t count a b +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "a"} +test text-10.4 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t count @q 3.1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@q"} +test text-10.5 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t count 3.1 @r +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@r"} +test text-10.6 {TextWidgetCmd procedure, "count" option} -setup { + text .t + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { .t count 5.7 5.3 -} {-4} -test text-9.2.6 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {-4} +test text-10.7 {TextWidgetCmd procedure, "count" option} -setup { + text .t + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { .t count 5.3 5.5 -} {2} -test text-9.2.7 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {2} +test text-10.8 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t count 5.3 end -} {29} -.t mark set a 5.3 -.t mark set b 5.3 -.t mark set c 5.5 -test text-9.2.8 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {29} +test text-10.9 {TextWidgetCmd procedure, "count" option} -setup { + text .t + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { .t count 5.2 5.7 -} {5} -test text-9.2.9 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {5} +test text-10.10 {TextWidgetCmd procedure, "count" option} -setup { + text .t + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { .t count 5.2 5.3 -} {1} -test text-9.2.10 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {1} +test text-10.11 {TextWidgetCmd procedure, "count" option} -setup { + text .t + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { .t count 5.2 5.4 -} {2} -test text-9.2.17 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count 5.2 foo} msg] $msg -} {1 {bad text index "foo"}} -.t tag configure elide -elide 1 -.t tag add elide 2.2 3.4 -.t tag add elide 4.0 4.1 -test text-9.2.18 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {2} +test text-10.12 {TextWidgetCmd procedure, "count" option} -setup { + text .t + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { + .t count 5.2 foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "foo"} +test text-10.13 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 .t count -displayindices 2.0 3.0 -} {2} -test text-9.2.19 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {2} +test text-10.14 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 .t count -displayindices 2.2 3.0 -} {0} -test text-9.2.20 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {0} +test text-10.15 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 .t count -displayindices 2.0 4.2 -} {5} +} -cleanup { + destroy .t +} -result {5} +test text-10.16 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 # Create one visible and one invisible window -frame .t.w1 -frame .t.w2 -.t mark set a 2.2 + frame .t.w1 + frame .t.w2 # Creating this window here means that the elidden text -# now starts at 2.3, but 'a' is automatically moved to 2.3 -.t window create 2.1 -window .t.w1 -.t window create 3.1 -window .t.w2 -test text-9.2.21 {TextWidgetCmd procedure, "count" option} { +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displayindices 2.0 3.0 -} {3} -test text-9.2.22 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {3} +test text-10.17 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displayindices 2.2 3.0 -} {1} -test text-9.2.23 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {1} +test text-10.18 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 + .t mark set a 2.2 +# Creating this window here means that the elidden text +# now starts at 2.3, but 'a' is automatically moved to 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displayindices a 3.0 -} {0} -test text-9.2.24 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {0} +test text-10.19 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displayindices 2.0 4.2 -} {6} -test text-9.2.25 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {6} +test text-10.20 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displaychars 2.0 3.0 -} {2} -test text-9.2.26 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {2} +test text-10.21 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displaychars 2.2 3.0 -} {1} -test text-9.2.27 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {1} +test text-10.22 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 + .t mark set a 2.2 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3, but 'a' is automatically moved to 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displaychars a 3.0 -} {0} -test text-9.2.28 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {0} +test text-10.23 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 + .t count -displaychars 2.0 4.2 +} -cleanup { + destroy .t +} -result {5} +test text-10.24 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -displaychars 2.0 4.2 -} {5} -test text-9.2.29 {TextWidgetCmd procedure, "count" option} { list [.t count -indices 2.2 3.0] [.t count 2.2 3.0] -} {10 10} -test text-9.2.30 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {10 10} +test text-10.25 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 + .t mark set a 2.2 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3, but 'a' is automatically moved to 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 list [.t count -indices a 3.0] [.t count a 3.0] -} {9 9} -test text-9.2.31 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {9 9} +test text-10.26 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 + .t count -displaychars 2.0 4.2 .t count -indices 2.0 4.2 -} {21} -test text-9.2.32 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {21} +test text-10.27 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 + .t count -displaychars 2.0 4.2 .t count -chars 2.2 3.0 -} {10} -test text-9.2.33 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {10} +test text-10.28 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 + .t mark set a 2.2 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3, but 'a' is automatically moved to 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 .t count -chars a 3.0 -} {9} -test text-9.2.34 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {9} +test text-10.29 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" + .t tag configure elide -elide 1 + .t tag add elide 2.2 3.4 + .t tag add elide 4.0 4.1 +# Create one visible and one invisible window + frame .t.w1 + frame .t.w2 +# Creating this window here means that the elidden text +# now starts at 2.3 + .t window create 2.1 -window .t.w1 + .t window create 3.1 -window .t.w2 + .t count -displaychars 2.0 4.2 .t count -chars 2.0 4.2 -} {19} -destroy .t.w1 -destroy .t.w2 -set current [.t get 1.0 end-1c] -.t delete 1.0 end -.t insert end [string repeat "abcde " 50]\n -.t insert end [string repeat "fghij " 50]\n -.t insert end [string repeat "klmno " 50] -test text-9.2.35 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {19} +test text-10.30 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines 1.0 end -} {3} -test text-9.2.36 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {3} +test text-10.31 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines end 1.0 -} {-3} -test text-9.2.37 {TextWidgetCmd procedure, "count" option} { - list [catch {.t count -lines 1.0 2.0 3.0} res] $res -} {1 {bad option "1.0" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels}} -test text-9.2.38 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {-3} +test text-10.32 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] + .t count -lines 1.0 2.0 3.0 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad option "1.0" must be -chars, -displaychars, -displayindices, -displaylines, -indices, -lines, -update, -xpixels, or -ypixels} +test text-10.33 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines end end -} {0} -test text-9.2.39 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {0} +test text-10.34 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines 1.5 2.5 -} {1} -test text-9.2.40 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {1} +test text-10.35 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines 2.5 "2.5 lineend" -} {0} -test text-9.2.41 {TextWidgetCmd procedure, "count" option} { +} -cleanup { + destroy .t +} -result {0} +test text-10.36 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines 2.7 "1.0 lineend" -} {-1} -test text-9.2.42 {TextWidgetCmd procedure, "count" option} { - set old_wrap [.t cget -wrap] +} -cleanup { + destroy .t +} -result {-1} +test text-10.37 {TextWidgetCmd procedure, "count" option} -setup { + text .t +} -body { + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t configure -wrap none - set res [.t count -displaylines 1.0 end] - .t configure -wrap $old_wrap - set res -} {3} -test text-9.2.43 {TextWidgetCmd procedure, "count" option} { + .t count -displaylines 1.0 end +} -cleanup { + destroy .t +} -result {3} +test text-10.38 {TextWidgetCmd procedure, "count" option} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack append . .t {top expand fill} +} -body { + .t configure -width 20 -height 10 + update + .t insert end [string repeat "abcde " 50]\n + .t insert end [string repeat "fghij " 50]\n + .t insert end [string repeat "klmno " 50] .t count -lines -chars -indices -displaylines 1.0 end -} {3 903 903 45} -.t configure -wrap none +} -cleanup { + destroy .t +} -result {3 903 903 45} -# Newer tags are higher priority -.t tag configure elide1 -elide 0 -.t tag configure elide2 -elide 1 -.t tag configure elide3 -elide 0 -.t tag configure elide4 -elide 1 -test text-0.2.44.0 {counting with tag priority eliding} { - .t delete 1.0 end +test text-11.1 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack append . .t {top expand fill} +} -body { .t insert end "hello" + .t configure -wrap none list [.t count -displaychars 1.0 1.0] \ [.t count -displaychars 1.0 1.1] \ [.t count -displaychars 1.0 1.2] \ @@ -702,23 +2631,42 @@ test text-0.2.44.0 {counting with tag priority eliding} { [.t count -displaychars 1.0 1.5] \ [.t count -displaychars 1.0 1.6] \ [.t count -displaychars 1.0 2.6] \ -} {0 1 2 3 4 5 5 6} -test text-0.2.44 {counting with tag priority eliding} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {0 1 2 3 4 5 5 6} +test text-11.2 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack append . .t {top expand fill} +} -body { .t insert end "hello" + .t tag configure elide1 -elide 0 .t tag add elide1 1.2 1.4 .t count -displaychars 1.0 1.5 -} {5} -test text-0.2.45 {counting with tag priority eliding} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {5} +test text-11.3 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 +} -body { .t insert end "hello" +# Newer tags are higher priority + .t tag configure elide1 -elide 0 + .t tag configure elide2 -elide 1 + .t tag add elide1 1.2 1.4 .t tag add elide2 1.2 1.4 .t count -displaychars 1.0 1.5 -} {3} -test text-0.2.46 {counting with tag priority eliding} { +} -cleanup { + destroy .t +} -result {3} +test text-11.4 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 set res {} - .t delete 1.0 end +} -body { .t insert end "hello" +# Newer tags are higher priority + .t tag configure elide1 -elide 0 + .t tag configure elide2 -elide 1 + .t tag add elide1 1.2 1.4 .t tag add elide2 1.2 1.4 .t tag add elide1 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] @@ -727,11 +2675,19 @@ test text-0.2.46 {counting with tag priority eliding} { .t tag add elide1 1.2 1.4 .t tag add elide2 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] -} {3 3} -test text-0.2.47 {counting with tag priority eliding} { +} -cleanup { + destroy .t +} -result {3 3} +test text-11.5 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 set res {} - .t delete 1.0 end +} -body { .t insert end "hello" +# Newer tags are higher priority + .t tag configure elide1 -elide 0 + .t tag configure elide2 -elide 1 + .t tag configure elide3 -elide 0 + .t tag add elide1 1.2 1.4 .t tag add elide2 1.2 1.4 .t tag add elide3 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] @@ -740,11 +2696,19 @@ test text-0.2.47 {counting with tag priority eliding} { .t tag add elide3 1.2 1.4 .t tag add elide3 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] -} {5 5} -test text-0.2.48 {counting with tag priority eliding} { +} -cleanup { + destroy .t +} -result {5 5} +test text-11.6 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 set res {} - .t delete 1.0 end +} -body { .t insert end "hello" +# Newer tags are higher priority + .t tag configure elide1 -elide 0 + .t tag configure elide2 -elide 1 + .t tag configure elide3 -elide 0 + .t tag configure elide4 -elide 1 .t tag add elide2 1.2 1.4 .t tag add elide3 1.2 1.4 .t tag add elide4 1.2 1.4 @@ -757,10 +2721,17 @@ test text-0.2.48 {counting with tag priority eliding} { .t tag add elide2 1.2 1.4 .t tag add elide3 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] -} {3 3} -test text-0.2.49 {counting with tag priority eliding} { +} -cleanup { + destroy .t +} -result {3 3} +test text-11.7 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 set res {} - .t delete 1.0 end +} -body { +# Newer tags are higher priority + .t tag configure elide1 -elide 0 + .t tag configure elide2 -elide 1 + .t tag configure elide3 -elide 0 .t insert end "hello" .t tag add elide2 1.2 1.4 .t tag add elide3 1.2 1.4 @@ -772,11 +2743,18 @@ test text-0.2.49 {counting with tag priority eliding} { .t tag add elide2 1.2 1.4 .t tag add elide3 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] -} {5 5} -test text-0.2.50 {counting with tag priority eliding} { +} -cleanup { + destroy .t +} -result {5 5} +test text-11.8 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack append . .t {top expand fill} set res {} - .t delete 1.0 end +} -body { .t insert end "hello" +# Newer tags are higher priority + .t tag configure elide1 -elide 0 + .t tag configure elide2 -elide 1 .t tag add elide2 1.0 1.5 .t tag add elide1 1.2 1.4 lappend res [.t count -displaychars 1.0 1.5] @@ -791,10 +2769,14 @@ test text-0.2.50 {counting with tag priority eliding} { lappend res [.t count -displaychars 1.1 1.5] lappend res [.t count -displaychars 1.2 1.5] lappend res [.t count -displaychars 1.3 1.5] -} {0 0 0 0 3 2 1 1} -test text-0.2.51 {counting with tag priority eliding} { +} -cleanup { + destroy .t +} -result {0 0 0 0 3 2 1 1} +test text-11.9 {counting with tag priority eliding} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack append . .t {top expand fill} set res {} - .t delete 1.0 end +} -body { .t tag configure WELCOME -elide 1 .t tag configure SYSTEM -elide 0 .t tag configure TRAFFIC -elide 1 @@ -815,225 +2797,410 @@ test text-0.2.51 {counting with tag priority eliding} { lappend res [.t index "end -2 indices"] lappend res [.t index "end -2 display indices"] lappend res [.t index "end -2 display chars"] -} {1 0 0 1 0 2.0 4.0 4.0 4.0 3.0 3.0 3.0 2.0 1.0 1.0} - -.t delete 1.0 end -.t insert end $current -unset current - -test text-10.1 {TextWidgetCmd procedure, "index" option} { - list [catch {.t index} msg] $msg -} {1 {wrong # args: should be ".t index index"}} -test text-10.2 {TextWidgetCmd procedure, "index" option} { - list [catch {.t ind a b} msg] $msg -} {1 {wrong # args: should be ".t index index"}} -test text-10.3 {TextWidgetCmd procedure, "index" option} { - list [catch {.t in a b} msg] $msg -} {1 {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview}} -test text-10.4 {TextWidgetCmd procedure, "index" option} { - list [catch {.t index @xyz} msg] $msg -} {1 {bad text index "@xyz"}} -test text-10.5 {TextWidgetCmd procedure, "index" option} { +} -cleanup { + destroy .t +} -result {1 0 0 1 0 2.0 4.0 4.0 4.0 3.0 3.0 3.0 2.0 1.0 1.0} + + +test text-12.1 {TextWidgetCmd procedure, "index" option} -setup { + text .t +} -body { + .t index +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t index index"} +test text-12.2 {TextWidgetCmd procedure, "index" option} -setup { + text .t +} -body { + .t ind a b +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t index index"} +test text-12.3 {TextWidgetCmd procedure, "index" option} -setup { + text .t +} -body { + .t in a b +} -cleanup { + destroy .t +} -returnCodes {error} -result {ambiguous option "in": must be bbox, cget, compare, configure, count, debug, delete, dlineinfo, dump, edit, get, image, index, insert, mark, peer, replace, scan, search, see, tag, window, xview, or yview} +test text-12.4 {TextWidgetCmd procedure, "index" option} -setup { + text .t +} -body { + .t index @xyz +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "@xyz"} +test text-12.5 {TextWidgetCmd procedure, "index" option} -setup { + [text .t] insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { .t index 1.2 -} 1.2 +} -cleanup { + destroy .t +} -result 1.2 -test text-11.1 {TextWidgetCmd procedure, "insert" option} { - list [catch {.t insert 1.2} msg] $msg -} {1 {wrong # args: should be ".t insert index chars ?tagList chars tagList ...?"}} -test text-11.2 {TextWidgetCmd procedure, "insert" option} { + +test text-13.1 {TextWidgetCmd procedure, "insert" option} -setup { + [text .t] insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" +} -body { + .t insert 1.2 +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t insert index chars ?tagList chars tagList ...?"} +test text-13.2 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t config -state disabled .t insert 1.2 xyzzy .t get 1.0 1.end -} {Line 1} -.t config -state normal -test text-11.3 {TextWidgetCmd procedure, "insert" option} { +} -cleanup { + destroy .t +} -result {Line 1} +test text-13.3 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t insert 1.2 xyzzy .t get 1.0 1.end -} {Lixyzzyne 1} -test text-11.4 {TextWidgetCmd procedure, "insert" option} { +} -cleanup { + destroy .t +} -result {Lixyzzyne 1} +test text-13.4 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { + .t insert 1.0 "Line 1 +aefghijklm +12345 +Line 4 +bOy GIrl .#@? x_yz +!@#$% +Line 7" .t delete 1.0 end .t insert 1.0 "Sample text" x .t tag ranges x -} {1.0 1.11} -test text-11.5 {TextWidgetCmd procedure, "insert" option} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {1.0 1.11} +test text-13.5 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { .t insert 1.0 "Sample text" x .t insert 1.2 "XYZ" y list [.t tag ranges x] [.t tag ranges y] -} {{1.0 1.2 1.5 1.14} {1.2 1.5}} -test text-11.6 {TextWidgetCmd procedure, "insert" option} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {{1.0 1.2 1.5 1.14} {1.2 1.5}} +test text-13.6 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { .t insert 1.0 "Sample text" {x y z} list [.t tag ranges x] [.t tag ranges y] [.t tag ranges z] -} {{1.0 1.11} {1.0 1.11} {1.0 1.11}} -test text-11.7 {TextWidgetCmd procedure, "insert" option} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {{1.0 1.11} {1.0 1.11} {1.0 1.11}} +test text-13.7 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { .t insert 1.0 "Sample text" {x y z} .t insert 1.3 "A" {a b z} list [.t tag ranges a] [.t tag ranges b] [.t tag ranges x] [.t tag ranges y] [.t tag ranges z] -} {{1.3 1.4} {1.3 1.4} {1.0 1.3 1.4 1.12} {1.0 1.3 1.4 1.12} {1.0 1.12}} -test text-11.8 {TextWidgetCmd procedure, "insert" option} { - .t delete 1.0 end - list [catch {.t insert 1.0 "Sample text" "a \{b"} msg] $msg -} {1 {unmatched open brace in list}} -test text-11.9 {TextWidgetCmd procedure, "insert" option} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {{1.3 1.4} {1.3 1.4} {1.0 1.3 1.4 1.12} {1.0 1.3 1.4 1.12} {1.0 1.12}} +test text-13.8 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { + .t insert 1.0 "Sample text" "a \{b" +} -cleanup { + destroy .t +} -returnCodes {error} -result {unmatched open brace in list} +test text-13.9 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { .t insert 1.0 "First" bold " " {} second "x y z" " third" list [.t get 1.0 1.end] [.t tag ranges bold] [.t tag ranges x] \ [.t tag ranges y] [.t tag ranges z] -} {{First second third} {1.0 1.5} {1.6 1.12} {1.6 1.12} {1.6 1.12}} -test text-11.10 {TextWidgetCmd procedure, "insert" option} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {{First second third} {1.0 1.5} {1.6 1.12} {1.6 1.12} {1.6 1.12}} +test text-13.10 {TextWidgetCmd procedure, "insert" option} -setup { + text .t +} -body { .t insert 1.0 "First" bold " second" silly list [.t get 1.0 1.end] [.t tag ranges bold] [.t tag ranges silly] -} {{First second} {1.0 1.5} {1.5 1.12}} +} -cleanup { + destroy .t +} -result {{First second} {1.0 1.5} {1.5 1.12}} # Edit, mark, scan, search, see, tag, window, xview, and yview actions are tested elsewhere. -test text-12.1 {ConfigureText procedure} { - list [catch {.t2 configure -state foobar} msg] $msg -} {1 {bad state "foobar": must be disabled or normal}} -test text-12.2 {ConfigureText procedure} { - .t2 configure -spacing1 -2 -spacing2 1 -spacing3 1 - list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] -} {0 1 1} -test text-12.3 {ConfigureText procedure} { - .t2 configure -spacing1 1 -spacing2 -1 -spacing3 1 - list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] -} {1 0 1} -test text-12.4 {ConfigureText procedure} { - .t2 configure -spacing1 1 -spacing2 1 -spacing3 -3 - list [.t2 cget -spacing1] [.t2 cget -spacing2] [.t2 cget -spacing3] -} {1 1 0} -test text-12.5 {ConfigureText procedure} { - set x [list [catch {.t2 configure -tabs {30 foo}} msg] $msg $errorInfo] - .t2 configure -tabs {10 20 30} - set x -} {1 {bad tab alignment "foo": must be left, right, center, or numeric} {bad tab alignment "foo": must be left, right, center, or numeric +test text-14.1 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -state foobar +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad state "foobar": must be disabled or normal} +test text-14.2 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -spacing1 -2 -spacing2 1 -spacing3 1 + list [.t cget -spacing1] [.t cget -spacing2] [.t cget -spacing3] +} -cleanup { + destroy .t +} -result {0 1 1} +test text-14.3 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -spacing1 1 -spacing2 -1 -spacing3 1 + list [.t cget -spacing1] [.t cget -spacing2] [.t cget -spacing3] +} -cleanup { + destroy .t +} -result {1 0 1} +test text-14.4 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -spacing1 1 -spacing2 1 -spacing3 -3 + list [.t cget -spacing1] [.t cget -spacing2] [.t cget -spacing3] +} -cleanup { + destroy .t +} -result {1 1 0} +test text-14.5 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -tabs {30 foo} +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad tab alignment "foo": must be left, right, center, or numeric} +test text-14.6 {ConfigureText procedure} -setup { + text .t +} -body { + catch {.t configure -tabs {30 foo}} + .t configure -tabs {10 20 30} + return $errorInfo +} -cleanup { + destroy .t +} -result {bad tab alignment "foo": must be left, right, center, or numeric (while processing -tabs option) invoked from within -".t2 configure -tabs {30 foo}"}} -test text-12.6 {ConfigureText procedure} { - .t2 configure -tabs {10 20 30} - .t2 configure -tabs {} - .t2 cget -tabs -} {} -test text-12.7 {ConfigureText procedure} { - list [catch {.t2 configure -wrap bogus} msg] $msg -} {1 {bad wrap "bogus": must be char, none, or word}} -test text-12.8 {ConfigureText procedure} { - .t2 configure -selectborderwidth 17 -selectforeground #332211 \ +".t configure -tabs {30 foo}"} +test text-14.7 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -tabs {10 20 30} + .t configure -tabs {} + .t cget -tabs +} -cleanup { + destroy .t +} -result {} +test text-14.8 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -wrap bogus +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad wrap "bogus": must be char, none, or word} +test text-14.9 {ConfigureText procedure} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 +} -body { + .t configure -selectborderwidth 17 -selectforeground #332211 \ -selectbackground #abc - list [lindex [.t2 tag config sel -borderwidth] 4] \ - [lindex [.t2 tag config sel -foreground] 4] \ - [lindex [.t2 tag config sel -background] 4] -} {17 #332211 #abc} -test text-12.9 {ConfigureText procedure} { - .t2 configure -selectborderwidth {} - .t2 tag cget sel -borderwidth -} {} -test text-12.10 {ConfigureText procedure} { - list [catch {.t2 configure -selectborderwidth foo} msg] $msg -} {1 {bad screen distance "foo"}} -test text-12.11 {ConfigureText procedure} { - catch {destroy .t2} + list [lindex [.t tag config sel -borderwidth] 4] \ + [lindex [.t tag config sel -foreground] 4] \ + [lindex [.t tag config sel -background] 4] +} -cleanup { + destroy .t +} -result {17 #332211 #abc} +test text-14.10 {ConfigureText procedure} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 +} -body { + .t configure -selectborderwidth {} + .t tag cget sel -borderwidth +} -cleanup { + destroy .t +} -result {} +test text-14.11 {ConfigureText procedure} -setup { + text .t +} -body { + .t configure -selectborderwidth foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad screen distance "foo"} +test text-14.12 {ConfigureText procedure} -body { + text .t + entry .t.e + .t.e insert end abcdefg + .t.e select from 0 .t.e select to 2 text .t2 -exportselection 1 selection get -} {ab} -test text-12.12 {ConfigureText procedure} { - catch {destroy .t2} +} -cleanup { + destroy .t .t2 +} -result {ab} +test text-14.13 {ConfigureText procedure} -body { + text .t + entry .t.e + .t.e insert end abcdefg + .t.e select from 0 .t.e select to 2 text .t2 -exportselection 0 .t2 insert insert 1234657890 .t2 tag add sel 1.0 1.4 selection get -} {ab} -test text-12.13 {ConfigureText procedure} { - catch {destroy .t2} +} -cleanup { + destroy .t .t2 +} -result {ab} +test text-14.14 {ConfigureText procedure} -body { + text .t + entry .t.e + .t.e insert end abcdefg + .t.e select from 0 .t.e select to 1 text .t2 -exportselection 1 .t2 insert insert 1234657890 .t2 tag add sel 1.0 1.4 selection get -} {1234} -test text-12.14 {ConfigureText procedure} { - catch {destroy .t2} +} -cleanup { + destroy .t .t2 +} -result {1234} +test text-14.15 {ConfigureText procedure} -body { + text .t + entry .t.e + .t.e insert end abcdefg + .t.e select from 0 .t.e select to 1 text .t2 -exportselection 0 .t2 insert insert 1234657890 .t2 tag add sel 1.0 1.4 .t2 configure -exportselection 1 selection get -} {1234} -test text-12.15 {ConfigureText procedure} { - catch {destroy .t2} +} -cleanup { + destroy .t2 .t +} -result {1234} +test text-14.16 {ConfigureText procedure} -body { + text .t + entry .t.e + .t.e insert end abcdefg + .t.e select from 0 + text .t2 -exportselection 1 + .t2 insert insert 1234657890 + .t2 tag add sel 1.0 1.4 + selection get + .t2 configure -exportselection 0 + selection get +} -cleanup { + destroy .t .t2 +} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test text-14.17 {ConfigureText procedure} -body { + text .t + entry .t.e + .t.e insert end abcdefg + .t.e select from 0 text .t2 -exportselection 1 .t2 insert insert 1234657890 .t2 tag add sel 1.0 1.4 set result [selection get] .t2 configure -exportselection 0 - lappend result [catch {selection get} msg] $msg -} {1234 1 {PRIMARY selection doesn't exist or form "STRING" not defined}} -test text-12.16 {ConfigureText procedure} {fonts} { - # This test is non-portable because the window size will vary depending - # on the font size, which can vary. - catch {destroy .t2} - toplevel .t2 - text .t2.t -width 20 -height 10 - pack append .t2 .t2.t top - wm geometry .t2 +0+0 - update - wm geometry .t2 -} {150x140+0+0} -test text-12.17 {ConfigureText procedure} { - # This test was failing Windows because the title bar on .t2 - # was a certain minimum size and it was interfering with the size - # requested by the -setgrid. The "overrideredirect" gets rid of the - # titlebar so the toplevel can shrink to the appropriate size. - catch {destroy .t2} - toplevel .t2 - wm overrideredirect .t2 1 - text .t2.t -width 20 -height 10 -setgrid 1 - pack append .t2 .t2.t top - wm geometry .t2 +0+0 - update - wm geometry .t2 -} {20x10+0+0} -test text-12.18 {ConfigureText procedure} { - # This test was failing on Windows because the title bar on .t2 - # was a certain minimum size and it was interfering with the size - # requested by the -setgrid. The "overrideredirect" gets rid of the - # titlebar so the toplevel can shrink to the appropriate size. - catch {destroy .t2} - toplevel .t2 - wm overrideredirect .t2 1 - text .t2.t -width 20 -height 10 -setgrid 1 - pack append .t2 .t2.t top - wm geometry .t2 +0+0 - update - set result [wm geometry .t2] - wm geometry .t2 15x8 - update - lappend result [wm geometry .t2] - .t2.t configure -wrap word - update - lappend result [wm geometry .t2] -} {20x10+0+0 15x8+0+0 15x8+0+0} - -test text-13.1 {TextWorldChanged procedure, spacing options} fonts { - catch {destroy .t2} - text .t2 -width 20 -height 10 - set result [winfo reqheight .t2] - .t2 configure -spacing1 2 - lappend result [winfo reqheight .t2] - .t2 configure -spacing3 1 - lappend result [winfo reqheight .t2] - .t2 configure -spacing1 0 - lappend result [winfo reqheight .t2] -} {140 160 170 150} - -test text-14.1 {TextEventProc procedure} { + catch {selection get} + return $result +} -cleanup { + destroy .t .t2 +} -result {1234} +test text-14.18 {ConfigureText procedure} -constraints fonts -setup { + toplevel .top + text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 +} -body { + .top.t configure -width 20 -height 10 + pack append .top .top.t top + update + set geom [wm geometry .top] + set x [string range $geom 0 [string first + $geom]] +} -cleanup { + destroy .top +} -result {150x140+} +# This test was failing Windows because the title bar on .t was a certain +# minimum size and it was interfering with the size requested by the -setgrid. +# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink +# to the appropriate size. +test text-14.19 {ConfigureText procedure} -setup { + toplevel .top + text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 +} -body { + .top.t configure -width 20 -height 10 -setgrid 1 + wm overrideredirect .top 1 + pack append .top .top.t top + wm geometry .top +0+0 + update + wm geometry .top +} -cleanup { + destroy .top +} -result {20x10+0+0} +# This test was failing on Windows because the title bar on .t was a certain +# minimum size and it was interfering with the size requested by the -setgrid. +# The "overrideredirect" gets rid of the titlebar so the toplevel can shrink +# to the appropriate size. +test text-14.20 {ConfigureText procedure} -setup { + toplevel .top + text .top.t -font {Courier -12} -borderwidth 2 -highlightthickness 2 +} -body { + .top.t configure -width 20 -height 10 -setgrid 1 + wm overrideredirect .top 1 + pack append .top .top.t top + wm geometry .top +0+0 + update + set result [wm geometry .top] + wm geometry .top 15x8 + update + lappend result [wm geometry .top] + .top.t configure -wrap word + update + lappend result [wm geometry .top] +} -cleanup { + destroy .top +} -result {20x10+0+0 15x8+0+0 15x8+0+0} + + +test text-15.1 {TextWorldChanged procedure, spacing options} -constraints { + fonts +} -body { + text .t -width 20 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + set result [winfo reqheight .t] + .t configure -spacing1 2 + lappend result [winfo reqheight .t] + .t configure -spacing3 1 + lappend result [winfo reqheight .t] + .t configure -spacing1 0 + lappend result [winfo reqheight .t] +} -cleanup { + destroy .t +} -result {140 160 170 150} + + +test text-16.1 {TextEventProc procedure} -body { text .tx1 -bg #543210 rename .tx1 .tx2 set x {} @@ -1041,265 +3208,363 @@ test text-14.1 {TextEventProc procedure} { lappend x [.tx2 cget -bg] destroy .tx1 lappend x [info command .tx*] [winfo exists .tx1] [winfo exists .tx2] -} {1 #543210 {} 0 0} +} -cleanup { + destroy .txt1 +} -result {1 #543210 {} 0 0} + -test text-15.1 {TextCmdDeletedProc procedure} { +test text-17.1 {TextCmdDeletedProc procedure} -body { text .tx1 rename .tx1 {} list [info command .tx*] [winfo exists .tx1] -} {{} 0} -test text-15.2 {TextCmdDeletedProc procedure, disabling -setgrid} fonts { - catch {destroy .top} - toplevel .top - wm geom .top +0+0 - text .top.t -setgrid 1 -width 20 -height 10 - pack .top.t - update - set x [wm geometry .top] - rename .top.t {} - update - lappend x [wm geometry .top] +} -cleanup { + destroy .txt1 +} -result {{} 0} +test text-17.2 {TextCmdDeletedProc procedure, disabling -setgrid} -constraints { + fonts +} -body { + toplevel .top + text .top.t -borderwidth 2 -highlightthickness 2 -font {Courier -12 bold} \ + -setgrid 1 -width 20 -height 10 + pack .top.t + update + set geom [wm geometry .top] + set x [string range $geom 0 [string first + $geom]] + rename .top.t {} + update + set geom [wm geometry .top] + lappend x [string range $geom 0 [string first + $geom]] + return $x +} -cleanup { destroy .top - set x -} {20x10+0+0 150x140+0+0} +} -result {20x10+ 150x140+} -test text-16.1 {InsertChars procedure} { - catch {destroy .t2} - text .t2 - .t2 insert 2.0 abcd\n - .t2 get 1.0 end -} {abcd + +test text-18.1 {InsertChars procedure} -body { + text .t + .t insert 2.0 abcd\n + .t get 1.0 end +} -cleanup { + destroy .t +} -result {abcd } -test text-16.2 {InsertChars procedure} { - catch {destroy .t2} - text .t2 - .t2 insert 1.0 abcd\n - .t2 insert end 123\n - .t2 get 1.0 end -} {abcd +test text-18.2 {InsertChars procedure} -body { + text .t + .t insert 1.0 abcd\n + .t insert end 123\n + .t get 1.0 end +} -cleanup { + destroy .t +} -result {abcd 123 } -test text-16.3 {InsertChars procedure} { - catch {destroy .t2} - text .t2 - .t2 insert 1.0 abcd\n - .t2 insert 10.0 123 - .t2 get 1.0 end -} {abcd +test text-18.3 {InsertChars procedure} -body { + text .t + .t insert 1.0 abcd\n + .t insert 10.0 123 + .t get 1.0 end +} -cleanup { + destroy .t +} -result {abcd 123 } -test text-16.4 {InsertChars procedure, inserting on top visible line} { - catch {destroy .t2} - text .t2 -width 20 -height 4 -wrap word - pack .t2 - .t2 insert insert "Now is the time for all great men to come to the " - .t2 insert insert "aid of their party.\n" - .t2 insert insert "Now is the time for all great men.\n" - .t2 see end - update - .t2 insert 1.0 "Short\n" - .t2 index @0,0 -} {2.56} -test text-16.5 {InsertChars procedure, inserting on top visible line} { - catch {destroy .t2} - text .t2 -width 20 -height 4 -wrap word - pack .t2 - .t2 insert insert "Now is the time for all great men to come to the " - .t2 insert insert "aid of their party.\n" - .t2 insert insert "Now is the time for all great men.\n" - .t2 see end - update - .t2 insert 1.55 "Short\n" - .t2 index @0,0 -} {2.0} -test text-16.6 {InsertChars procedure, inserting on top visible line} { - catch {destroy .t2} - text .t2 -width 20 -height 4 -wrap word - pack .t2 - .t2 insert insert "Now is the time for all great men to come to the " - .t2 insert insert "aid of their party.\n" - .t2 insert insert "Now is the time for all great men.\n" - .t2 see end - update - .t2 insert 1.56 "Short\n" - .t2 index @0,0 -} {1.56} -test text-16.7 {InsertChars procedure, inserting on top visible line} { - catch {destroy .t2} - text .t2 -width 20 -height 4 -wrap word - pack .t2 - .t2 insert insert "Now is the time for all great men to come to the " - .t2 insert insert "aid of their party.\n" - .t2 insert insert "Now is the time for all great men.\n" - .t2 see end - update - .t2 insert 1.57 "Short\n" - .t2 index @0,0 -} {1.56} -catch {destroy .t2} - -proc setup {} { - .t delete 1.0 end +test text-18.4 {InsertChars procedure, inserting on top visible line} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .t +} -body { + .t configure -width 20 -height 4 -wrap word + .t insert insert "Now is the time for all great men to come to the " + .t insert insert "aid of their party.\n" + .t insert insert "Now is the time for all great men.\n" + .t see end + update + .t insert 1.0 "Short\n" + .t index @0,0 +} -cleanup { + destroy .t +} -result {2.56} +test text-18.5 {InsertChars procedure, inserting on top visible line} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .t +} -body { + .t configure -width 20 -height 4 -wrap word + .t insert insert "Now is the time for all great men to come to the " + .t insert insert "aid of their party.\n" + .t insert insert "Now is the time for all great men.\n" + .t see end + update + .t insert 1.55 "Short\n" + .t index @0,0 +} -cleanup { + destroy .t +} -result {2.0} +test text-18.6 {InsertChars procedure, inserting on top visible line} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .t +} -body { + .t configure -width 20 -height 4 -wrap word + .t insert insert "Now is the time for all great men to come to the " + .t insert insert "aid of their party.\n" + .t insert insert "Now is the time for all great men.\n" + .t see end + update + .t insert 1.56 "Short\n" + .t index @0,0 +} -cleanup { + destroy .t +} -result {1.56} +test text-18.7 {InsertChars procedure, inserting on top visible line} -setup { + text .t -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .t +} -body { + .t configure -width 20 -height 4 -wrap word + .t insert insert "Now is the time for all great men to come to the " + .t insert insert "aid of their party.\n" + .t insert insert "Now is the time for all great men.\n" + .t see end + update + .t insert 1.57 "Short\n" + .t index @0,0 +} -cleanup { + destroy .t +} -result {1.56} + + +test text-19.1 {DeleteChars procedure} -body { + text .t + .t get 1.0 end +} -cleanup { + destroy .t +} -result { +} +test text-19.2 {DeleteChars procedure} -body { + text .t + .t delete foobar +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "foobar"} +test text-19.3 {DeleteChars procedure} -body { + text .t + .t delete 1.0 lousy +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "lousy"} +test text-19.4 {DeleteChars procedure} -body { + text .t .t insert 1.0 "Line 1 abcde 12345 Line 4" -} - -.t delete 1.0 end -test text-17.1 {DeleteChars procedure} { - .t get 1.0 end -} { -} -test text-17.2 {DeleteChars procedure} { - list [catch {.t delete foobar} msg] $msg -} {1 {bad text index "foobar"}} -test text-17.3 {DeleteChars procedure} { - list [catch {.t delete 1.0 lousy} msg] $msg -} {1 {bad text index "lousy"}} -test text-17.4 {DeleteChars procedure} { - setup .t delete 2.1 .t get 1.0 end -} {Line 1 +} -cleanup { + destroy .t +} -result {Line 1 acde 12345 Line 4 } -test text-17.5 {DeleteChars procedure} { - setup +test text-19.5 {DeleteChars procedure} -body { + text .t + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" .t delete 2.3 .t get 1.0 end -} {Line 1 +} -cleanup { + destroy .t +} -result {Line 1 abce 12345 Line 4 } -test text-17.6 {DeleteChars procedure} { - setup +test text-19.6 {DeleteChars procedure} -body { + text .t + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" .t delete 2.end .t get 1.0 end -} {Line 1 +} -cleanup { + destroy .t +} -result {Line 1 abcde12345 Line 4 } -test text-17.7 {DeleteChars procedure} { - setup +test text-19.7 {DeleteChars procedure} -body { + text .t + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" .t tag add sel 4.2 end .t delete 4.2 end list [.t tag ranges sel] [.t get 1.0 end] -} {{} {Line 1 +} -cleanup { + destroy .t +} -result {{} {Line 1 abcde 12345 Li }} -test text-17.8 {DeleteChars procedure} { - setup +test text-19.8 {DeleteChars procedure} -body { + text .t + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" .t tag add sel 1.0 end .t delete 4.0 end list [.t tag ranges sel] [.t get 1.0 end] -} {{1.0 3.5} {Line 1 +} -cleanup { + destroy .t +} -result {{1.0 3.5} {Line 1 abcde 12345 }} -test text-17.9 {DeleteChars procedure} { - setup +test text-19.9 {DeleteChars procedure} -body { + text .t + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" .t delete 2.2 2.2 .t get 1.0 end -} {Line 1 +} -cleanup { + destroy .t +} -result {Line 1 abcde 12345 Line 4 } -test text-17.10 {DeleteChars procedure} { - setup +test text-19.10 {DeleteChars procedure} -body { + text .t + .t insert 1.0 "Line 1 +abcde +12345 +Line 4" .t delete 2.3 2.1 .t get 1.0 end -} {Line 1 +} -cleanup { + destroy .t +} -result {Line 1 abcde 12345 Line 4 } -test text-17.11 {DeleteChars procedure} { - catch {destroy .t2} - toplevel .t2 - text .t2.t -width 20 -height 5 - pack append .t2 .t2.t top - wm geometry .t2 +0+0 - .t2.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns" - update - .t2.t delete 1.0 3.0 - list [.t2.t index @0,0] [.t2.t get @0,0] -} {1.0 x} -test text-17.12 {DeleteChars procedure} { - catch {destroy .t2} - toplevel .t2 - text .t2.t -width 20 -height 5 - pack append .t2 .t2.t top - wm geometry .t2 +0+0 - .t2.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns" - .t2.t yview 3.0 - update - .t2.t delete 2.0 4.0 - list [.t2.t index @0,0] [.t2.t get @0,0] -} {2.0 y} -catch {destroy .t2} -toplevel .t2 -text .t2.t -width 1 -height 10 -wrap char -frame .t2.f -width 200 -height 20 -relief raised -bd 2 -pack .t2.f .t2.t -side left -wm geometry .t2 +0+0 -update -test text-17.13 {DeleteChars procedure, updates affecting topIndex} { - .t2.t delete 1.0 end - .t2.t insert end "abcde\n12345\nqrstuv" - .t2.t yview 2.1 - .t2.t delete 1.4 2.3 - .t2.t index @0,0 -} {1.2} -test text-17.14 {DeleteChars procedure, updates affecting topIndex} { - .t2.t delete 1.0 end - .t2.t insert end "abcde\n12345\nqrstuv" - .t2.t yview 2.1 - .t2.t delete 2.3 2.4 - .t2.t index @0,0 -} {2.0} -test text-17.15 {DeleteChars procedure, updates affecting topIndex} { - .t2.t delete 1.0 end - .t2.t insert end "abcde\n12345\nqrstuv" - .t2.t yview 1.3 - .t2.t delete 1.0 1.2 - .t2.t index @0,0 -} {1.1} -test text-17.16 {DeleteChars procedure, updates affecting topIndex} { - catch {destroy .t2} - toplevel .t2 - text .t2.t -width 6 -height 10 -wrap word - frame .t2.f -width 200 -height 20 -relief raised -bd 2 - pack .t2.f .t2.t -side left - wm geometry .t2 +0+0 - update - .t2.t insert end "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n" - .t2.t yview 2.4 - .t2.t delete 2.5 - set x [.t2.t index @0,0] - .t2.t delete 2.5 - list $x [.t2.t index @0,0] -} {2.3 2.0} - -.t delete 1.0 end -foreach i {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} { - .t insert end $i.0$i.1$i.2$i.3$i.4\n -} -test text-18.1 {TextFetchSelection procedure} { +test text-19.11 {DeleteChars procedure} -body { + toplevel .top + text .top.t -width 20 -height 5 + pack append .top .top.t top + wm geometry .top +0+0 + .top.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns" + update + .top.t delete 1.0 3.0 + list [.top.t index @0,0] [.top.t get @0,0] +} -cleanup { + destroy .top +} -result {1.0 x} +test text-19.12 {DeleteChars procedure} -body { + toplevel .top + text .top.t -width 20 -height 5 + pack append .top .top.t top + wm geometry .top +0+0 + .top.t insert 1.0 "abc\n123\nx\ny\nz\nq\nr\ns" + .top.t yview 3.0 + update + .top.t delete 2.0 4.0 + list [.top.t index @0,0] [.top.t get @0,0] +} -cleanup { + destroy .top +} -result {2.0 y} +test text-19.13 {DeleteChars procedure, updates affecting topIndex} -setup { + toplevel .top + text .top.t -width 1 -height 10 -wrap char + pack .top.t -side left + wm geometry .top +0+0 + update +} -body { + .top.t insert end "abcde\n12345\nqrstuv" + .top.t yview 2.1 + .top.t delete 1.4 2.3 + .top.t index @0,0 +} -cleanup { + destroy .top +} -result {1.2} +test text-19.14 {DeleteChars procedure, updates affecting topIndex} -setup { + toplevel .top + text .top.t -width 1 -height 10 -wrap char + pack .top.t -side left + wm geometry .top +0+0 + update +} -body { + .top.t insert end "abcde\n12345\nqrstuv" + .top.t yview 2.1 + .top.t delete 2.3 2.4 + .top.t index @0,0 +} -cleanup { + destroy .top +} -result {2.0} +test text-19.15 {DeleteChars procedure, updates affecting topIndex} -setup { + toplevel .top + text .top.t -width 1 -height 10 -wrap char + pack .top.t -side left + wm geometry .top +0+0 + update +} -body { + .top.t insert end "abcde\n12345\nqrstuv" + .top.t yview 1.3 + .top.t delete 1.0 1.2 + .top.t index @0,0 +} -cleanup { + destroy .top +} -result {1.1} +test text-19.16 {DeleteChars procedure, updates affecting topIndex} -setup { + toplevel .top + text .top.t -width 6 -height 10 -wrap word + frame .top.f -width 200 -height 20 -relief raised -bd 2 + pack .top.f .top.t -side left + wm geometry .top +0+0 + update +} -body { + .top.t insert end "abc def\n01 2345 678 9101112\nLine 3\nLine 4\nLine 5\n6\n7\n8\n" + .top.t yview 2.4 + .top.t delete 2.5 + set x [.top.t index @0,0] + .top.t delete 2.5 + list $x [.top.t index @0,0] +} -cleanup { + destroy .top +} -result {2.3 2.0} + + +test text-20.1 {TextFetchSelection procedure} -setup { + text .t -width 20 -height 10 + pack append . .t {top expand fill} + update +} -body { + foreach i {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} { + .t insert end $i.0$i.1$i.2$i.3$i.4\n + } .t tag add sel 1.3 3.4 selection get -} {a.1a.2a.3a.4 +} -cleanup { + destroy .t +} -result {a.1a.2a.3a.4 b.0b.1b.2b.3b.4 c.0c} -test text-18.2 {TextFetchSelection procedure} { +test text-20.2 {TextFetchSelection procedure} -setup { + text .t -width 20 -height 10 + pack append . .t {top expand fill} + update +} -body { + foreach i {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} { + .t insert end $i.0$i.1$i.2$i.3$i.4\n + } .t tag add x 1.2 .t tag add x 1.4 .t tag add x 2.0 @@ -1307,15 +3572,33 @@ test text-18.2 {TextFetchSelection procedure} { .t tag remove sel 1.0 end .t tag add sel 1.0 3.4 selection get -} {a.0a.1a.2a.3a.4 +} -cleanup { + destroy .t +} -result {a.0a.1a.2a.3a.4 b.0b.1b.2b.3b.4 c.0c} -test text-18.3 {TextFetchSelection procedure} { +test text-20.3 {TextFetchSelection procedure} -setup { + text .t -width 20 -height 10 + pack append . .t {top expand fill} + update +} -body { + foreach i {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} { + .t insert end $i.0$i.1$i.2$i.3$i.4\n + } .t tag remove sel 1.0 end .t tag add sel 13.3 selection get -} {m} -test text-18.4 {TextFetchSelection procedure} { +} -cleanup { + destroy .t +} -result {m} +test text-20.4 {TextFetchSelection procedure} -setup { + text .t -width 20 -height 10 + pack append . .t {top expand fill} + update +} -body { + foreach i {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} { + .t insert end $i.0$i.1$i.2$i.3$i.4\n + } .t tag remove x 1.0 end .t tag add sel 1.0 3.4 .t tag remove sel 1.0 end @@ -1324,674 +3607,1043 @@ test text-18.4 {TextFetchSelection procedure} { .t tag add sel 10.0 10.end .t tag add sel 13.3 selection get -} {0a..1b.2b.3b.4 +} -cleanup { + destroy .t +} -result {0a..1b.2b.3b.4 cj.0j.1j.2j.3j.4m} -set x "" -for {set i 1} {$i < 200} {incr i} { - append x "This is line $i, padded to just about 53 characters.\n" -} -test text-18.5 {TextFetchSelection procedure, long selections} { - .t delete 1.0 end +test text-20.5 {TextFetchSelection procedure, long selections} -setup { + text .t -width 20 -height 10 + pack append . .t {top expand fill} + update + set x "" +} -body { + for {set i 1} {$i < 200} {incr i} { + append x "This is line $i, padded to just about 53 characters.\n" + } .t insert end $x .t tag add sel 1.0 end - selection get -} $x\n + expr {[selection get] eq "$x\n"} +} -cleanup { + destroy .t +} -result {1} + -test text-19.1 {TkTextLostSelection procedure} unix { - catch {destroy .t2} +test text-21.1 {TkTextLostSelection procedure} -constraints unix -setup { + text .t + .t insert 1.0 "Line 1" + entry .t.e + .t.e insert end "abcdefg" text .t2 .t2 insert 1.0 "abc\ndef\nghijk\n1234" +} -body { .t2 tag add sel 1.2 3.3 + .t.e select from 0 .t.e select to 1 .t2 tag ranges sel -} {} -test text-19.2 {TkTextLostSelection procedure} win { - catch {destroy .t2} +} -cleanup { + destroy .t .t2 +} -result {} +test text-21.2 {TkTextLostSelection procedure} -constraints win -setup { + text .t + .t insert 1.0 "Line 1" + entry .t.e + .t.e insert end "abcdefg" text .t2 .t2 insert 1.0 "abc\ndef\nghijk\n1234" +} -body { .t2 tag add sel 1.2 3.3 + .t.e select from 0 .t.e select to 1 .t2 tag ranges sel -} {1.2 3.3} -catch {destroy .t2} -test text-19.3 {TkTextLostSelection procedure} { - catch {destroy .t2} - text .t2 - .t2 insert 1.0 "abcdef\nghijk\n1234" - .t2 tag add sel 1.0 1.3 +} -cleanup { + destroy .t .t2 +} -result {1.2 3.3} +test text-21.3 {TkTextLostSelection procedure} -body { + text .t + .t insert 1.0 "abcdef\nghijk\n1234" + .t tag add sel 1.0 1.3 + selection get + selection clear + selection get +} -cleanup { + destroy .t +} -returnCodes error -result {PRIMARY selection doesn't exist or form "STRING" not defined} +test text-21.4 {TkTextLostSelection procedure} -body { + text .t + .t insert 1.0 "abcdef\nghijk\n1234" + .t tag add sel 1.0 1.3 set x [selection get] selection clear - lappend x [catch {selection get} msg] $msg - .t2 tag add sel 1.0 1.3 + catch {selection get} + .t tag add sel 1.0 1.3 lappend x [selection get] -} {abc 1 {PRIMARY selection doesn't exist or form "STRING" not defined} abc} - -.t delete 1.0 end -.t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" -test text-20.1 {TextSearchCmd procedure, argument parsing} { - list [catch {.t search -} msg] $msg -} {1 {bad switch "-": must be --, -all, -backward, -count, -elide, -exact, -forward, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits}} -test text-20.2 {TextSearchCmd procedure, -backwards option} { +} -cleanup { + destroy .t +} -result {abc abc} + + +test text-22.1 {TextSearchCmd procedure, argument parsing} -body { + text .t + .t search - +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad switch "-": must be --, -all, -backward, -count, -elide, -exact, -forward, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits} +test text-22.2 {TextSearchCmd procedure, -backwards option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards xyz 1.4 -} {1.1} -test text-20.2.1 {TextSearchCmd procedure, -all option} { +} -cleanup { + destroy .t +} -result {1.1} +test text-22.3 {TextSearchCmd procedure, -all option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -all xyz 1.4 -} {1.5 3.0 3.5 1.1} -test text-20.3 {TextSearchCmd procedure, -forwards option} { +} -cleanup { + destroy .t +} -result {1.5 3.0 3.5 1.1} +test text-22.4 {TextSearchCmd procedure, -forwards option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -forwards xyz 1.4 -} {1.5} -test text-20.4 {TextSearchCmd procedure, -exact option} { +} -cleanup { + destroy .t +} -result {1.5} +test text-22.5 {TextSearchCmd procedure, -exact option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -f -exact x. 1.0 -} {1.9} -test text-20.5 {TextSearchCmd procedure, -regexp option} { +} -cleanup { + destroy .t +} -result {1.9} +test text-22.6 {TextSearchCmd procedure, -regexp option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -b -regexp x.z 1.4 -} {1.1} -test text-20.6 {TextSearchCmd procedure, -count option} { +} -cleanup { + destroy .t +} -result {1.1} +test text-22.7 {TextSearchCmd procedure, -count option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" set length unmodified list [.t search -count length x. 1.4] $length -} {1.9 2} -test text-20.7 {TextSearchCmd procedure, -count option} { - list [catch {.t search -count} msg] $msg -} {1 {no value given for "-count" option}} -test text-20.8 {TextSearchCmd procedure, -nocase option} { +} -cleanup { + destroy .t +} -result {1.9 2} +test text-22.8 {TextSearchCmd procedure, -count option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search -count +} -cleanup { + destroy .t +} -returnCodes {error} -result {no value given for "-count" option} +test text-22.9 {TextSearchCmd procedure, -nocase option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" list [.t search -nocase BaR 1.1] [.t search BaR 1.1] -} {2.13 2.23} -test text-20.9 {TextSearchCmd procedure, -n ambiguous option} { - list [catch {.t search -n BaR 1.1} msg] $msg -} {1 {bad switch "-n": must be --, -all, -backward, -count, -elide, -exact, -forward, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits}} -test text-20.9.1 {TextSearchCmd procedure, -nocase option} { +} -cleanup { + destroy .t +} -result {2.13 2.23} +test text-22.10 {TextSearchCmd procedure, -n ambiguous option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search -n BaR 1.1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad switch "-n": must be --, -all, -backward, -count, -elide, -exact, -forward, -nocase, -nolinestop, -overlap, -regexp, or -strictlimits} +test text-22.11 {TextSearchCmd procedure, -nocase option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -noc BaR 1.1 -} {2.13} -test text-20.9.2 {TextSearchCmd procedure, -nolinestop option} { - list [catch {.t search -nolinestop BaR 1.1} msg] $msg -} {1 {the "-nolinestop" option requires the "-regexp" option to be present}} -test text-20.9.3 {TextSearchCmd procedure, -nolinestop option} { +} -cleanup { + destroy .t +} -result {2.13} +test text-22.12 {TextSearchCmd procedure, -nolinestop option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search -nolinestop BaR 1.1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {the "-nolinestop" option requires the "-regexp" option to be present} +test text-22.13 {TextSearchCmd procedure, -nolinestop option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" set msg "" list [.t search -nolinestop -regexp -count msg e.*o 1.1] $msg -} {1.14 32} -test text-20.10 {TextSearchCmd procedure, -- option} { +} -cleanup { + destroy .t +} -result {1.14 32} +test text-22.14 {TextSearchCmd procedure, -- option} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -- -forward 1.0 -} {2.4} -test text-20.11 {TextSearchCmd procedure, argument parsing} { - list [catch {.t search abc} msg] $msg -} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"}} -test text-20.12 {TextSearchCmd procedure, argument parsing} { - list [catch {.t search abc d e f} msg] $msg -} {1 {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"}} -test text-20.13 {TextSearchCmd procedure, check index} { - list [catch {.t search abc gorp} msg] $msg -} {1 {bad text index "gorp"}} -test text-20.14 {TextSearchCmd procedure, startIndex == "end"} { +} -cleanup { + destroy .t +} -result {2.4} +test text-22.15 {TextSearchCmd procedure, argument parsing} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search abc +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"} +test text-22.16 {TextSearchCmd procedure, argument parsing} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search abc d e f +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t search ?switches? pattern index ?stopIndex?"} +test text-22.17 {TextSearchCmd procedure, check index} -body { + text .t + .t search abc gorp +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "gorp"} +test text-22.18 {TextSearchCmd procedure, startIndex == "end"} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search non-existent end -} {} -test text-20.15 {TextSearchCmd procedure, startIndex == "end"} { +} -cleanup { + destroy .t +} -result {} +test text-22.19 {TextSearchCmd procedure, startIndex == "end"} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search non-existent end -} {} -test text-20.16 {TextSearchCmd procedure, bad stopIndex} { - list [catch {.t search abc 1.0 lousy} msg] $msg -} {1 {bad text index "lousy"}} -test text-20.17 {TextSearchCmd procedure, pattern case conversion} { +} -cleanup { + destroy .t +} -result {} +test text-22.20 {TextSearchCmd procedure, bad stopIndex} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search abc 1.0 lousy +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "lousy"} +test text-22.21 {TextSearchCmd procedure, pattern case conversion} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" list [.t search -nocase BAR 1.1] [.t search BAR 1.1] -} {2.13 {}} -test text-20.18 {TextSearchCmd procedure, bad regular expression pattern} { - list [catch {.t search -regexp a( 1.0} msg] $msg -} {1 {couldn't compile regular expression pattern: parentheses () not balanced}} -test text-20.19 {TextSearchCmd procedure, skip dummy last line} { +} -cleanup { + destroy .t +} -result {2.13 {}} +test text-22.22 {TextSearchCmd procedure, bad regular expression pattern} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + .t search -regexp a( 1.0 +} -cleanup { + destroy .t +} -returnCodes {error} -result {couldn't compile regular expression pattern: parentheses () not balanced} +test text-22.23 {TextSearchCmd procedure, skip dummy last line} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards BaR end 1.0 -} {2.23} -test text-20.20 {TextSearchCmd procedure, skip dummy last line} { +} -cleanup { + destroy .t +} -result {2.23} +test text-22.24 {TextSearchCmd procedure, skip dummy last line} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards \n end 1.0 -} {3.9} -test text-20.21 {TextSearchCmd procedure, skip dummy last line} { +} -cleanup { + destroy .t +} -result {3.9} +test text-22.25 {TextSearchCmd procedure, skip dummy last line} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search \n end -} {1.15} -test text-20.22 {TextSearchCmd procedure, skip dummy last line} { +} -cleanup { + destroy .t +} -result {1.15} +test text-22.26 {TextSearchCmd procedure, skip dummy last line} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -back \n 1.0 -} {3.9} -test text-20.23 {TextSearchCmd procedure, extract line contents} { +} -cleanup { + destroy .t +} -result {3.9} +test text-22.27 {TextSearchCmd procedure, extract line contents} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t tag add foo 1.2 .t tag add x 1.3 .t mark set silly 1.2 .t search xyz 3.6 -} {1.1} -test text-20.24 {TextSearchCmd procedure, stripping newlines} { +} -cleanup { + destroy .t +} -result {1.1} +test text-22.28 {TextSearchCmd procedure, stripping newlines} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search the\n 1.0 -} {1.12} -test text-20.25 {TextSearchCmd procedure, handling newlines} { +} -cleanup { + destroy .t +} -result {1.12} +test text-22.29 {TextSearchCmd procedure, handling newlines} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -regexp the\n 1.0 -} {1.12} -test text-20.26 {TextSearchCmd procedure, stripping newlines} { +} -cleanup { + destroy .t +} -result {1.12} +test text-22.30 {TextSearchCmd procedure, stripping newlines} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -regexp {the$} 1.0 -} {1.12} -test text-20.27 {TextSearchCmd procedure, handling newlines} { +} -cleanup { + destroy .t +} -result {1.12} +test text-22.31 {TextSearchCmd procedure, handling newlines} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -regexp \n 1.0 -} {1.15} -test text-20.28 {TextSearchCmd procedure, line case conversion} { +} -cleanup { + destroy .t +} -result {1.15} +test text-22.32 {TextSearchCmd procedure, line case conversion} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" list [.t search -nocase bar 2.18] [.t search bar 2.18] -} {2.23 2.13} -test text-20.29 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {2.23 2.13} +test text-22.33 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards xyz 1.6 -} {1.5} -test text-20.30 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {1.5} +test text-22.34 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards xyz 1.5 -} {1.1} -test text-20.31 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {1.1} +test text-22.35 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search xyz 1.5 -} {1.5} -test text-20.32 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {1.5} +test text-22.36 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search xyz 1.6 -} {3.0} -test text-20.33 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {3.0} +test text-22.37 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search {} 1.end -} {1.15} -test text-20.34 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {1.15} +test text-22.38 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search f 1.end -} {2.0} -test text-20.35 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {2.0} +test text-22.39 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search {} end -} {1.0} -test text-20.35a {TextSearchCmd procedure, regexp finds empty lines} { - # Test for fix of bug #1643 +} -cleanup { + destroy .t +} -result {1.0} +test text-22.40 {TextSearchCmd procedure, regexp finds empty lines} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" +# Test for fix of bug #1643 .t insert end "\n" tk::TextSetCursor .t 4.0 .t search -forward -regexp {^$} insert end -} {4.0} - -catch {destroy .t2} -toplevel .t2 -wm geometry .t2 +0+0 -text .t2.t -width 30 -height 10 -pack .t2.t -.t2.t insert 1.0 "This is a line\nand this is another" -.t2.t insert end "\nand this is yet another" -frame .t2.f -width 20 -height 20 -bd 2 -relief raised -.t2.t window create 2.5 -window .t2.f -test text-20.36 {TextSearchCmd procedure, firstChar and lastChar} { - .t2.t search his 2.6 -} {2.6} -test text-20.37 {TextSearchCmd procedure, firstChar and lastChar} { - .t2.t search this 2.6 -} {3.4} -test text-20.38 {TextSearchCmd procedure, firstChar and lastChar} { - .t2.t search is 2.6 -} {2.7} -test text-20.39 {TextSearchCmd procedure, firstChar and lastChar} { - .t2.t search his 2.7 -} {3.5} -test text-20.40 {TextSearchCmd procedure, firstChar and lastChar} { - .t2.t search -backwards "his is another" 2.6 -} {2.6} -test text-20.41 {TextSearchCmd procedure, firstChar and lastChar} { - .t2.t search -backwards "his is" 2.6 -} {1.1} -destroy .t2 -test text-20.42 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {4.0} +test text-22.41 {TextSearchCmd procedure, firstChar and lastChar} -setup { + toplevel .top + text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .top.t +} -body { + .top.t insert 1.0 "This is a line\nand this is another" + .top.t insert end "\nand this is yet another" + frame .top.f -width 20 -height 20 -bd 2 -relief raised + .top.t window create 2.5 -window .top.f + .top.t search his 2.6 +} -cleanup { + destroy .top +} -result {2.6} +test text-22.42 {TextSearchCmd procedure, firstChar and lastChar} -setup { + toplevel .top + text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .top.t +} -body { + .top.t insert 1.0 "This is a line\nand this is another" + .top.t insert end "\nand this is yet another" + frame .top.f -width 20 -height 20 -bd 2 -relief raised + .top.t window create 2.5 -window .top.f + .top.t search this 2.6 +} -cleanup { + destroy .top +} -result {3.4} +test text-22.43 {TextSearchCmd procedure, firstChar and lastChar} -setup { + toplevel .top + text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .top.t +} -body { + .top.t insert 1.0 "This is a line\nand this is another" + .top.t insert end "\nand this is yet another" + frame .top.f -width 20 -height 20 -bd 2 -relief raised + .top.t window create 2.5 -window .top.f + .top.t search is 2.6 +} -cleanup { + destroy .top +} -result {2.7} +test text-22.44 {TextSearchCmd procedure, firstChar and lastChar} -setup { + toplevel .top + text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .top.t +} -body { + .top.t insert 1.0 "This is a line\nand this is another" + .top.t insert end "\nand this is yet another" + frame .top.f -width 20 -height 20 -bd 2 -relief raised + .top.t window create 2.5 -window .top.f + .top.t search his 2.7 +} -cleanup { + destroy .top +} -result {3.5} +test text-22.45 {TextSearchCmd procedure, firstChar and lastChar} -setup { + toplevel .top + text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .top.t +} -body { + .top.t insert 1.0 "This is a line\nand this is another" + .top.t insert end "\nand this is yet another" + frame .top.f -width 20 -height 20 -bd 2 -relief raised + .top.t window create 2.5 -window .top.f + .top.t search -backwards "his is another" 2.6 +} -cleanup { + destroy .top +} -result {2.6} +test text-22.46 {TextSearchCmd procedure, firstChar and lastChar} -setup { + toplevel .top + text .top.t -width 30 -height 10 -font {Courier -12} -borderwidth 2 -highlightthickness 2 + pack .top.t +} -body { + .top.t insert 1.0 "This is a line\nand this is another" + .top.t insert end "\nand this is yet another" + frame .top.f -width 20 -height 20 -bd 2 -relief raised + .top.t window create 2.5 -window .top.f + .top.t search -backwards "his is" 2.6 +} -cleanup { + destroy .top +} -result {1.1} +test text-22.47 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards forw 2.5 -} {2.5} -test text-20.43 {TextSearchCmd procedure, firstChar and lastChar} { +} -cleanup { + destroy .t +} -result {2.5} +test text-22.48 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search forw 2.5 -} {2.5} -test text-20.44 {TextSearchCmd procedure, firstChar and lastChar} { - catch {destroy .t2} +} -cleanup { + destroy .t +} -result {2.5} +test text-22.49 {TextSearchCmd procedure, firstChar and lastChar} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" + catch {destroy .t} text .t2 list [.t2 search a 1.0] [.t2 search -backward a 1.0] -} {{} {}} -test text-20.45 {TextSearchCmd procedure, regexp match length} { +} -cleanup { + destroy .t .t2 +} -result {{} {}} +test text-22.50 {TextSearchCmd procedure, regexp match length} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" set length unchanged list [.t search -regexp -count length x(.)(.*)z 1.1] $length -} {1.1 7} -test text-20.46 {TextSearchCmd procedure, regexp match length} { +} -cleanup { + destroy .t +} -result {1.1 7} +test text-22.51 {TextSearchCmd procedure, regexp match length} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" set length unchanged list [.t search -regexp -backward -count length fo* 2.5] $length -} {2.0 3} -test text-20.47 {TextSearchCmd procedure, checking stopIndex} { +} -cleanup { + destroy .t +} -result {2.0 3} +test text-22.52 {TextSearchCmd procedure, checking stopIndex} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" list [.t search bar 2.1 2.13] [.t search bar 2.1 2.14] \ [.t search bar 2.12 2.14] [.t search bar 2.14 2.14] -} {{} 2.13 2.13 {}} -test text-20.48 {TextSearchCmd procedure, checking stopIndex} { +} -cleanup { + destroy .t +} -result {{} 2.13 2.13 {}} +test text-22.53 {TextSearchCmd procedure, checking stopIndex} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" list [.t search -backwards bar 2.20 2.13] \ [.t search -backwards bar 2.20 2.14] \ [.t search -backwards bar 2.14 2.13] \ [.t search -backwards bar 2.13 2.13] -} {2.13 {} 2.13 {}} -test text-20.48.1 {TextSearchCmd procedure, checking stopIndex} { +} -cleanup { + destroy .t +} -result {2.13 {} 2.13 {}} +test text-22.54 {TextSearchCmd procedure, checking stopIndex} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" list [.t search -backwards -strict bar 2.20 2.13] \ [.t search -backwards -strict bar 2.20 2.14] \ [.t search -backwards -strict bar 2.14 2.13] \ [.t search -backwards -strict bar 2.13 2.13] -} {2.13 {} {} {}} -test text-20.49 {TextSearchCmd procedure, embedded windows and index/count} { +} -cleanup { + destroy .t +} -result {2.13 {} {} {}} +test text-22.55 {TextSearchCmd procedure, embedded windows and index/count} -setup { + text .t frame .t.f1 -width 20 -height 20 -relief raised -bd 2 frame .t.f2 -width 20 -height 20 -relief raised -bd 2 frame .t.f3 -width 20 -height 20 -relief raised -bd 2 frame .t.f4 -width 20 -height 20 -relief raised -bd 2 + set result "" +} -body { + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t window create 2.10 -window .t.f3 .t window create 2.8 -window .t.f2 .t window create 2.8 -window .t.f1 .t window create 2.1 -window .t.f4 - set result "" lappend result [.t search -count x forward 1.0] $x lappend result [.t search -count x wa 1.0] $x - .t delete 2.1 - .t delete 2.8 2.10 - .t delete 2.10 - set result -} {2.6 10 2.11 2} -test text-20.50 {TextSearchCmd procedure, error setting variable} { - catch {unset a} + return $result +} -cleanup { + destroy .t +} -result {2.6 10 2.11 2} +test text-22.56 {TextSearchCmd procedure, error setting variable} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" set a 44 - list [catch {.t search -count a(2) xyz 1.0} msg] $msg -} {1 {can't set "a(2)": variable isn't array}} -test text-20.51 {TextSearchCmd procedure, wrap-around} { + .t search -count a(2) xyz 1.0 +} -cleanup { + destroy .t +} -returnCodes {error} -result {can't set "a(2)": variable isn't array} +test text-22.57 {TextSearchCmd procedure, wrap-around} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards xyz 1.1 -} {3.5} -test text-20.52 {TextSearchCmd procedure, wrap-around} { +} -cleanup { + destroy .t +} -result {3.5} +test text-22.58 {TextSearchCmd procedure, wrap-around} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -backwards xyz 1.1 1.0 -} {} -test text-20.53 {TextSearchCmd procedure, wrap-around} { +} -cleanup { + destroy .t +} -result {} +test text-22.59 {TextSearchCmd procedure, wrap-around} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search xyz 3.6 -} {1.1} -test text-20.54 {TextSearchCmd procedure, wrap-around} { +} -cleanup { + destroy .t +} -result {1.1} +test text-22.60 {TextSearchCmd procedure, wrap-around} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search xyz 3.6 end -} {} -test text-20.55 {TextSearchCmd procedure, no match} { +} -cleanup { + destroy .t +} -result {} +test text-22.61 {TextSearchCmd procedure, no match} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search non_existent 3.5 -} {} -test text-20.56 {TextSearchCmd procedure, no match} { +} -cleanup { + destroy .t +} -result {} +test text-22.62 {TextSearchCmd procedure, no match} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -regexp non_existent 3.5 -} {} -test text-20.57 {TextSearchCmd procedure, special cases} { +} -cleanup { + destroy .t +} -result {} +test text-22.63 {TextSearchCmd procedure, special cases} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -back x 1.1 -} {1.0} -test text-20.58 {TextSearchCmd procedure, special cases} { +} -cleanup { + destroy .t +} -result {1.0} +test text-22.64 {TextSearchCmd procedure, special cases} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search -back x 1.0 -} {3.8} -test text-20.59 {TextSearchCmd procedure, special cases} { +} -cleanup { + destroy .t +} -result {3.8} +test text-22.65 {TextSearchCmd procedure, special cases} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search \n {end-2c} -} {3.9} -test text-20.60 {TextSearchCmd procedure, special cases} { +} -cleanup { + destroy .t +} -result {3.9} +test text-22.66 {TextSearchCmd procedure, special cases} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search \n end -} {1.15} -test text-20.61 {TextSearchCmd procedure, special cases} { +} -cleanup { + destroy .t +} -result {1.15} +test text-22.67 {TextSearchCmd procedure, special cases} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" .t search x 1.0 -} {1.0} -test text-20.62 {TextSearchCmd, freeing copy of pattern} { - # This test doesn't return a result, but it will generate - # a core leak if the pattern copy isn't properly freed. - # (actually in Tk 8.5 objectification means there is no - # longer a copy of the pattern, but we leave this test in - # anyway). +} -cleanup { + destroy .t +} -result {1.0} +test text-22.68 {TextSearchCmd, freeing copy of pattern} -body { + text .t + .t insert end "xxyz xyz x. the\nfoo -forward bar xxxxx BaR foo\nxyz xxyzx" +# This test doesn't return a result, but it will generate +# a core leak if the pattern copy isn't properly freed. +# (actually in Tk 8.5 objectification means there is no +# longer a copy of the pattern, but we leave this test in +# anyway). set p abcdefg1234567890 set p $p$p$p$p$p$p$p$p set p $p$p$p$p$p .t search -nocase $p 1.0 -} {} -test text-20.63 {TextSearchCmd, unicode} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {} +test text-22.69 {TextSearchCmd, unicode} -body { + text .t .t insert end "foo\u30c9\u30cabar" .t search \u30c9\u30ca 1.0 -} 1.3 -test text-20.64 {TextSearchCmd, unicode} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {1.3} +test text-22.70 {TextSearchCmd, unicode} -body { + text .t .t insert end "foo\u30c9\u30cabar" list [.t search -count n \u30c9\u30ca 1.0] $n -} {1.3 2} -test text-20.65 {TextSearchCmd, unicode with non-text segments} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {1.3 2} +test text-22.71 {TextSearchCmd, unicode with non-text segments} -body { + text .t button .b1 -text baz .t insert end "foo\u30c9" .t window create end -window .b1 .t insert end "\u30cabar" - set result [list [.t search -count n \u30c9\u30ca 1.0] $n] - destroy .b1 - set result -} {1.3 3} -test text-20.66 {TextSearchCmd, hidden text does not affect match index} { - deleteWindows - pack [text .t2] - .t2 insert end "12345H7890" - .t2 search 7 1.0 -} 1.6 -test text-20.67 {TextSearchCmd, hidden text does not affect match index} { - deleteWindows - pack [text .t2] - .t2 insert end "12345H7890" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.5 - .t2 search 7 1.0 -} 1.6 -test text-20.68 {TextSearchCmd, hidden text does not affect match index} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nbarbaz\nbazboo" - .t2 search boo 1.0 -} 3.3 -test text-20.69 {TextSearchCmd, hidden text does not affect match index} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nbarbaz\nbazboo" - .t2 tag configure hidden -elide true - .t2 tag add hidden 2.0 3.0 - .t2 search boo 1.0 -} 3.3 -test text-20.70 {TextSearchCmd, -regexp -nocase searches} { - catch {destroy .t} + list [.t search -count n \u30c9\u30ca 1.0] $n +} -cleanup { + destroy .t .b1 +} -result {1.3 3} +test text-22.72 {TextSearchCmd, hidden text does not affect match index} -body { + pack [text .t] + .t insert end "12345H7890" + .t search 7 1.0 +} -cleanup { + destroy .t +} -result {1.6} +test text-22.73 {TextSearchCmd, hidden text does not affect match index} -body { + pack [text .t] + .t insert end "12345H7890" + .t tag configure hidden -elide true + .t tag add hidden 1.5 + .t search 7 1.0 +} -cleanup { + destroy .t +} -result {1.6} +test text-22.74 {TextSearchCmd, hidden text does not affect match index} -body { + pack [text .t] + .t insert end "foobar\nbarbaz\nbazboo" + .t search boo 1.0 +} -cleanup { + destroy .t +} -result {3.3} +test text-22.75 {TextSearchCmd, hidden text does not affect match index} -body { + pack [text .t] + .t insert end "foobar\nbarbaz\nbazboo" + .t tag configure hidden -elide true + .t tag add hidden 2.0 3.0 + .t search boo 1.0 +} -cleanup { + destroy .t +} -result {3.3} +test text-22.76 {TextSearchCmd, -regexp -nocase searches} -body { pack [text .t] .t insert end "word1 word2" - set res [.t search -nocase -regexp {\mword.} 1.0 end] + .t search -nocase -regexp {\mword.} 1.0 end +} -cleanup { destroy .t - set res -} 1.0 -test text-20.71 {TextSearchCmd, -regexp -nocase searches} { - catch {destroy .t} +} -result {1.0} +test text-22.77 {TextSearchCmd, -regexp -nocase searches} -body { pack [text .t] .t insert end "word1 word2" - set res [.t search -nocase -regexp {word.\M} 1.0 end] + .t search -nocase -regexp {word.\M} 1.0 end +} -cleanup { destroy .t - set res -} 1.0 -test text-20.72 {TextSearchCmd, -regexp -nocase searches} { - catch {destroy .t} +} -result {1.0} +test text-22.78 {TextSearchCmd, -regexp -nocase searches} -body { pack [text .t] .t insert end "word1 word2" - set res [.t search -nocase -regexp {word.\W} 1.0 end] - destroy .t - set res -} 1.0 -test text-20.73 {TextSearchCmd, hidden text and start index} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search bar 1.3 -} 1.3 -test text-20.74 {TextSearchCmd, hidden text shouldn't influence start index} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.0 1.2 - .t2 search bar 1.3 -} 1.3 -test text-20.75 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - list [.t2 search -count foo foar 1.3] $foo -} {1.0 6} -test text-20.75.1 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 + .t search -nocase -regexp {word.\W} 1.0 end +} -cleanup { + destroy .t +} -result {1.0} +test text-22.79 {TextSearchCmd, hidden text and start index} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search bar 1.3 +} -cleanup { + destroy .t +} -result {1.3} +test text-22.80 {TextSearchCmd, hidden text shouldn't influence start index} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.0 1.2 + .t search bar 1.3 +} -cleanup { + destroy .t +} -result {1.3} +test text-22.81 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + list [.t search -count foo foar 1.3] $foo +} -cleanup { + destroy .t +} -result {1.0 6} +test text-22.82 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 list \ - [.t2 search -strict -count foo foar 1.3] \ - [.t2 search -strict -count foo foar 2.3] $foo -} {{} 1.0 6} -test text-20.76 {TextSearchCmd, hidden text and start index} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -regexp bar 1.3 -} 1.3 -test text-20.77 {TextSearchCmd, hidden text shouldn't influence start index} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.0 1.2 - .t2 search -regexp bar 1.3 -} 1.3 -test text-20.78 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - list [.t2 search -regexp -count foo foar 1.3] $foo -} {1.0 6} -test text-20.78.1 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - list [.t2 search -count foo foar 1.3] $foo -} {1.0 6} -test text-20.78.2 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - .t2 search -strict -count foo foar 1.3 -} {} -test text-20.78.3 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - .t2 tag add hidden 2.2 2.4 - list [.t2 search -regexp -all -count foo foar 1.3] $foo -} {{2.0 3.0 1.0} {6 4 6}} -test text-20.78.4 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - .t2 tag add hidden 2.2 2.4 - list [.t2 search -all -count foo foar 1.3] $foo -} {{2.0 3.0 1.0} {6 4 6}} -test text-20.78.5 {TextSearchCmd, hidden text inside match must count in length} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoar" - .t2 tag configure hidden -elide true - .t2 tag add hidden 1.2 1.4 - .t2 tag add hidden 2.2 2.4 - list [.t2 search -strict -all -count foo foar 1.3] $foo -} {{2.0 3.0} {6 4}} -test text-20.78.6 {TextSearchCmd, single line with -all} { - deleteWindows - pack [text .t2] - .t2 insert end " X\n X\n X\n X\n X\n X\n" - .t2 search -all -regexp { +| *\n} 1.0 end -} {1.0 1.2 2.0 2.2 3.0 3.2 4.0 4.2 5.0 5.2 6.0 6.2 7.0} -test text-20.79 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -count foo foobar\nfoo 1.0] $foo -} {1.0 10} -test text-20.80 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -count foo bar\nfoo 1.0] $foo -} {1.3 7} -test text-20.81 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -count foo \nfoo 1.0] $foo -} {1.6 4} -test text-20.82 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -count foo bar\nfoobar\nfoo 1.0] $foo -} {1.3 14} -test text-20.83 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -count foo bar\nfoobar\nfoobanearly 1.0 -} {} -test text-20.84 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -regexp -count foo foobar\nfoo 1.0] $foo -} {1.0 10} -test text-20.85 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -regexp -count foo bar\nfoo 1.0] $foo -} {1.3 7} -test text-20.86 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -regexp -count foo \nfoo 1.0] $foo -} {1.6 4} -test text-20.87 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -regexp -count foo bar\nfoobar\nfoo 1.0] $foo -} {1.3 14} -test text-20.88 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -regexp -count foo bar\nfoobar\nfoobanearly 1.0 -} {} -test text-20.89 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfaoobar\nfoobar" - .t2 search -regexp -count foo bar\nfoo 1.0 -} {2.4} -test text-20.90 {TextSearchCmd, multiline matching end of window} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfaoobar\nfoobar" - .t2 search -regexp -count foo bar\nfoobar\n\n 1.0 -} {} -test text-20.91 {TextSearchCmd, multiline matching end of window} { - deleteWindows - pack [text .t2] - .t2 search "\n\n" 1.0 -} {} -test text-20.92 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -count foo foobar\nfoo end] $foo -} {2.0 10} -test text-20.93 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -count foo bar\nfoo 1.0] $foo -} {2.3 7} -test text-20.94 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -count foo \nfoo 1.0] $foo -} {2.6 4} -test text-20.95 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -count foo bar\nfoobar\nfoo 1.0] $foo -} {1.3 14} -test text-20.96 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -backwards -count foo bar\nfoobar\nfoobanearly 1.0 -} {} -test text-20.97 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -regexp -count foo foobar\nfoo end] $foo -} {2.0 10} -test text-20.97.1 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -regexp -count foo foobar\nfo end] $foo -} {2.0 9} -test text-20.98 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -regexp -count foo bar\nfoo 1.0] $foo -} {2.3 7} -test text-20.99 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -regexp -count foo \nfoo 1.0] $foo -} {2.6 4} -test text-20.100 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - list [.t2 search -backwards -regexp -count foo bar\nfoobar\nfoo 1.0] $foo -} {1.3 14} -test text-20.101 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -backwards -regexp -count foo bar\nfoobar\nfoobanearly 1.0 -} {} -test text-20.102 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfaoobar\nfoobar" - .t2 search -backwards -regexp -count foo bar\nfoo 1.0 -} {2.4} -test text-20.103 {TextSearchCmd, multiline matching end of window} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfaoobar\nfoobar" - .t2 search -backwards -regexp -count foo bar\nfoobar\n\n 1.0 -} {} -test text-20.104 {TextSearchCmd, multiline matching end of window} { - deleteWindows - pack [text .t2] - .t2 search -backwards "\n\n" 1.0 -} {} -test text-20.105 {TextSearchCmd, multiline regexp matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 { Tcl_Obj *objPtr)); + [.t search -strict -count foo foar 1.3] \ + [.t search -strict -count foo foar 2.3] $foo +} -cleanup { + destroy .t +} -result {{} 1.0 6} +test text-22.83 {TextSearchCmd, hidden text and start index} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -regexp bar 1.3 +} -cleanup { + destroy .t +} -result {1.3} +test text-22.84 {TextSearchCmd, hidden text shouldn't influence start index} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.0 1.2 + .t search -regexp bar 1.3 +} -cleanup { + destroy .t +} -result {1.3} +test text-22.85 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + list [.t search -regexp -count foo foar 1.3] $foo +} -cleanup { + destroy .t +} -result {1.0 6} +test text-22.86 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + list [.t search -count foo foar 1.3] $foo +} -cleanup { + destroy .t +} -result {1.0 6} +test text-22.87 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + .t search -strict -count foo foar 1.3 +} -cleanup { + destroy .t +} -result {} +test text-22.88 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + .t tag add hidden 2.2 2.4 + list [.t search -regexp -all -count foo foar 1.3] $foo +} -cleanup { + destroy .t +} -result {{2.0 3.0 1.0} {6 4 6}} +test text-22.89 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + .t tag add hidden 2.2 2.4 + list [.t search -all -count foo foar 1.3] $foo +} -cleanup { + destroy .t +} -result {{2.0 3.0 1.0} {6 4 6}} +test text-22.90 {TextSearchCmd, hidden text inside match must count in length} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoar" + .t tag configure hidden -elide true + .t tag add hidden 1.2 1.4 + .t tag add hidden 2.2 2.4 + list [.t search -strict -all -count foo foar 1.3] $foo +} -cleanup { + destroy .t +} -result {{2.0 3.0} {6 4}} +test text-22.91 {TextSearchCmd, single line with -all} -body { + pack [text .t] + .t insert end " X\n X\n X\n X\n X\n X\n" + .t search -all -regexp { +| *\n} 1.0 end +} -cleanup { + destroy .t +} -result {1.0 1.2 2.0 2.2 3.0 3.2 4.0 4.2 5.0 5.2 6.0 6.2 7.0} +test text-22.92 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -count foo foobar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.0 10} +test text-22.93 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -count foo bar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.3 7} +test text-22.94 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -count foo \nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.6 4} +test text-22.95 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -count foo bar\nfoobar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.3 14} +test text-22.96 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -count foo bar\nfoobar\nfoobanearly 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.97 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -regexp -count foo foobar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.0 10} +test text-22.98 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -regexp -count foo bar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.3 7} +test text-22.99 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -regexp -count foo \nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.6 4} +test text-22.100 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -regexp -count foo bar\nfoobar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.3 14} +test text-22.101 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -regexp -count foo bar\nfoobar\nfoobanearly 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.102 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfaoobar\nfoobar" + .t search -regexp -count foo bar\nfoo 1.0 +} -cleanup { + destroy .t +} -result {2.4} +test text-22.103 {TextSearchCmd, multiline matching end of window} -body { + pack [text .t] + .t insert end "foobar\nfaoobar\nfoobar" + .t search -regexp -count foo bar\nfoobar\n\n 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.104 {TextSearchCmd, multiline matching end of window} -body { + pack [text .t] + .t search "\n\n" 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.105 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -count foo foobar\nfoo end] $foo +} -cleanup { + destroy .t +} -result {2.0 10} +test text-22.106 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -count foo bar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {2.3 7} +test text-22.107 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -count foo \nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {2.6 4} +test text-22.108 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -count foo bar\nfoobar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.3 14} +test text-22.109 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -backwards -count foo bar\nfoobar\nfoobanearly 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.110 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -regexp -count foo foobar\nfoo end] $foo +} -cleanup { + destroy .t +} -result {2.0 10} +test text-22.111 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -regexp -count foo foobar\nfo end] $foo +} -cleanup { + destroy .t +} -result {2.0 9} +test text-22.112 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -regexp -count foo bar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {2.3 7} +test text-22.113 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -regexp -count foo \nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {2.6 4} +test text-22.114 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + list [.t search -backwards -regexp -count foo bar\nfoobar\nfoo 1.0] $foo +} -cleanup { + destroy .t +} -result {1.3 14} +test text-22.115 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -backwards -regexp -count foo bar\nfoobar\nfoobanearly 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.116 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfaoobar\nfoobar" + .t search -backwards -regexp -count foo bar\nfoo 1.0 +} -cleanup { + destroy .t +} -result {2.4} +test text-22.117 {TextSearchCmd, multiline matching end of window} -body { + pack [text .t] + .t insert end "foobar\nfaoobar\nfoobar" + .t search -backwards -regexp -count foo bar\nfoobar\n\n 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.118 {TextSearchCmd, multiline matching end of window} -body { + pack [text .t] + .t search -backwards "\n\n" 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.119 {TextSearchCmd, multiline regexp matching} -body { + pack [text .t] + .t insert 1.0 { Tcl_Obj *objPtr)); static Tcl_Obj* FSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" append markExpr "\[ \n\t\r\]*\\()" - .t2 search -forwards -regexp $markExpr 1.41 end -} {} -test text-20.106 {TextSearchCmd, multiline regexp matching} { - # Practical example which used to crash Tk, but only after the - # search is complete. This is memory corruption caused by - # a bug in Tcl's handling of string objects. - # (Tcl bug 635200) - deleteWindows - pack [text .t2] - .t2 insert 1.0 {static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, + .t search -forwards -regexp $markExpr 1.41 end +} -cleanup { + destroy .t +} -result {} +test text-22.120 {TextSearchCmd, multiline regexp matching} -body { +# Practical example which used to crash Tk, but only after the +# search is complete. This is memory corruption caused by +# a bug in Tcl's handling of string objects. +# (Tcl bug 635200) + pack [text .t] + .t insert 1.0 {static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static Tcl_Obj* FSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr));} set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" append markExpr "\[ \n\t\r\]*\\()" - .t2 search -forwards -regexp $markExpr 1.41 end -} {} -test text-20.107 {TextSearchCmd, multiline regexp matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 { + .t search -forwards -regexp $markExpr 1.41 end +} -cleanup { + destroy .t +} -result {} +test text-22.121 {TextSearchCmd, multiline regexp matching} -body { + pack [text .t] + .t insert 1.0 { static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static Tcl_Obj* FSNormalizeAbsolutePath @@ -1999,240 +4651,275 @@ static Tcl_Obj* FSNormalizeAbsolutePath set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" append markExpr "\[ \n\t\r\]*\\()" - .t2 search -backwards -all -regexp $markExpr end -} {2.0} -test text-20.108 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -all -regexp -count foo bar\nfoo 1.0 -} {1.3 2.3} -test text-20.109 {TextSearchCmd, multiline matching} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -all -backwards -regexp -count foo bar\nfoo 1.0 -} {2.3 1.3} -test text-20.110 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -- "blah" 3.3 1.3 -} {} -test text-20.111 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "foobar\nfoobar\nfoobar" - .t2 search -backwards -- "blah" 1.3 3.3 -} {} -test text-20.112 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "if (stringPtr->uallocated > 0) \{x" - .t2 search -backwards -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0 -} {1.31} -test text-20.113 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "if (stringPtr->uallocated > 0) \{x" - .t2 search -regexp -- "\[\]\")\}\[(\{\]" 1.30 "1.0 lineend" -} {1.31} -test text-20.114 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "if (stringPtr->uallocated > 0) \{x" - .t2 search -backwards -all -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0 -} {1.31 1.29 1.3} -test text-20.115 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "if (stringPtr->uallocated > 0) \{x" - .t2 search -all -regexp -- "\[\]\")\}\[(\{\]" 1.0 "1.0 lineend" -} {1.3 1.29 1.31} -test text-20.116 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "if (stringPtr->uallocated > 0) \{x" - .t2 search -backwards -- "\{" "1.32" 1.0 -} {1.31} -test text-20.117 {TextSearchCmd, wrapping and limits} { - deleteWindows - pack [text .t2] - .t2 insert end "if (stringPtr->uallocated > 0) \{x" - .t2 search -- "\{" 1.30 "1.0 lineend" -} {1.31} -test text-20.118 {TextSearchCmd, multiline regexp matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 { + .t search -backwards -all -regexp $markExpr end +} -cleanup { + destroy .t +} -result {2.0} +test text-22.122 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -all -regexp -count foo bar\nfoo 1.0 +} -cleanup { + destroy .t +} -result {1.3 2.3} +test text-22.123 {TextSearchCmd, multiline matching} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -all -backwards -regexp -count foo bar\nfoo 1.0 +} -cleanup { + destroy .t +} -result {2.3 1.3} +test text-22.124 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -- "blah" 3.3 1.3 +} -cleanup { + destroy .t +} -result {} +test text-22.125 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "foobar\nfoobar\nfoobar" + .t search -backwards -- "blah" 1.3 3.3 +} -cleanup { + destroy .t +} -result {} +test text-22.126 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "if (stringPtr->uallocated > 0) \{x" + .t search -backwards -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0 +} -cleanup { + destroy .t +} -result {1.31} +test text-22.127 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "if (stringPtr->uallocated > 0) \{x" + .t search -regexp -- "\[\]\")\}\[(\{\]" 1.30 "1.0 lineend" +} -cleanup { + destroy .t +} -result {1.31} +test text-22.128 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "if (stringPtr->uallocated > 0) \{x" + .t search -backwards -all -regexp -- "\[\]\")\}\[(\{\]" "1.32" 1.0 +} -cleanup { + destroy .t +} -result {1.31 1.29 1.3} +test text-22.129 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "if (stringPtr->uallocated > 0) \{x" + .t search -all -regexp -- "\[\]\")\}\[(\{\]" 1.0 "1.0 lineend" +} -cleanup { + destroy .t +} -result {1.3 1.29 1.31} +test text-22.130 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "if (stringPtr->uallocated > 0) \{x" + .t search -backwards -- "\{" "1.32" 1.0 +} -cleanup { + destroy .t +} -result {1.31} +test text-22.131 {TextSearchCmd, wrapping and limits} -body { + pack [text .t] + .t insert end "if (stringPtr->uallocated > 0) \{x" + .t search -- "\{" 1.30 "1.0 lineend" +} -cleanup { + destroy .t +} -result {1.31} +test text-22.132 {TextSearchCmd, multiline regexp matching} -body { + pack [text .t] + .t insert 1.0 { void Tcl_SetObjLength(objPtr, length) register Tcl_Obj *objPtr; /* Pointer to object. This object must - * not currently be shared. */ + * not currently be shared. */ register int length; /* Number of bytes desired for string * representation of object, not including - * terminating null byte. */ + * terminating null byte. */ \{ char *new; } set markExpr "^(\[A-Za-z0-9~_\]+\[ \t\n\r\]*\\(|(\[^ \t\(#\n\r/@:\*\]\[^=\(\r\n\]*\[ \t\]+\\*?)?" append markExpr "(\[A-Za-z0-9~_\]+(<\[^>\]*>)?(::)?(\[A-Za-z0-9~_\]+::)*\[-A-Za-z0-9~_+ <>\|\\*/\]+|\[A-Za-z0-9~_\]+)" append markExpr "\[ \n\t\r\]*\\()" - .t2 search -all -regexp -- $markExpr 1.0 -} {4.0} -test text-20.119 {TextSearchCmd, multiline regexp matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" + .t search -all -regexp -- $markExpr 1.0 +} -cleanup { + destroy .t +} -result {4.0} +test text-22.133 {TextSearchCmd, multiline regexp matching} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" set markExpr {^[a-z]+} - # This should not match, and should not wrap - .t2 search -regexp -- $markExpr end end -} {} -test text-20.120 {TextSearchCmd, multiline regexp matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" +# This should not match, and should not wrap + .t search -regexp -- $markExpr end end +} -cleanup { + destroy .t +} -result {} +test text-22.134 {TextSearchCmd, multiline regexp matching} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" set markExpr {^[a-z]+} - # This should not match, and should not wrap - .t2 search -regexp -- $markExpr end+10c end -} {} -test text-20.121 {TextSearchCmd, multiline regexp matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" +# This should not match, and should not wrap + .t search -regexp -- $markExpr end+10c end +} -cleanup { + destroy .t +} -result {} +test text-22.135 {TextSearchCmd, multiline regexp matching} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" set markExpr {^[a-z]+} - # This should not match, and should not wrap - .t2 search -regexp -backwards -- $markExpr 1.0 1.0 -} {} -test text-20.122 {TextSearchCmd, regexp linestop} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" - .t2 search -regexp -- {i.*x} 1.0 -} {2.6} -test text-20.123 {TextSearchCmd, multiline regexp nolinestop matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" - .t2 search -regexp -nolinestop -- {i.*x} 1.0 -} {1.1} -test text-20.124 {TextSearchCmd, regexp linestop} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" - .t2 search -regexp -all -overlap -- {i.*x} 1.0 -} {2.6} -test text-20.124.1 {TextSearchCmd, regexp linestop} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" - .t2 search -regexp -all -- {i.*x} 1.0 -} {2.6} -test text-20.125 {TextSearchCmd, multiline regexp nolinestop matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" - list [.t2 search -regexp -all -overlap -count c -nolinestop -- {i.*x} 1.0] $c -} {{1.1 2.6} {26 10}} -test text-20.125.1 {TextSearchCmd, multiline regexp nolinestop matching} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "first line\nlast line of text" - list [.t2 search -regexp -all -count c -nolinestop -- {i.*x} 1.0] $c -} {1.1 26} -test text-20.126 {TextSearchCmd, stop at end of line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " \t\n last line of text" - .t2 search -regexp -nolinestop -- {[^ \t]} 1.0 -} {1.3} -test text-20.127 {TextSearchCmd, overlapping all matches} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde abcde" - list [.t2 search -regexp -all -overlap -count c -- {\w+} 1.0] $c -} {{1.0 1.6} {5 5}} -test text-20.127.1 {TextSearchCmd, non-overlapping all matches} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde abcde" - list [.t2 search -regexp -all -count c -- {\w+} 1.0] $c -} {{1.0 1.6} {5 5}} -test text-20.128 {TextSearchCmd, stop at end of line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde abcde" - list [.t2 search -backwards -regexp -all -count c -- {\w+} 1.0] $c -} {{1.6 1.0} {5 5}} -test text-20.129 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - list [.t2 search -backwards -regexp -count c -- {Z\w+} 1.21 1.5] $c -} {1.8 8} -test text-20.130 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - list [.t2 search -backwards -all -overlap -regexp -count c -- {Z\w+} 1.21 1.5] $c -} {1.8 8} -test text-20.130.1 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.5] $c -} {1.8 8} -test text-20.131 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - list [.t2 search -backwards -overlap -all -regexp -count c -- {Z\w+} 1.21 1.1] $c -} {1.4 12} -test text-20.131.1 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - list [.t2 search -backwards -overlap -all -regexp -count c -- {Z[^Z]+Z} 1.21 1.1] $c -} {{1.8 1.4} {5 5}} -test text-20.131.2 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.1] $c -} {1.4 12} -test text-20.132 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" - list [.t2 search -backwards -all -overlap -regexp -count c -- {Z\w+} 2.21 1.5] $c -} {{2.4 1.8} {12 8}} -test text-20.132.1 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" - list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.5] $c -} {{2.4 1.8} {12 8}} -test text-20.133 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" - list [.t2 search -backwards -overlap -all -regexp -count c -- {Z\w+} 2.21 1.1] $c -} {{2.4 1.4} {12 12}} -test text-20.133.1 {TextSearchCmd, backwards search stop index } { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "bla ZabcZdefZghi and some text again" - .t2 insert 1.0 "bla ZabcZdefZghi and some text again\n" - list [.t2 search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.1] $c -} {{2.4 1.4} {12 12}} -test text-20.134 {TextSearchCmd, search -all example} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 { +# This should not match, and should not wrap + .t search -regexp -backwards -- $markExpr 1.0 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.136 {TextSearchCmd, regexp linestop} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" + .t search -regexp -- {i.*x} 1.0 +} -cleanup { + destroy .t +} -result {2.6} +test text-22.137 {TextSearchCmd, multiline regexp nolinestop matching} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" + .t search -regexp -nolinestop -- {i.*x} 1.0 +} -cleanup { + destroy .t +} -result {1.1} +test text-22.138 {TextSearchCmd, regexp linestop} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" + .t search -regexp -all -overlap -- {i.*x} 1.0 +} -cleanup { + destroy .t +} -result {2.6} +test text-22.139 {TextSearchCmd, regexp linestop} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" + .t search -regexp -all -- {i.*x} 1.0 +} -cleanup { + destroy .t +} -result {2.6} +test text-22.140 {TextSearchCmd, multiline regexp nolinestop matching} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" + list [.t search -regexp -all -overlap -count c -nolinestop -- {i.*x} 1.0] $c +} -cleanup { + destroy .t +} -result {{1.1 2.6} {26 10}} +test text-22.141 {TextSearchCmd, multiline regexp nolinestop matching} -body { + pack [text .t] + .t insert 1.0 "first line\nlast line of text" + list [.t search -regexp -all -count c -nolinestop -- {i.*x} 1.0] $c +} -cleanup { + destroy .t +} -result {1.1 26} +test text-22.142 {TextSearchCmd, stop at end of line} -body { + pack [text .t] + .t insert 1.0 " \t\n last line of text" + .t search -regexp -nolinestop -- {[^ \t]} 1.0 +} -cleanup { + destroy .t +} -result {1.3} +test text-22.143 {TextSearchCmd, overlapping all matches} -body { + pack [text .t] + .t insert 1.0 "abcde abcde" + list [.t search -regexp -all -overlap -count c -- {\w+} 1.0] $c +} -cleanup { + destroy .t +} -result {{1.0 1.6} {5 5}} +test text-22.144 {TextSearchCmd, non-overlapping all matches} -body { + pack [text .t] + .t insert 1.0 "abcde abcde" + list [.t search -regexp -all -count c -- {\w+} 1.0] $c +} -cleanup { + destroy .t +} -result {{1.0 1.6} {5 5}} +test text-22.145 {TextSearchCmd, stop at end of line} -body { + pack [text .t] + .t insert 1.0 "abcde abcde" + list [.t search -backwards -regexp -all -count c -- {\w+} 1.0] $c +} -cleanup { + destroy .t +} -result {{1.6 1.0} {5 5}} +test text-22.146 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t search -backwards -regexp -count c -- {Z\w+} 1.21 1.5] $c +} -cleanup { + destroy .t +} -result {1.8 8} +test text-22.147 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t search -backwards -all -overlap -regexp -count c -- {Z\w+} 1.21 1.5] $c +} -cleanup { + destroy .t +} -result {1.8 8} +test text-22.148 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.5] $c +} -cleanup { + destroy .t +} -result {1.8 8} +test text-22.149 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t search -backwards -overlap -all -regexp -count c -- {Z\w+} 1.21 1.1] $c +} -cleanup { + destroy .t +} -result {1.4 12} +test text-22.150 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t search -backwards -overlap -all -regexp -count c -- {Z[^Z]+Z} 1.21 1.1] $c +} -cleanup { + destroy .t +} -result {{1.8 1.4} {5 5}} +test text-22.151 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + list [.t search -backwards -all -regexp -count c -- {Z\w+} 1.21 1.1] $c +} -cleanup { + destroy .t +} -result {1.4 12} +test text-22.152 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + .t insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t search -backwards -all -overlap -regexp -count c -- {Z\w+} 2.21 1.5] $c +} -cleanup { + destroy .t +} -result {{2.4 1.8} {12 8}} +test text-22.153 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + .t insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.5] $c +} -cleanup { + destroy .t +} -result {{2.4 1.8} {12 8}} +test text-22.154 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + .t insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t search -backwards -overlap -all -regexp -count c -- {Z\w+} 2.21 1.1] $c +} -cleanup { + destroy .t +} -result {{2.4 1.4} {12 12}} +test text-22.155 {TextSearchCmd, backwards search stop index } -body { + pack [text .t] + .t insert 1.0 "bla ZabcZdefZghi and some text again" + .t insert 1.0 "bla ZabcZdefZghi and some text again\n" + list [.t search -backwards -all -regexp -count c -- {Z\w+} 2.21 1.1] $c +} -cleanup { + destroy .t +} -result {{2.4 1.4} {12 12}} +test text-22.156 {TextSearchCmd, search -all example} -body { + pack [text .t] + .t insert 1.0 { See the package: supersearch for more information. @@ -2246,697 +4933,947 @@ See the package: marks for more information. } set pat {package: ([a-zA-Z0-9][-a-zA-Z0-9._+#/]*)} - list [.t2 search -nolinestop -regexp -nocase -all -forwards \ + list [.t search -nolinestop -regexp -nocase -all -forwards \ -count c -- $pat 1.0 end] $c -} {{3.8 6.8 8.0 11.8} {20 26 13 14}} -test text-20.135 {TextSearchCmd, backwards search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" - .t2 search -backwards -regexp {fooba+rfoo} end -} {1.6} -test text-20.135.1 {TextSearchCmd, backwards search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" - .t2 search -backwards -overlap -all -regexp {fooba+rfoo} end -} {1.6 1.0} -test text-20.135.2 {TextSearchCmd, backwards search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" - .t2 search -backwards -all -regexp {fooba+rfoo} end -} {1.6} -test text-20.135.3 {TextSearchCmd, forwards search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" - .t2 search -all -overlap -regexp {fooba+rfoo} end -} {1.0 1.6} -test text-20.135.4 {TextSearchCmd, forwards search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foobarfoobaaaaaaaaaaarfoo" - .t2 search -all -regexp {fooba+rfoo} end -} {1.0} -test text-20.136 {TextSearchCmd, forward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abababab" - .t2 search -exact -overlap -all {abab} 1.0 -} {1.0 1.2 1.4} -test text-20.136.1 {TextSearchCmd, forward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abababab" - .t2 search -exact -all {abab} 1.0 -} {1.0 1.4} -test text-20.137 {TextSearchCmd, backward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "ababababab" - .t2 search -exact -overlap -backwards -all {abab} end -} {1.6 1.4 1.2 1.0} -test text-20.137.1 {TextSearchCmd, backward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "ababababab" - .t2 search -exact -backwards -all {abab} end -} {1.6 1.2} -test text-20.137.2 {TextSearchCmd, backward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abababababab" - .t2 search -exact -backwards -all {abab} end -} {1.8 1.4 1.0} -test text-20.138 {TextSearchCmd, forward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" - .t2 search -exact -overlap -all "foo\nbar\nfoo" 1.0 -} {1.0 3.0 5.0} -test text-20.138.1 {TextSearchCmd, forward exact search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" - .t2 search -exact -all "foo\nbar\nfoo" 1.0 -} {1.0 5.0} -test text-20.139 {TextSearchCmd, backward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" - .t2 search -exact -overlap -backward -all "foo\nbar\nfoo" end -} {5.0 3.0 1.0} -test text-20.140 {TextSearchCmd, backward exact search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" - .t2 search -exact -backward -all "foo\nbar\nfoo" end -} {5.0 1.0} -test text-20.141 {TextSearchCmd, backward exact search overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" - .t2 search -regexp -backward -overlap -all "foo\nbar\nfoo" end -} {5.0 3.0 1.0} -test text-20.142 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" - .t2 search -regexp -backward -all "foo\nbar\nfoo" end -} {5.0 1.0} -test text-20.142a {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 -} {1.7} -test text-20.143 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.5 -} {1.7} -test text-20.144 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.7 -} {1.7} -test text-20.145 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.8 -} {1.8} -test text-20.146 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.3 -} {1.7 1.3} -test text-20.147 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.13 -} {} -test text-20.148 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 2.0 1.3 -} {1.12 1.7 1.3} -test text-20.149 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 " aasda asdj werwer" - .t2 search -regexp -backward -all -- {(\$)?[\w:_]+} 1.3 -} {1.1 1.12 1.7 1.3} -test text-20.150 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\n" - .t2 search -regexp -backward -all -- {(\w+\n)+} end -} {1.0} -test text-20.151 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\n" - .t2 search -regexp -backward -all -- {(\w+\n)+} end 1.5 -} {2.0} -test text-20.152 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.5 -} {2.0} -test text-20.153 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo -} {1.0 20} -test text-20.154 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" +} -cleanup { + destroy .t +} -result {{3.8 6.8 8.0 11.8} {20 26 13 14}} +test text-22.157 {TextSearchCmd, backwards search overlaps} -body { + pack [text .t] + .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t search -backwards -regexp {fooba+rfoo} end +} -cleanup { + destroy .t +} -result {1.6} +test text-22.158 {TextSearchCmd, backwards search overlaps} -body { + pack [text .t] + .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t search -backwards -overlap -all -regexp {fooba+rfoo} end +} -cleanup { + destroy .t +} -result {1.6 1.0} +test text-22.159 {TextSearchCmd, backwards search overlaps} -body { + pack [text .t] + .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t search -backwards -all -regexp {fooba+rfoo} end +} -cleanup { + destroy .t +} -result {1.6} +test text-22.160 {TextSearchCmd, forwards search overlaps} -body { + pack [text .t] + .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t search -all -overlap -regexp {fooba+rfoo} end +} -cleanup { + destroy .t +} -result {1.0 1.6} +test text-22.161 {TextSearchCmd, forwards search overlaps} -body { + pack [text .t] + .t insert 1.0 "foobarfoobaaaaaaaaaaarfoo" + .t search -all -regexp {fooba+rfoo} end +} -cleanup { + destroy .t +} -result {1.0} +test text-22.162 {TextSearchCmd, forward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "abababab" + .t search -exact -overlap -all {abab} 1.0 +} -cleanup { + destroy .t +} -result {1.0 1.2 1.4} +test text-22.163 {TextSearchCmd, forward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "abababab" + .t search -exact -all {abab} 1.0 +} -cleanup { + destroy .t +} -result {1.0 1.4} +test text-22.164 {TextSearchCmd, backward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "ababababab" + .t search -exact -overlap -backwards -all {abab} end +} -cleanup { + destroy .t +} -result {1.6 1.4 1.2 1.0} +test text-22.165 {TextSearchCmd, backward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "ababababab" + .t search -exact -backwards -all {abab} end +} -cleanup { + destroy .t +} -result {1.6 1.2} +test text-22.166 {TextSearchCmd, backward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "abababababab" + .t search -exact -backwards -all {abab} end +} -cleanup { + destroy .t +} -result {1.8 1.4 1.0} +test text-22.167 {TextSearchCmd, forward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t search -exact -overlap -all "foo\nbar\nfoo" 1.0 +} -cleanup { + destroy .t +} -result {1.0 3.0 5.0} +test text-22.168 {TextSearchCmd, forward exact search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t search -exact -all "foo\nbar\nfoo" 1.0 +} -cleanup { + destroy .t +} -result {1.0 5.0} +test text-22.169 {TextSearchCmd, backward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t search -exact -overlap -backward -all "foo\nbar\nfoo" end +} -cleanup { + destroy .t +} -result {5.0 3.0 1.0} +test text-22.170 {TextSearchCmd, backward exact search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t search -exact -backward -all "foo\nbar\nfoo" end +} -cleanup { + destroy .t +} -result {5.0 1.0} +test text-22.171 {TextSearchCmd, backward exact search overlaps} -body { + pack [text .t] + .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t search -regexp -backward -overlap -all "foo\nbar\nfoo" end +} -cleanup { + destroy .t +} -result {5.0 3.0 1.0} +test text-22.172 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "foo\nbar\nfoo\nbar\nfoo\nbar\nfoo\n" + .t search -regexp -backward -all "foo\nbar\nfoo" end +} -cleanup { + destroy .t +} -result {5.0 1.0} +test text-22.173 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 +} -cleanup { + destroy .t +} -result {1.7} +test text-22.174 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.5 +} -cleanup { + destroy .t +} -result {1.7} +test text-22.175 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.7 +} -cleanup { + destroy .t +} -result {1.7} +test text-22.176 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -- {(\$)?[\w:_]+} 1.9 1.8 +} -cleanup { + destroy .t +} -result {1.8} +test text-22.177 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.3 +} -cleanup { + destroy .t +} -result {1.7 1.3} +test text-22.178 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.9 1.13 +} -cleanup { + destroy .t +} -result {} +test text-22.179 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -all -- {(\$)?[\w:_]+} 2.0 1.3 +} -cleanup { + destroy .t +} -result {1.12 1.7 1.3} +test text-22.180 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 " aasda asdj werwer" + .t search -regexp -backward -all -- {(\$)?[\w:_]+} 1.3 +} -cleanup { + destroy .t +} -result {1.1 1.12 1.7 1.3} +test text-22.181 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\n" + .t search -regexp -backward -all -- {(\w+\n)+} end +} -cleanup { + destroy .t +} -result {1.0} +test text-22.182 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\n" + .t search -regexp -backward -all -- {(\w+\n)+} end 1.5 +} -cleanup { + destroy .t +} -result {2.0} +test text-22.183 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.5 +} -cleanup { + destroy .t +} -result {2.0} +test text-22.184 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo +} -cleanup { + destroy .t +} -result {1.0 20} +test text-22.185 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" set res {} lappend res \ - [list [.t2 search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo] \ - [list [.t2 search -regexp -all -count foo -- {(\w+)+} 1.0] $foo] -} {{1.0 20} {{1.0 2.0 3.0 4.0} {5 5 5 1}}} -test text-20.155 {TextSearchCmd, regexp search greedy} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -all -nolinestop -count foo -- {.*} 1.0] $foo -} {1.0 20} -test text-20.156 {TextSearchCmd, regexp search greedy} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -all -count foo -- {.*} 1.0] $foo -} {{1.0 2.0 3.0 4.0} {5 5 5 1}} -test text-20.157 {TextSearchCmd, regexp search greedy multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -count foo -- {(\w+\n\w)+} 1.0] $foo -} {1.0 19} -test text-20.158 {TextSearchCmd, regexp search greedy multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -backwards -count foo -- {(\w+\n\w)+} end] $foo -} {1.0 19} -test text-20.159 {TextSearchCmd, regexp search greedy multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -all -backwards -count foo -- {(\w+\n\w)+} end] $foo -} {1.0 19} -test text-20.160 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.5 -} {2.0} -test text-20.161 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - .t2 search -regexp -backward -all -- {(\w+\n\w)+} end 1.3 -} {1.3} -test text-20.162 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -forward -count foo -- {(\w+\n\w)+} 1.3] $foo -} {1.3 16} -test text-20.163 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.3] $foo - # This result is somewhat debatable -- the two results do overlap, - # but only because the search has totally wrapped around back to - # the start. -} {{1.3 1.0} {16 19}} -test text-20.164 {TextSearchCmd, backward regexp search no-overlaps} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "abcde\nabcde\nabcde\na" - list [.t2 search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.0 1.3] $foo -} {1.0 19} -test text-20.165 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n" - list [.t2 search -regexp -forward -all -count foo -- {(a+\n(b+\n))+} 1.0] $foo -} {1.0 20} -test text-20.166 {TextSearchCmd, regexp search complex cases} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n" - list [.t2 search -regexp -forward -all -count foo \ + [list [.t search -regexp -all -count foo -- {(\w+\n)+} 1.0] $foo] \ + [list [.t search -regexp -all -count foo -- {(\w+)+} 1.0] $foo] +} -cleanup { + destroy .t +} -result {{1.0 20} {{1.0 2.0 3.0 4.0} {5 5 5 1}}} +test text-22.186 {TextSearchCmd, regexp search greedy} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -all -nolinestop -count foo -- {.*} 1.0] $foo +} -cleanup { + destroy .t +} -result {1.0 20} +test text-22.187 {TextSearchCmd, regexp search greedy} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -all -count foo -- {.*} 1.0] $foo +} -cleanup { + destroy .t +} -result {{1.0 2.0 3.0 4.0} {5 5 5 1}} +test text-22.188 {TextSearchCmd, regexp search greedy multi-line} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -count foo -- {(\w+\n\w)+} 1.0] $foo +} -cleanup { + destroy .t +} -result {1.0 19} +test text-22.189 {TextSearchCmd, regexp search greedy multi-line} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -backwards -count foo -- {(\w+\n\w)+} end] $foo +} -cleanup { + destroy .t +} -result {1.0 19} +test text-22.190 {TextSearchCmd, regexp search greedy multi-line} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -all -backwards -count foo -- {(\w+\n\w)+} end] $foo +} -cleanup { + destroy .t +} -result {1.0 19} +test text-22.191 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.5 +} -cleanup { + destroy .t +} -result {2.0} +test text-22.192 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + .t search -regexp -backward -all -- {(\w+\n\w)+} end 1.3 +} -cleanup { + destroy .t +} -result {1.3} +test text-22.193 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -forward -count foo -- {(\w+\n\w)+} 1.3] $foo +} -cleanup { + destroy .t +} -result {1.3 16} +test text-22.194 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.3] $foo +# This result is somewhat debatable -- the two results do overlap, +# but only because the search has totally wrapped around back to +# the start. +} -cleanup { + destroy .t +} -result {{1.3 1.0} {16 19}} +test text-22.195 {TextSearchCmd, backward regexp search no-overlaps} -body { + pack [text .t] + .t insert 1.0 "abcde\nabcde\nabcde\na" + list [.t search -regexp -forward -all -count foo -- {(\w+\n\w)+} 1.0 1.3] $foo +} -cleanup { + destroy .t +} -result {1.0 19} +test text-22.196 {TextSearchCmd, regexp search multi-line} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n" + list [.t search -regexp -forward -all -count foo -- {(a+\n(b+\n))+} 1.0] $foo +} -cleanup { + destroy .t +} -result {1.0 20} +test text-22.197 {TextSearchCmd, regexp search complex cases} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\naaaa\nbbbb\n" + list [.t search -regexp -forward -all -count foo \ -- {(a+\n(b+\n))+} 1.0] $foo -} {1.0 20} -test text-20.167 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" +} -cleanup { + destroy .t +} -result {1.0 20} +test text-22.198 {TextSearchCmd, regexp search multi-line} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" set foo {} - list [.t2 search -regexp -forward -all -count foo \ + list [.t search -regexp -forward -all -count foo \ -- {(b+\nc+\nb+)\na+} 1.0] $foo -} {2.0 19} -test text-20.168 {TextSearchCmd, regexp search multi-line} {knownBug} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" +} -cleanup { + destroy .t +} -result {2.0 19} +test text-22.199 {TextSearchCmd, regexp search multi-line} -constraints { + knownBug +} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" set foo {} - list [.t2 search -regexp -forward -all -count foo \ + list [.t search -regexp -forward -all -count foo \ -- {(a+|b+\nc+\nb+)\na+} 1.0] $foo -} {2.0 19} -test text-20.169 {TextSearchCmd, regexp search multi-line} {knownBug} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" +} -cleanup { + destroy .t +} -result {2.0 19} +test text-22.200 {TextSearchCmd, regexp search multi-line} -constraints { + knownBug +} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" set foo {} - list [.t2 search -regexp -forward -all -count foo \ + list [.t search -regexp -forward -all -count foo \ -- {(a+|b+\nc+\nb+)+\na+} 1.0] $foo -} {2.0 19} -test text-20.170 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" +} -cleanup { + destroy .t +} -result {2.0 19} +test text-22.201 {TextSearchCmd, regexp search multi-line} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\ncccc\nbbbb\naaaa\n" set foo {} - list [.t2 search -regexp -forward -all -count foo \ + list [.t search -regexp -forward -all -count foo \ -- {((a+|b+\nc+\nb+)+\n)+a+} 1.0] $foo -} {1.0 24} -test text-20.171 {TextSearchCmd, regexp search multi-line} {knownBug} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n" - list [.t2 search -regexp -backward -all -count foo \ +} -cleanup { + destroy .t +} -result {1.0 24} +test text-22.202 {TextSearchCmd, regexp search multi-line} -constraints { + knownBug +} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n" + list [.t search -regexp -backward -all -count foo \ -- {b+\n|a+\n(b+\n)+} end] $foo -} {1.0 25} -test text-20.172 {TextSearchCmd, regexp search multi-line} {knownBug} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n" - .t2 search -regexp -backward -- {b+\n|a+\n(b+\n)+} end - # Should match at 1.0 for a true greedy match -} {1.0} -test text-20.172.1 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "line0\nline1\nline1\nline1\nline1\nline2\nline2\nline2\nline3\n" - .t2 search -nolinestop -regexp -nocase -forwards -- {^(.*)\n(\1\n)+} 1.0 end - # Matches at 6.0 currently -} {2.0} -test text-20.173 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "\naaaxxx\nyyy\n" +} -cleanup { + destroy .t +} -result {1.0 25} +test text-22.203 {TextSearchCmd, regexp search multi-line} -constraints { + knownBug +} -body { + pack [text .t] + .t insert 1.0 "aaaa\nbbbb\nbbbb\nbbbb\nbbbb\n" + .t search -regexp -backward -- {b+\n|a+\n(b+\n)+} end +# Should match at 1.0 for a true greedy match +} -cleanup { + destroy .t +} -result {1.0} +test text-22.204 {TextSearchCmd, regexp search multi-line} -body { + pack [text .t] + .t insert 1.0 "line0\nline1\nline1\nline1\nline1\nline2\nline2\nline2\nline3\n" + .t search -nolinestop -regexp -nocase -forwards -- {^(.*)\n(\1\n)+} 1.0 end +# Matches at 6.0 currently +} -cleanup { + destroy .t +} -result {2.0} +test text-22.205 {TextSearchCmd, regexp search multi-line} -setup { + pack [text .t] set res {} - lappend res [.t2 search -count c -regexp -- {x*\ny*} 2.0] $c - lappend res [.t2 search -count c -regexp -- {x*\ny*} 2.1] $c - set res -} {2.3 7 2.3 7} -test text-20.174 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "\naaa\n\n\n\n\nxxx\n" +} -body { + .t insert 1.0 "\naaaxxx\nyyy\n" + lappend res [.t search -count c -regexp -- {x*\ny*} 2.0] $c + lappend res [.t search -count c -regexp -- {x*\ny*} 2.1] $c + return $res +} -cleanup { + destroy .t +} -result {2.3 7 2.3 7} +test text-22.206 {TextSearchCmd, regexp search multi-line} -setup { + pack [text .t] set res {} - lappend res [.t2 search -count c -regexp -- {\n+} 2.0] $c - lappend res [.t2 search -count c -regexp -- {\n+} 2.1] $c - set res -} {2.3 5 2.3 5} -test text-20.175 {TextSearchCmd, regexp search multi-line} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "\naaa\n\n\t \n\t\t\t \n\nxxx\n" +} -body { + .t insert 1.0 "\naaa\n\n\n\n\nxxx\n" + lappend res [.t search -count c -regexp -- {\n+} 2.0] $c + lappend res [.t search -count c -regexp -- {\n+} 2.1] $c + return $res +} -cleanup { + destroy .t +} -result {2.3 5 2.3 5} +test text-22.207 {TextSearchCmd, regexp search multi-line} -setup { + pack [text .t] set res {} - lappend res [.t2 search -count c -regexp -- {(\n+(\t+ *)*)+} 2.0] $c - set res -} {2.3 13} -test text-20.176 {TextSearchCmd, empty search range} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\na\na\n" - .t2 search -- a 2.0 1.0 -} {} -test text-20.177 {TextSearchCmd, empty search range} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\na\na\n" - .t2 search -backwards -- a 1.0 2.0 -} {} -test text-20.178 {TextSearchCmd, empty search range} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\na\na\n" - .t2 search -- a 1.0 1.0 -} {} -test text-20.179 {TextSearchCmd, empty search range} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\na\na\n" - .t2 search -backwards -- a 2.0 2.0 -} {} -test text-20.180 {TextSearchCmd, elide up to match} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\nb\nc" - .t2 tag configure e -elide 1 +} -body { + .t insert 1.0 "\naaa\n\n\t \n\t\t\t \n\nxxx\n" + lappend res [.t search -count c -regexp -- {(\n+(\t+ *)*)+} 2.0] $c + return $res +} -cleanup { + destroy .t +} -result {2.3 13} +test text-22.208 {TextSearchCmd, empty search range} -body { + pack [text .t] + .t insert 1.0 "a\na\na\n" + .t search -- a 2.0 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.209 {TextSearchCmd, empty search range} -body { + pack [text .t] + .t insert 1.0 "a\na\na\n" + .t search -backwards -- a 1.0 2.0 +} -cleanup { + destroy .t +} -result {} +test text-22.210 {TextSearchCmd, empty search range} -body { + pack [text .t] + .t insert 1.0 "a\na\na\n" + .t search -- a 1.0 1.0 +} -cleanup { + destroy .t +} -result {} +test text-22.211 {TextSearchCmd, empty search range} -body { + pack [text .t] + .t insert 1.0 "a\na\na\n" + .t search -backwards -- a 2.0 2.0 +} -cleanup { + destroy .t +} -result {} +test text-22.212 {TextSearchCmd, elide up to match} -setup { + pack [text .t] set res {} - lappend res [.t2 search -regexp a 1.0] - lappend res [.t2 search -regexp b 1.0] - lappend res [.t2 search -regexp c 1.0] - .t2 tag add e 1.0 2.0 - lappend res [.t2 search -regexp a 1.0] - lappend res [.t2 search -regexp b 1.0] - lappend res [.t2 search -regexp c 1.0] - lappend res [.t2 search -elide -regexp a 1.0] - lappend res [.t2 search -elide -regexp b 1.0] - lappend res [.t2 search -elide -regexp c 1.0] -} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} -test text-20.181 {TextSearchCmd, elide up to match, backwards} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\nb\nc" - .t2 tag configure e -elide 1 +} -body { + .t insert 1.0 "a\nb\nc" + .t tag configure e -elide 1 + lappend res [.t search -regexp a 1.0] + lappend res [.t search -regexp b 1.0] + lappend res [.t search -regexp c 1.0] + .t tag add e 1.0 2.0 + lappend res [.t search -regexp a 1.0] + lappend res [.t search -regexp b 1.0] + lappend res [.t search -regexp c 1.0] + lappend res [.t search -elide -regexp a 1.0] + lappend res [.t search -elide -regexp b 1.0] + lappend res [.t search -elide -regexp c 1.0] +} -cleanup { + destroy .t +} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-22.213 {TextSearchCmd, elide up to match, backwards} -setup { + pack [text .t] set res {} - lappend res [.t2 search -backward -regexp a 1.0] - lappend res [.t2 search -backward -regexp b 1.0] - lappend res [.t2 search -backward -regexp c 1.0] - .t2 tag add e 1.0 2.0 - lappend res [.t2 search -backward -regexp a 1.0] - lappend res [.t2 search -backward -regexp b 1.0] - lappend res [.t2 search -backward -regexp c 1.0] - lappend res [.t2 search -backward -elide -regexp a 1.0] - lappend res [.t2 search -backward -elide -regexp b 1.0] - lappend res [.t2 search -backward -elide -regexp c 1.0] -} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} -test text-20.182 {TextSearchCmd, elide up to match} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\nb\nc" - .t2 tag configure e -elide 1 +} -body { + .t insert 1.0 "a\nb\nc" + .t tag configure e -elide 1 + lappend res [.t search -backward -regexp a 1.0] + lappend res [.t search -backward -regexp b 1.0] + lappend res [.t search -backward -regexp c 1.0] + .t tag add e 1.0 2.0 + lappend res [.t search -backward -regexp a 1.0] + lappend res [.t search -backward -regexp b 1.0] + lappend res [.t search -backward -regexp c 1.0] + lappend res [.t search -backward -elide -regexp a 1.0] + lappend res [.t search -backward -elide -regexp b 1.0] + lappend res [.t search -backward -elide -regexp c 1.0] +} -cleanup { + destroy .t +} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-22.214 {TextSearchCmd, elide up to match} -setup { + pack [text .t] set res {} - lappend res [.t2 search a 1.0] - lappend res [.t2 search b 1.0] - lappend res [.t2 search c 1.0] - .t2 tag add e 1.0 2.0 - lappend res [.t2 search a 1.0] - lappend res [.t2 search b 1.0] - lappend res [.t2 search c 1.0] - lappend res [.t2 search -elide a 1.0] - lappend res [.t2 search -elide b 1.0] - lappend res [.t2 search -elide c 1.0] -} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} -test text-20.183 {TextSearchCmd, elide up to match, backwards} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "a\nb\nc" - .t2 tag configure e -elide 1 +} -body { + .t insert 1.0 "a\nb\nc" + .t tag configure e -elide 1 + lappend res [.t search a 1.0] + lappend res [.t search b 1.0] + lappend res [.t search c 1.0] + .t tag add e 1.0 2.0 + lappend res [.t search a 1.0] + lappend res [.t search b 1.0] + lappend res [.t search c 1.0] + lappend res [.t search -elide a 1.0] + lappend res [.t search -elide b 1.0] + lappend res [.t search -elide c 1.0] +} -cleanup { + destroy .t +} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-22.215 {TextSearchCmd, elide up to match, backwards} -setup { + pack [text .t] set res {} - lappend res [.t2 search -backward a 1.0] - lappend res [.t2 search -backward b 1.0] - lappend res [.t2 search -backward c 1.0] - .t2 tag add e 1.0 2.0 - lappend res [.t2 search -backward a 1.0] - lappend res [.t2 search -backward b 1.0] - lappend res [.t2 search -backward c 1.0] - lappend res [.t2 search -backward -elide a 1.0] - lappend res [.t2 search -backward -elide b 1.0] - lappend res [.t2 search -backward -elide c 1.0] -} {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} -test text-20.184 {TextSearchCmd, elide up to match} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aa\nbb\ncc" - .t2 tag configure e -elide 1 +} -body { + .t insert 1.0 "a\nb\nc" + .t tag configure e -elide 1 + lappend res [.t search -backward a 1.0] + lappend res [.t search -backward b 1.0] + lappend res [.t search -backward c 1.0] + .t tag add e 1.0 2.0 + lappend res [.t search -backward a 1.0] + lappend res [.t search -backward b 1.0] + lappend res [.t search -backward c 1.0] + lappend res [.t search -backward -elide a 1.0] + lappend res [.t search -backward -elide b 1.0] + lappend res [.t search -backward -elide c 1.0] +} -cleanup { + destroy .t +} -result {1.0 2.0 3.0 {} 2.0 3.0 1.0 2.0 3.0} +test text-22.216 {TextSearchCmd, elide up to match} -setup { + pack [text .t] set res {} - lappend res [.t2 search ab 1.0] - lappend res [.t2 search bc 1.0] - .t2 tag add e 1.1 2.1 - lappend res [.t2 search ab 1.0] - lappend res [.t2 search b 1.0] - .t2 tag remove e 1.0 end - .t2 tag add e 2.1 3.1 - lappend res [.t2 search bc 1.0] - lappend res [.t2 search c 1.0] - .t2 tag remove e 1.0 end - .t2 tag add e 2.1 3.0 - lappend res [.t2 search bc 1.0] - lappend res [.t2 search c 1.0] -} {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} -test text-20.185 {TextSearchCmd, elide up to match} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "aa\nbb\ncc" - .t2 tag configure e -elide 1 +} -body { + .t insert 1.0 "aa\nbb\ncc" + .t tag configure e -elide 1 + lappend res [.t search ab 1.0] + lappend res [.t search bc 1.0] + .t tag add e 1.1 2.1 + lappend res [.t search ab 1.0] + lappend res [.t search b 1.0] + .t tag remove e 1.0 end + .t tag add e 2.1 3.1 + lappend res [.t search bc 1.0] + lappend res [.t search c 1.0] + .t tag remove e 1.0 end + .t tag add e 2.1 3.0 + lappend res [.t search bc 1.0] + lappend res [.t search c 1.0] +} -cleanup { + destroy .t +} -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} +test text-22.217 {TextSearchCmd, elide up to match} -setup { + pack [text .t] set res {} - lappend res [.t2 search -regexp ab 1.0] - lappend res [.t2 search -regexp bc 1.0] - .t2 tag add e 1.1 2.1 - lappend res [.t2 search -regexp ab 1.0] - lappend res [.t2 search -regexp b 1.0] - .t2 tag remove e 1.0 end - .t2 tag add e 2.1 3.1 - lappend res [.t2 search -regexp bc 1.0] - lappend res [.t2 search -regexp c 1.0] - .t2 tag remove e 1.0 end - .t2 tag add e 2.1 3.0 - lappend res [.t2 search -regexp bc 1.0] - lappend res [.t2 search -regexp c 1.0] -} {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} -test text-20.186 {TextSearchCmd, strict limits} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -strictlimits -- "world" 1.3 1.8 -} {} -test text-20.187 {TextSearchCmd, strict limits} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -strictlimits -- "world" 1.3 1.10 -} {} -test text-20.188 {TextSearchCmd, strict limits} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -strictlimits -- "world" 1.3 1.11 -} {1.6} -test text-20.189 {TextSearchCmd, strict limits backwards} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -strictlimits -backward -- "world" 2.3 1.8 -} {} -test text-20.190 {TextSearchCmd, strict limits backwards} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -strictlimits -backward -- "world" 2.3 1.6 -} {1.6} -test text-20.191 {TextSearchCmd, strict limits backwards} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -strictlimits -backward -- "world" 2.3 1.7 -} {} -test text-20.192 {TextSearchCmd, strict limits} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -regexp -strictlimits -- "world" 1.3 1.8 -} {} -test text-20.193 {TextSearchCmd, strict limits} { - deleteWindows - pack [text .t2] - .t2 insert 1.0 "Hello world!\nThis is a test\n" - .t2 search -regexp -strictlimits -backward -- "world" 2.3 1.8 -} {} - -deleteWindows -text .t2 -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 -pack .t2 -.t2 insert end "1\t2\t3\t4\t55.5" - -test text-21.1 {TkTextGetTabs procedure} { - list [catch {.t2 configure -tabs "\{{}"} msg] $msg -} {1 {unmatched open brace in list}} -test text-21.2 {TkTextGetTabs procedure} { - list [catch {.t2 configure -tabs xyz} msg] $msg -} {1 {bad screen distance "xyz"}} -test text-21.3 {TkTextGetTabs procedure} { - .t2 configure -tabs {100 200} +} -body { + .t insert 1.0 "aa\nbb\ncc" + .t tag configure e -elide 1 + lappend res [.t search -regexp ab 1.0] + lappend res [.t search -regexp bc 1.0] + .t tag add e 1.1 2.1 + lappend res [.t search -regexp ab 1.0] + lappend res [.t search -regexp b 1.0] + .t tag remove e 1.0 end + .t tag add e 2.1 3.1 + lappend res [.t search -regexp bc 1.0] + lappend res [.t search -regexp c 1.0] + .t tag remove e 1.0 end + .t tag add e 2.1 3.0 + lappend res [.t search -regexp bc 1.0] + lappend res [.t search -regexp c 1.0] +} -cleanup { + destroy .t +} -result {{} {} 1.0 2.1 2.0 3.1 2.0 3.0} +test text-22.218 {TextSearchCmd, strict limits} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -strictlimits -- "world" 1.3 1.8 +} -cleanup { + destroy .t +} -result {} +test text-22.219 {TextSearchCmd, strict limits} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -strictlimits -- "world" 1.3 1.10 +} -cleanup { + destroy .t +} -result {} +test text-22.220 {TextSearchCmd, strict limits} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -strictlimits -- "world" 1.3 1.11 +} -cleanup { + destroy .t +} -result {1.6} +test text-22.221 {TextSearchCmd, strict limits backwards} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -strictlimits -backward -- "world" 2.3 1.8 +} -cleanup { + destroy .t +} -result {} +test text-22.222 {TextSearchCmd, strict limits backwards} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -strictlimits -backward -- "world" 2.3 1.6 +} -cleanup { + destroy .t +} -result {1.6} +test text-22.223 {TextSearchCmd, strict limits backwards} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -strictlimits -backward -- "world" 2.3 1.7 +} -cleanup { + destroy .t +} -result {} +test text-22.224 {TextSearchCmd, strict limits} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -regexp -strictlimits -- "world" 1.3 1.8 +} -cleanup { + destroy .t +} -result {} +test text-22.225 {TextSearchCmd, strict limits} -body { + pack [text .t] + .t insert 1.0 "Hello world!\nThis is a test\n" + .t search -regexp -strictlimits -backward -- "world" 2.3 1.8 +} -cleanup { + destroy .t +} -result {} + + +test text-23.1 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs "\{{}" +} -cleanup { + destroy .t +} -returnCodes {error} -result {unmatched open brace in list} +test text-23.2 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs xyz +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad screen distance "xyz"} +test text-23.3 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs {100 200} update idletasks - list [lindex [.t2 bbox 1.2] 0] [lindex [.t2 bbox 1.4] 0] -} {100 200} -test text-21.4 {TkTextGetTabs procedure} { - .t2 configure -tabs {100 right 200 left 300 center 400 numeric} + list [lindex [.t bbox 1.2] 0] [lindex [.t bbox 1.4] 0] +} -cleanup { + destroy .t +} -result {100 200} +test text-23.4 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs {100 right 200 left 300 center 400 numeric} update idletasks - list [expr [lindex [.t2 bbox 1.2] 0] + [lindex [.t2 bbox 1.2] 2]] \ - [lindex [.t2 bbox 1.4] 0] \ - [expr [lindex [.t2 bbox 1.6] 0] + [lindex [.t2 bbox 1.6] 2]/2] \ - [lindex [.t2 bbox 1.10] 0] -} {100 200 300 400} -test text-21.5 {TkTextGetTabs procedure} { - .t2 configure -tabs {105 r 205 l 305 c 405 n} + list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \ + [lindex [.t bbox 1.4] 0] \ + [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \ + [lindex [.t bbox 1.10] 0] +} -cleanup { + destroy .t +} -result {100 200 300 400} +test text-23.5 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs {105 r 205 l 305 c 405 n} update idletasks - list [expr [lindex [.t2 bbox 1.2] 0] + [lindex [.t2 bbox 1.2] 2]] \ - [lindex [.t2 bbox 1.4] 0] \ - [expr [lindex [.t2 bbox 1.6] 0] + [lindex [.t2 bbox 1.6] 2]/2] \ - [lindex [.t2 bbox 1.10] 0] -} {105 205 305 405} -test text-21.6 {TkTextGetTabs procedure} { - list [catch {.t2 configure -tabs {100 left 200 lork}} msg] $msg -} {1 {bad tab alignment "lork": must be left, right, center, or numeric}} -test text-21.7 {TkTextGetTabs procedure} { - list [catch {.t2 configure -tabs {100 !44 200 lork}} msg] $msg -} {1 {bad screen distance "!44"}} - -deleteWindows -text .t -pack .t -.t insert 1.0 "One Line" -.t mark set insert 1.0 - -test text-22.1 {TextDumpCmd procedure, bad args} { - list [catch {.t dump} msg] $msg -} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} -test text-22.2 {TextDumpCmd procedure, bad args} { - list [catch {.t dump -all} msg] $msg -} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} -test text-22.3 {TextDumpCmd procedure, bad args} { - list [catch {.t dump -command} msg] $msg -} {1 {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?}} -test text-22.4 {TextDumpCmd procedure, bad args} { - list [catch {.t dump -bogus} msg] $msg -} {1 {bad option "-bogus": must be -all, -command, -image, -mark, -tag, -text, or -window}} -test text-22.5 {TextDumpCmd procedure, bad args} { - list [catch {.t dump bogus} msg] $msg -} {1 {bad text index "bogus"}} -test text-22.6 {TextDumpCmd procedure, one index} { + list [expr [lindex [.t bbox 1.2] 0] + [lindex [.t bbox 1.2] 2]] \ + [lindex [.t bbox 1.4] 0] \ + [expr [lindex [.t bbox 1.6] 0] + [lindex [.t bbox 1.6] 2]/2] \ + [lindex [.t bbox 1.10] 0] +} -cleanup { + destroy .t +} -result {105 205 305 405} +test text-23.6 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs {100 left 200 lork} +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad tab alignment "lork": must be left, right, center, or numeric} +test text-23.7 {TkTextGetTabs procedure} -setup { + text .t -highlightthickness 0 -bd 0 -relief flat -padx 0 -width 100 + pack .t +} -body { + .t insert end "1\t2\t3\t4\t55.5" + .t configure -tabs {100 !44 200 lork} +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad screen distance "!44"} + + +test text-24.1 {TextDumpCmd procedure, bad args} -body { + pack [text .t] + .t insert 1.0 "One Line" + .t mark set insert 1.0 + .t dump +} -cleanup { + destroy .t +} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?} +test text-24.2 {TextDumpCmd procedure, bad args} -body { + pack [text .t] + .t insert 1.0 "One Line" + .t mark set insert 1.0 + .t dump -all +} -cleanup { + destroy .t +} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?} +test text-24.3 {TextDumpCmd procedure, bad args} -body { + pack [text .t] + .t insert 1.0 "One Line" + .t mark set insert 1.0 + .t dump -command +} -cleanup { + destroy .t +} -returnCodes {error} -result {Usage: .t dump ?-all -image -text -mark -tag -window? ?-command script? index ?index2?} +test text-24.4 {TextDumpCmd procedure, bad args} -body { + pack [text .t] + .t insert 1.0 "One Line" + .t mark set insert 1.0 + .t dump -bogus +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad option "-bogus": must be -all, -command, -image, -mark, -tag, -text, or -window} +test text-24.5 {TextDumpCmd procedure, bad args} -body { + pack [text .t] + .t insert 1.0 "One Line" + .t mark set insert 1.0 + .t dump bogus +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad text index "bogus"} +test text-24.6 {TextDumpCmd procedure, one index} -body { + pack [text .t] + .t insert 1.0 "One Line" .t dump -text 1.2 -} {text e 1.2} -test text-22.7 {TextDumpCmd procedure, two indices} { +} -cleanup { + destroy .t +} -result {text e 1.2} +test text-24.7 {TextDumpCmd procedure, two indices} -body { + pack [text .t] + .t insert 1.0 "One Line" .t dump -text 1.0 1.end -} {text {One Line} 1.0} -test text-22.8 {TextDumpCmd procedure, "end" index} { +} -cleanup { + destroy .t +} -result {text {One Line} 1.0} +test text-24.8 {TextDumpCmd procedure, "end" index} -body { + pack [text .t] + .t insert 1.0 "One Line" .t dump -text 1.end end -} {text { +} -cleanup { + destroy .t +} -result {text { } 1.8} -test text-22.9 {TextDumpCmd procedure, same indices} { +test text-24.9 {TextDumpCmd procedure, same indices} -body { + pack [text .t] + .t insert 1.0 "One Line" .t dump 1.5 1.5 -} {} -test text-22.10 {TextDumpCmd procedure, negative range} { +} -cleanup { + destroy .t +} -result {} +test text-24.10 {TextDumpCmd procedure, negative range} -body { + pack [text .t] + .t insert 1.0 "One Line" + .t mark set insert 1.0 .t dump 1.5 1.0 -} {} -.t delete 1.0 end -.t insert end "Line One\nLine Two\nLine Three\nLine Four" -.t mark set insert 1.0 -.t mark set current 1.0 -test text-22.11 {TextDumpCmd procedure, stop at begin-line} { +} -cleanup { + destroy .t +} -result {} +test text-24.11 {TextDumpCmd procedure, stop at begin-line} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" .t dump -text 1.0 2.0 -} {text {Line One +} -cleanup { + destroy .t +} -result {text {Line One } 1.0} -test text-22.12 {TextDumpCmd procedure, span multiple lines} { +test text-24.12 {TextDumpCmd procedure, span multiple lines} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" .t dump -text 1.5 3.end -} {text {One +} -cleanup { + destroy .t +} -result {text {One } 1.5 text {Line Two } 2.0 text {Line Three} 3.0} -.t tag add x 2.0 2.end -.t tag add y 1.0 end -.t mark set m 2.4 -.t mark set n 4.0 -.t mark set END end -test text-22.13 {TextDumpCmd procedure, tags only} { +test text-24.13 {TextDumpCmd procedure, tags only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t tag add x 2.0 2.end + .t tag add y 1.0 end .t dump -tag 2.1 2.8 -} {} -test text-22.14 {TextDumpCmd procedure, tags only} { +} -cleanup { + destroy .t +} -result {} +test text-24.14 {TextDumpCmd procedure, tags only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t tag add x 2.0 2.end + .t tag add y 1.0 end .t dump -tag 2.0 2.8 -} {tagon x 2.0} -test text-22.15 {TextDumpCmd procedure, tags only} { +} -cleanup { + destroy .t +} -result {tagon x 2.0} +test text-24.15 {TextDumpCmd procedure, tags only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t tag add x 2.0 2.end + .t tag add y 1.0 end .t dump -tag 1.0 4.end -} {tagon y 1.0 tagon x 2.0 tagoff x 2.8} -test text-22.16 {TextDumpCmd procedure, tags only} { +} -cleanup { + destroy .t +} -result {tagon y 1.0 tagon x 2.0 tagoff x 2.8} +test text-24.16 {TextDumpCmd procedure, tags only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t tag add x 2.0 2.end + .t tag add y 1.0 end .t dump -tag 1.0 end -} {tagon y 1.0 tagon x 2.0 tagoff x 2.8 tagoff y 5.0} -.t mark set insert 1.0 -.t mark set current 1.0 -test text-22.17 {TextDumpCmd procedure, marks only} { +} -cleanup { + destroy .t +} -result {tagon y 1.0 tagon x 2.0 tagoff x 2.8 tagoff y 5.0} +test text-24.17 {TextDumpCmd procedure, marks only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t mark set insert 1.0 + .t mark set current 1.0 + .t mark set m 2.4 + .t mark set n 4.0 + .t mark set END end .t dump -mark 1.1 1.8 -} {} -test text-22.18 {TextDumpCmd procedure, marks only} { +} -cleanup { + destroy .t +} -result {} +test text-24.18 {TextDumpCmd procedure, marks only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t mark set insert 1.0 + .t mark set current 1.0 + .t mark set m 2.4 + .t mark set n 4.0 + .t mark set END end .t dump -mark 2.0 2.8 -} {mark m 2.4} -test text-22.19 {TextDumpCmd procedure, marks only} { +} -cleanup { + destroy .t +} -result {mark m 2.4} +test text-24.19 {TextDumpCmd procedure, marks only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t mark set insert 1.0 + .t mark set current 1.0 + .t mark set m 2.4 + .t mark set n 4.0 + .t mark set END end .t dump -mark 1.1 4.end -} {mark m 2.4 mark n 4.0} -test text-22.20 {TextDumpCmd procedure, marks only} { +} -cleanup { + destroy .t +} -result {mark m 2.4 mark n 4.0} +test text-24.20 {TextDumpCmd procedure, marks only} -body { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t mark set insert 1.0 + .t mark set current 1.0 + .t mark set m 2.4 + .t mark set n 4.0 + .t mark set END end .t dump -mark 1.0 end -} {mark current 1.0 mark insert 1.0 mark m 2.4 mark n 4.0 mark END 5.0} -button .hello -text Hello -.t window create 3.end -window .hello -for {set i 0} {$i < 100} {incr i} { - .t insert end "-\n" -} -.t window create 100.0 -create { } -test text-22.21 {TextDumpCmd procedure, windows only} { +} -cleanup { + destroy .t +} -result {mark current 1.0 mark insert 1.0 mark m 2.4 mark n 4.0 mark END 5.0} +test text-24.21 {TextDumpCmd procedure, windows only} -setup { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + for {set i 0} {$i < 100} {incr i} {.t insert end "-\n"} + button .hello -text Hello +} -body { + .t window create 3.end -window .hello + .t window create 100.0 -create { } .t dump -window 1.0 5.0 -} {window .hello 3.10} -test text-22.22 {TextDumpCmd procedure, windows only} { +} -cleanup { + destroy .t +} -result {window .hello 3.10} +test text-24.22 {TextDumpCmd procedure, windows only} -setup { + pack [text .t] + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + for {set i 0} {$i < 100} {incr i} {.t insert end "-\n"} + button .hello -text Hello +} -body { + .t window create 3.end -window .hello + .t window create 100.0 -create { } .t dump -window 5.0 end -} {window {} 100.0} -.t delete 1.0 end -eval {.t mark unset} [.t mark names] -.t insert end "Line One\nLine Two\nLine Three\nLine Four" -.t mark set insert 1.0 -.t mark set current 1.0 -.t tag add x 2.0 2.end -.t mark set m 2.4 -proc Append {varName key value index} { - upvar #0 $varName x - lappend x $key $index $value -} -test text-22.23 {TextDumpCmd procedure, command script} { +} -cleanup { + destroy .t +} -result {window {} 100.0} +test text-24.23 {TextDumpCmd procedure, command script} -setup { set x {} + pack [text .t] + proc Append {varName key value index} { + upvar #0 $varName x + lappend x $key $index $value + } +} -body { + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t mark set insert 1.0 + .t mark set current 1.0 + .t tag add x 2.0 2.end + .t mark set m 2.4 .t dump -command {Append x} -all 1.0 end - set x -} {mark 1.0 current mark 1.0 insert text 1.0 {Line One + return $x +} -cleanup { + destroy .t + rename Append {} +} -result {mark 1.0 current mark 1.0 insert text 1.0 {Line One } tagon 2.0 x text 2.0 Line mark 2.4 m text 2.4 { Two} tagoff 2.8 x text 2.8 { } text 3.0 {Line Three } text 4.0 {Line Four }} -test text-22.24 {TextDumpCmd procedure, command script} { +test text-24.24 {TextDumpCmd procedure, command script} -setup { set x {} + pack [text .t] + proc Append {varName key value index} { + upvar #0 $varName x + lappend x $key $index $value + } +} -body { + .t insert end "Line One\nLine Two\nLine Three\nLine Four" + .t mark set insert 1.0 + .t mark set current 1.0 + .t mark set m 2.4 .t dump -mark -command {Append x} 1.0 end - set x -} {mark 1.0 current mark 1.0 insert mark 2.4 m} -catch {unset x} -test text-22.25 {TextDumpCmd procedure, unicode characters} { - catch {destroy .t} + return $x +} -cleanup { + destroy .t + rename Append {} +} -result {mark 1.0 current mark 1.0 insert mark 2.4 m} +test text-24.25 {TextDumpCmd procedure, unicode characters} -body { text .t - .t delete 1.0 end .t insert 1.0 \xb1\xb1\xb1 .t dump -all 1.0 2.0 -} "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3" -test text-22.26 {TextDumpCmd procedure, unicode characters} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result "text \xb1\xb1\xb1 1.0 mark insert 1.3 mark current 1.3 text {\n} 1.3" +test text-24.26 {TextDumpCmd procedure, unicode characters} -body { text .t .t delete 1.0 end .t insert 1.0 abc\xb1\xb1\xb1 .t dump -all 1.0 2.0 -} "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" -test text-22.27 {TextDumpCmd procedure, peer present} -setup { +} -cleanup { destroy .t -} -body { +} -result "text abc\xb1\xb1\xb1 1.0 mark insert 1.6 mark current 1.6 text {\n} 1.6" +test text-24.27 {TextDumpCmd procedure, peer present} -body { text .t .t peer create .t.t .t dump -all 1.0 end @@ -2944,21 +5881,18 @@ test text-22.27 {TextDumpCmd procedure, peer present} -setup { destroy .t } -result "mark insert 1.0 mark current 1.0 text {\n} 1.0" -set l [interp hidden] -deleteWindows - -test text-23.1 {text widget vs hidden commands} { - catch {destroy .t} +test text-25.1 {text widget vs hidden commands} -body { text .t + set y [list {} [interp hidden]] interp hide {} .t destroy .t - list [winfo children .] [interp hidden] -} [list {} $l] + set x [list [winfo children .] [interp hidden]] + expr {$x eq $y} +} -result {1} -test text-24.1 {bug fix - 1642} { - catch {destroy .t} - text .t - pack .t + +test text-26.1 {bug fix - 1642} -body { + pack [text .t] .t insert end "line 1\n" .t insert end "line 2\n" .t insert end "line 3\n" @@ -2966,16 +5900,24 @@ test text-24.1 {bug fix - 1642} { .t insert end "line 5\n" tk::TextSetCursor .t 3.0 .t search -backward -regexp "\$" insert 1.0 -} {2.6} - -test text-25.1 {TextEditCmd procedure, argument parsing} { - list [catch {.t edit} msg] $msg -} {1 {wrong # args: should be ".t edit option ?arg arg ...?"}} -test text-25.2 {TextEditCmd procedure, argument parsing} { - list [catch {.t edit gorp} msg] $msg -} {1 {bad edit option "gorp": must be modified, redo, reset, separator, or undo}} -test text-25.3 {TextEditUndo procedure, undoing changes} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {2.6} + + +test text-27.1 {TextEditCmd procedure, argument parsing} -body { + pack [text .t] + .t edit +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t edit option ?arg ...?"} +test text-27.2 {TextEditCmd procedure, argument parsing} -body { + pack [text .t] + .t edit gorp +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad edit option "gorp": must be modified, redo, reset, separator, or undo} +test text-27.3 {TextEditUndo procedure, undoing changes} -body { text .t -undo 1 pack .t .t insert end "line 1\n" @@ -2983,9 +5925,10 @@ test text-25.3 {TextEditUndo procedure, undoing changes} { .t insert end "should be gone after undo\n" .t edit undo .t get 1.0 end -} "line\n\n" -test text-25.4 {TextEditRedo procedure, redoing changes} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result "line\n\n" +test text-27.4 {TextEditRedo procedure, redoing changes} -body { text .t -undo 1 pack .t .t insert end "line 1\n" @@ -2994,9 +5937,10 @@ test text-25.4 {TextEditRedo procedure, redoing changes} { .t edit undo .t edit redo .t get 1.0 end -} "line\nshould be back after redo\n\n" -test text-25.5 {TextEditUndo procedure, resetting stack} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result "line\nshould be back after redo\n\n" +test text-27.5 {TextEditUndo procedure, resetting stack} -body { text .t -undo 1 pack .t .t insert end "line 1\n" @@ -3004,10 +5948,11 @@ test text-25.5 {TextEditUndo procedure, resetting stack} { .t insert end "should be back after redo\n" .t edit reset catch {.t edit undo} msg - set msg -} "nothing to undo" -test text-25.6 {TextEditCmd procedure, insert separator} { - catch {destroy .t} + return $msg +} -cleanup { + destroy .t +} -result "nothing to undo" +test text-27.6 {TextEditCmd procedure, insert separator} -body { text .t -undo 1 pack .t .t insert end "line 1\n" @@ -3015,9 +5960,10 @@ test text-25.6 {TextEditCmd procedure, insert separator} { .t insert end "line 2\n" .t edit undo .t get 1.0 end -} "line 1\n\n" -test text-25.7 {-autoseparators configuration option} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result "line 1\n\n" +test text-27.7 {-autoseparators configuration option} -body { text .t -undo 1 -autoseparators 0 pack .t .t insert end "line 1\n" @@ -3025,36 +5971,41 @@ test text-25.7 {-autoseparators configuration option} { .t insert end "line 2\n" .t edit undo .t get 1.0 end -} "\n" -test text-25.8 {TextEditCmd procedure, modified flag} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result "\n" +test text-27.8 {TextEditCmd procedure, modified flag} -body { text .t pack .t .t insert end "line 1\n" .t edit modified -} {1} -test text-25.9 {TextEditCmd procedure, reset modified flag} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {1} +test text-27.9 {TextEditCmd procedure, reset modified flag} -body { text .t pack .t .t insert end "line 1\n" .t edit modified 0 .t edit modified -} {0} -test text-25.10 {TextEditCmd procedure, set modified flag} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {0} +test text-27.10 {TextEditCmd procedure, set modified flag} -body { text .t pack .t .t edit modified 1 .t edit modified -} {1} -test text-25.10.1 {TextEditCmd procedure, set modified flag repeat} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {1} +test text-27.11 {TextEditCmd procedure, set modified flag repeat} -setup { text .t pack .t set ::retval {} +} -body { bind .t <<Modified>> "lappend ::retval modified" - # Shouldn't require [update idle] to trigger event [Bug 1809538] +# Shouldn't require [update idle] to trigger event [Bug 1809538] lappend ::retval [.t edit modified] .t edit modified 1 update idletasks @@ -3062,50 +6013,54 @@ test text-25.10.1 {TextEditCmd procedure, set modified flag repeat} { .t edit modified 1 ; # binding should only fire once [Bug 1799782] update idletasks lappend ::retval [.t edit modified] -} {0 modified 1 1} -test text-25.11 {<<Modified>> virtual event} { +} -cleanup { + destroy .t +} -result {0 modified 1 1} +test text-27.12 {<<Modified>> virtual event} -body { set ::retval unmodified - catch {destroy .t} text .t -undo 1 pack .t bind .t <<Modified>> "set ::retval modified" update idletasks .t insert end "nothing special\n" - set ::retval -} {modified} -test text-25.11.1 {<<Modified>> virtual event - insert before Modified} { - set ::retval {} + return $::retval +} -cleanup { destroy .t +} -result {modified} +test text-27.13 {<<Modified>> virtual event - insert before Modified} -body { + set ::retval {} pack [text .t -undo 1] bind .t <<Modified>> { set ::retval [.t get 1.0 end-1c] } update idletasks .t insert end "nothing special" - set ::retval -} {nothing special} -test text-25.11.2 {<<Modified>> virtual event - delete before Modified} { - # Bug 1737288, make sure we delete chars before triggering <<Modified>> - set ::retval {} + return $::retval +} -cleanup { destroy .t +} -result {nothing special} +test text-27.14 {<<Modified>> virtual event - delete before Modified} -body { +# Bug 1737288, make sure we delete chars before triggering <<Modified>> + set ::retval {} pack [text .t -undo 1] bind .t <<Modified>> { set ::retval [.t get 1.0 end-1c] } .t insert end "nothing special" .t edit modified 0 .t delete 1.0 1.2 set ::retval -} {thing special} -test text-25.12 {<<Selection>> virtual event} { +} -cleanup { + destroy .t +} -result {thing special} +test text-27.15 {<<Selection>> virtual event} -body { set ::retval no_selection - catch {destroy .t} - text .t -undo 1 - pack .t + pack [text .t -undo 1] bind .t <<Selection>> "set ::retval selection_changed" update idletasks .t insert end "nothing special\n" .t tag add sel 1.0 1.1 set ::retval -} {selection_changed} -test text-25.13 {-maxundo configuration option} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {selection_changed} +test text-27.16 {-maxundo configuration option} -body { text .t -undo 1 -autoseparators 1 -maxundo 2 pack .t .t insert end "line 1\n" @@ -3115,17 +6070,20 @@ test text-25.13 {-maxundo configuration option} { catch {.t edit undo} catch {.t edit undo} .t get 1.0 end -} "line 1\n\n" -test text-25.15 {bug fix 1536735 - undo with empty text} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result "line 1\n\n" +test text-27.17 {bug fix 1536735 - undo with empty text} -body { text .t -undo 1 set r [.t edit modified] .t delete 1.0 lappend r [.t edit modified] lappend r [catch {.t edit undo}] lappend r [.t edit modified] -} {0 0 1 0} -test text-25.18 {patch 1469210 - inserting after undo} -setup { +} -cleanup { + destroy .t +} -result {0 0 1 0} +test text-27.18 {patch 1469210 - inserting after undo} -setup { destroy .t } -body { text .t -undo 1 @@ -3138,246 +6096,275 @@ test text-25.18 {patch 1469210 - inserting after undo} -setup { destroy .t } -result 1 -test text-26.1 {bug fix - 624372, ControlUtfProc long lines} { - destroy .t +test text-28.1 {bug fix - 624372, ControlUtfProc long lines} -body { pack [text .t -wrap none] .t insert end [string repeat "\1" 500] -} {} - -test text-27.1 {tabs - must be positive and must be increasing} { +} -cleanup { destroy .t +} -result {} + + +test text-29.1 {tabs - must be positive and must be increasing} -body { pack [text .t -wrap none] - list [catch {.t configure -tabs {0}} msg] $msg -} {1 {tab stop "0" is not at a positive distance}} -test text-27.2 {tabs - must be positive and must be increasing} { + .t configure -tabs {0} +} -cleanup { destroy .t +} -returnCodes {error} -result {tab stop "0" is not at a positive distance} +test text-29.2 {tabs - must be positive and must be increasing} -body { pack [text .t -wrap none] - list [catch {.t configure -tabs {-5}} msg] $msg -} {1 {tab stop "-5" is not at a positive distance}} -test text-27.3 {tabs - must be positive and must be increasing} {knownBug} { - # This bug will be fixed in Tk 9.0, when we can allow a minor - # incompatibility with Tk 8.x + .t configure -tabs {-5} +} -cleanup { destroy .t +} -returnCodes {error} -result {tab stop "-5" is not at a positive distance} +test text-29.3 {tabs - must be positive and must be increasing} -constraints { + knownBug +} -body { +# This bug will be fixed in Tk 9.0, when we can allow a minor +# incompatibility with Tk 8.x pack [text .t -wrap none] - list [catch {.t configure -tabs {10c 5c}} msg] $msg -} {1 {tabs must be monotonically increasing, but "5c" is smaller than or equal to the previous tab}} -test text-27.4 {tabs - must be positive and must be increasing} { + .t configure -tabs {10c 5c} +} -cleanup { destroy .t +} -returnCodes {error} -result {tabs must be monotonically increasing, but "5c" is smaller than or equal to the previous tab} +test text-29.4 {tabs - must be positive and must be increasing} -body { pack [text .t -wrap none] .t insert end "a\tb\tc\td\te" catch {.t configure -tabs {10c 5c}} update ; update ; update - # This test must simply not go into an infinite loop to succeed +# This test must simply not go into an infinite loop to succeed set result 1 -} {1} - -test text-28.0 {repeated insert and scroll} { - foreach subcmd { - {moveto 1} - {scroll 1 pages} - {scroll 100 pixels} - {scroll 10 units} - } { - destroy .t - pack [text .t] - for {set i 0} {$i < 30} {incr i} { - .t insert end "blabla\n" - eval .t yview $subcmd - } +} -cleanup { + destroy .t +} -result {1} + + +test text-30.1 {repeated insert and scroll} -body { + pack [text .t] + for {set i 0} {$i < 30} {incr i} { + .t insert end "blabla\n" + eval .t yview moveto 1 } - # This test must simply not crash to succeed +# This test must simply not crash to succeed set result 1 -} {1} - -test text-29.0 {peer widgets} { - destroy .t .tt - toplevel .tt - pack [text .t] - pack [.t peer create .tt.t] - destroy .t .tt -} {} -test text-29.1 {peer widgets} { - destroy .t .t1 .t2 - toplevel .t1 - toplevel .t2 - pack [text .t] - pack [.t peer create .t1.t] - pack [.t peer create .t2.t] +} -cleanup { + destroy .t +} -result {1} +test text-30.2 {repeated insert and scroll} -body { + pack [text .t] + for {set i 0} {$i < 30} {incr i} { + .t insert end "blabla\n" + eval .t yview scroll 1 pages + } +# This test must simply not crash to succeed + set result 1 +} -cleanup { + destroy .t +} -result {1} +test text-30.3 {repeated insert and scroll} -body { + pack [text .t] + for {set i 0} {$i < 30} {incr i} { + .t insert end "blabla\n" + eval .t yview scroll 100 pixels + } +# This test must simply not crash to succeed + set result 1 +} -cleanup { + destroy .t +} -result {1} +test text-30.4 {repeated insert and scroll} -body { + pack [text .t] + for {set i 0} {$i < 30} {incr i} { + .t insert end "blabla\n" + eval .t yview scroll 10 units + } +# This test must simply not crash to succeed + set result 1 +} -cleanup { + destroy .t +} -result {1} + + +test text-31.1 {peer widgets} -body { + toplevel .top + pack [text .t] + pack [.t peer create .top.t] + destroy .t .top +} -result {} +test text-31.2 {peer widgets} -body { + toplevel .top1 + toplevel .top2 + pack [text .t] + pack [.t peer create .top1.t] + pack [.t peer create .top2.t] .t insert end "abcd\nabcd" update - destroy .t1 + destroy .top1 update .t insert end "abcd\nabcd" update - destroy .t .t2 + destroy .t .top2 update -} {} -test text-29.2 {peer widgets} { - destroy .t .t1 .t2 - toplevel .t1 - toplevel .t2 +} -result {} +test text-31.3 {peer widgets} -body { + toplevel .top1 + toplevel .top2 pack [text .t] - pack [.t peer create .t1.t] - pack [.t peer create .t2.t] + pack [.t peer create .top1.t] + pack [.t peer create .top2.t] .t insert end "abcd\nabcd" update destroy .t update - .t2.t insert end "abcd\nabcd" + .top2.t insert end "abcd\nabcd" update - destroy .t .t2 + destroy .t .top2 update -} {} -test text-29.3 {peer widgets} { - destroy .t .tt - toplevel .tt +} -result {} +test text-31.4 {peer widgets} -body { + toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] + pack [.t peer create .top.t -start 5 -end 11] update - destroy .t .tt -} {} -test text-29.4 {peer widgets} { - destroy .t .tt - toplevel .tt + destroy .t .top +} -result {} +test text-31.5 {peer widgets} -body { + toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] - pack [.tt.t peer create .tt.t2] - set res [list [.tt.t index end] [.tt.t2 index end]] + pack [.t peer create .top.t -start 5 -end 11] + pack [.top.t peer create .top.t2] + set res [list [.top.t index end] [.top.t2 index end]] update - destroy .t .tt - set res -} {7.0 7.0} -test text-29.4.1 {peer widgets} { - destroy .t .tt - toplevel .tt + return $res +} -cleanup { + destroy .t .top +} -result {7.0 7.0} +test text-31.6 {peer widgets} -body { + toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] - pack [.tt.t peer create .tt.t2 -start {} -end {}] - set res [list [.tt.t index end] [.tt.t2 index end]] + pack [.t peer create .top.t -start 5 -end 11] + pack [.top.t peer create .top.t2 -start {} -end {}] + set res [list [.top.t index end] [.top.t2 index end]] update - destroy .t .tt - set res -} {7.0 21.0} -test text-29.5 {peer widgets} { - destroy .t .tt - toplevel .tt + return $res +} -cleanup { + destroy .t .top +} -result {7.0 21.0} +test text-31.7 {peer widgets} -body { + toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] + pack [.t peer create .top.t -start 5 -end 11] update ; update - set p1 [.tt.t count -update -ypixels 1.0 end] + set p1 [.top.t count -update -ypixels 1.0 end] set p2 [.t count -update -ypixels 5.0 11.0] - if {$p1 == $p2} { - set res "ok" - } else { - set res "$p1 and $p2 not equal" - } - destroy .t .tt - set res -} {ok} -test text-29.6 {peer widgets} { - destroy .t .tt - toplevel .tt + expr {$p1 eq $p2} +} -cleanup { + destroy .t .top +} -result {1} +test text-31.8 {peer widgets} -body { + toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] + pack [.t peer create .top.t -start 5 -end 11] update ; update .t delete 3.0 6.0 - set res [.tt.t index end] - destroy .t .tt - set res -} {6.0} -test text-29.7 {peer widgets} { - destroy .t .tt - toplevel .tt + .top.t index end +} -cleanup { + destroy .t .top +} -result {6.0} +test text-31.9 {peer widgets} -body { + toplevel .top pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] + pack [.t peer create .top.t -start 5 -end 11] update ; update .t delete 8.0 12.0 - set res [.tt.t index end] - destroy .t .tt - set res -} {4.0} -test text-29.8 {peer widgets} { - destroy .t .tt - toplevel .tt + .top.t index end +} -cleanup { + destroy .t .top +} -result {4.0} +test text-31.10 {peer widgets} -body { + toplevel .top pack [text .t] - for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + for {set i 1} {$i < 20} {incr i} { + .t insert end "Line $i\n" } - pack [.t peer create .tt.t -start 5 -end 11] + pack [.t peer create .top.t -start 5 -end 11] update ; update .t delete 3.0 13.0 - set res [.tt.t index end] - destroy .t .tt - set res -} {1.0} -test text-29.9 {peer widgets} { - destroy .t + .top.t index end +} -cleanup { + destroy .t .top +} -result {1.0} +test text-31.11 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add sel 1.0 end-1c - set res {} lappend res [.t tag ranges sel] .t configure -start 10 -end 20 lappend res [.t tag ranges sel] + return $res +} -cleanup { destroy .t - set res -} {{1.0 100.0} {1.0 11.0}} -test text-29.10 {peer widgets} { - destroy .t +} -result {{1.0 100.0} {1.0 11.0}} +test text-31.12 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add sel 1.0 end-1c - set res {} lappend res [.t tag ranges sel] .t configure -start 11 lappend res [.t tag ranges sel] + return $res +} -cleanup { destroy .t - set res -} {{1.0 100.0} {1.0 90.0}} -test text-29.11 {peer widgets} { - destroy .t +} -result {{1.0 100.0} {1.0 90.0}} +test text-31.13 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add sel 1.0 end-1c - set res {} lappend res [.t tag ranges sel] .t configure -end 90 lappend res [.t tag ranges sel] destroy .t - set res -} {{1.0 100.0} {1.0 90.0}} -test text-29.12 {peer widgets} { + return $res +} -cleanup { destroy .t +} -result {{1.0 100.0} {1.0 90.0}} +test text-31.14 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add sel 1.0 3.0 5.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 - set res {} lappend res [.t tag prevrange sel 1.0] .t configure -start 6 -end 12 lappend res [.t tag ranges sel] @@ -3387,17 +6374,18 @@ test text-29.12 {peer widgets} { lappend res "prev" [.t tag prevrange sel 1.0] \ [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \ [.t tag prevrange sel 4.0] + return $res +} -cleanup { destroy .t - set res -} {{} {1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}} -test text-29.13 {peer widgets} { - destroy .t +} -result {{} {1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}} +test text-31.15 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add sel 1.0 3.0 9.0 11.0 13.0 15.0 17.0 19.0 - set res {} .t configure -start 6 -end 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ @@ -3406,17 +6394,18 @@ test text-29.13 {peer widgets} { lappend res "prev" [.t tag prevrange sel 1.0] \ [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \ [.t tag prevrange sel 4.0] + return $res +} -cleanup { destroy .t - set res -} {{4.0 6.0} next {4.0 6.0} {} {} {} prev {} {} {} {}} -test text-29.14 {peer widgets} { - destroy .t +} -result {{4.0 6.0} next {4.0 6.0} {} {} {} prev {} {} {} {}} +test text-31.16 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 20} {incr i} { .t insert end "Line $i\n" } .t tag add sel 1.0 7.0 9.0 11.0 13.0 15.0 17.0 19.0 - set res {} .t configure -start 6 -end 12 lappend res [.t tag ranges sel] lappend res "next" [.t tag nextrange sel 4.0] \ @@ -3425,16 +6414,17 @@ test text-29.14 {peer widgets} { lappend res "prev" [.t tag prevrange sel 1.0] \ [.t tag prevrange sel 2.0] [.t tag prevrange sel 3.0] \ [.t tag prevrange sel 4.0] + return $res +} -cleanup { destroy .t - set res -} {{1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}} -test text-29.15 {peer widgets} { - destroy .t +} -result {{1.0 2.0 4.0 6.0} next {4.0 6.0} {} {} {} prev {} {1.0 2.0} {1.0 2.0} {1.0 2.0}} +test text-31.17 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - set res {} .t tag add sel 1.0 11.0 lappend res [.t tag ranges sel] lappend res [catch {.t configure -start 15 -end 10}] @@ -3443,58 +6433,61 @@ test text-29.15 {peer widgets} { lappend res [.t tag ranges sel] .t configure -start {} -end {} lappend res [.t tag ranges sel] + return $res +} -cleanup { destroy .t - set res -} {{1.0 11.0} 1 {1.0 11.0} {1.0 6.0} {1.0 11.0}} -test text-29.16 {peer widgets} { - destroy .t +} -result {{1.0 11.0} 1 {1.0 11.0} {1.0 6.0} {1.0 11.0}} +test text-31.18 {peer widgets} -setup { pack [text .t] + set res {} +} -body { for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - set res {} .t tag add sel 1.0 11.0 lappend res [.t index sel.first] lappend res [.t index sel.last] + return $res +} -cleanup { destroy .t - set res -} {1.0 11.0} -test text-29.17 {peer widgets} { - destroy .t +} -result {1.0 11.0} +test text-31.19 {peer widgets} -body { pack [text .t] for {set i 1} {$i < 20} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - set res {} .t tag delete sel - set res [list [catch {.t index sel.first} msg] $msg] + .t index sel.first +} -cleanup { destroy .t - set res -} {1 {text doesn't contain any characters tagged with "sel"}} +} -returnCodes {error} -result {text doesn't contain any characters tagged with "sel"} -proc makeText {} { - set w .g - set font "Times 11" - destroy .g - toplevel .g - frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken - set t $w.f.text - text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ - -height 35 -wrap word -highlightthickness 0 -borderwidth 0 - pack $t -expand yes -fill both - scrollbar $w.scroll -command "$t yview" - pack $w.scroll -side right -fill y - pack $w.f -expand yes -fill both - $t tag configure center -justify center -spacing1 5m -spacing3 5m - $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ - -spacing1 3m -spacing2 0 -spacing3 0 - for {set i 0} {$i < 40} {incr i} { - $t insert end "${i}word " - } - return $t -} -test text-30.1 {line heights on creation} { +test text-32.1 {line heights on creation} -setup { + text .t + proc makeText {} { + set w .g + set font "Times 11" + destroy .g + toplevel .g + frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken + set t $w.f.text + text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font \ + -width 70 -height 35 -wrap word -highlightthickness 0 \ + -borderwidth 0 + pack $t -expand yes -fill both + scrollbar $w.scroll -command "$t yview" + pack $w.scroll -side right -fill y + pack $w.f -expand yes -fill both + $t tag configure center -justify center -spacing1 5m -spacing3 5m + $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ + -spacing1 3m -spacing2 0 -spacing3 0 + for {set i 0} {$i < 40} {incr i} { + $t insert end "${i}word " + } + return $t + } +} -body { set w [makeText] update ; after 1000 ; update set before [$w count -ypixels 1.0 2.0] @@ -3502,63 +6495,88 @@ test text-30.1 {line heights on creation} { update set after [$w count -ypixels 1.0 2.0] destroy .g - if {$before != $after} { - set res "Count changed: $before $after" - } else { - set res "ok" - } -} {ok} - -destroy .t -text .t -test text-31.1 {TextWidgetCmd procedure, "peer" option} { - list [catch {.t peer foo 1} msg] $msg -} {1 {bad peer option "foo": must be create or names}} -test text-31.2 {TextWidgetCmd procedure, "peer" option} { - list [catch {.t peer names foo} msg] $msg -} {1 {wrong # args: should be ".t peer names"}} -test text-31.3 {TextWidgetCmd procedure, "peer" option} { - list [catch {.t p names} msg] $msg -} {0 {}} -test text-31.4 {TextWidgetCmd procedure, "peer" option} { + expr {$before eq $after} +} -cleanup { + destroy .t +} -result {1} + + +test text-33.1 {TextWidgetCmd procedure, "peer" option} -setup { + text .t +} -body { + .t peer foo 1 +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad peer option "foo": must be create or names} +test text-33.2 {TextWidgetCmd procedure, "peer" option} -setup { + text .t +} -body { + .t peer names foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {wrong # args: should be ".t peer names"} +test text-33.3 {TextWidgetCmd procedure, "peer" option} -setup { + text .t +} -body { + .t p names +} -cleanup { + destroy .t +} -returnCodes {ok} -result {} +test text-33.4 {TextWidgetCmd procedure, "peer" option} -setup { + text .t +} -body { .t peer names -} {} -test text-31.5 {TextWidgetCmd procedure, "peer" option} { - list [catch {.t peer create foo} msg] $msg -} {1 {bad window path name "foo"}} -test text-31.6 {TextWidgetCmd procedure, "peer" option} { - .t peer create .t2 +} -cleanup { + destroy .t +} -result {} +test text-33.5 {TextWidgetCmd procedure, "peer" option} -setup { + text .t +} -body { + .t peer create foo +} -cleanup { + destroy .t +} -returnCodes {error} -result {bad window path name "foo"} +test text-33.6 {TextWidgetCmd procedure, "peer" option} -setup { + text .t set res {} +} -body { + .t peer create .t2 lappend res [.t peer names] lappend res [.t2 peer names] destroy .t2 lappend res [.t peer names] -} {.t2 .t {}} -test text-31.7 {peer widget -start, -end} { - set res [list [catch {.t configure -start 10 -end 5} msg] $msg] - .t configure -start {} -end {} - set res -} {0 {}} -test text-31.8 {peer widget -start, -end} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {.t2 .t {}} +test text-33.7 {peer widget -start, -end} -body { + text .t + set res [.t configure -start 10 -end 5] + return $res +} -cleanup { + destroy .t +} -returnCodes {2} -result {} +test text-33.8 {peer widget -start, -end} -body { + text .t for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } - list [catch {.t configure -start 10 -end 5} msg] $msg -} {1 {-startline must be less than or equal to -endline}} -test text-31.9 {peer widget -start, -end} { - .t delete 1.0 end + .t configure -start 10 -end 5 +} -cleanup { + destroy .t +} -returnCodes {error} -result {-startline must be less than or equal to -endline} +test text-33.9 {peer widget -start, -end} -body { + text .t for {set i 1} {$i < 100} {incr i} { .t insert end "Line $i\n" } - set res [list [catch {.t configure -start 5 -end 10} msg] $msg] - .t configure -start {} -end {} - set res -} {0 {}} -test text-31.10 {peer widget -start, -end} { - .t delete 1.0 end + .t configure -start 5 -end 10 +} -cleanup { + destroy .t +} -returnCodes {ok} -result {} +test text-33.10 {peer widget -start, -end} -body { + text .t for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } set res [.t index end] lappend res [catch {.t configure -start 5 -end 10 -tab foo}] @@ -3567,12 +6585,14 @@ test text-31.10 {peer widget -start, -end} { lappend res [.t index end] .t configure -start {} -end {} lappend res [.t index end] - set res -} {101.0 1 101.0 1 101.0 101.0} -test text-31.11 {peer widget -start, -end} { - .t delete 1.0 end + return $res +} -cleanup { + destroy .t +} -result {101.0 1 101.0 1 101.0 101.0} +test text-33.11 {peer widget -start, -end} -body { + text .t for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } set res [.t index end] lappend res [catch {.t configure -start 5 -end 15}] @@ -3581,16 +6601,19 @@ test text-31.11 {peer widget -start, -end} { lappend res [.t index end] .t configure -start {} -end {} lappend res [.t index end] - set res -} {101.0 0 11.0 0 31.0 101.0} + return $res +} -cleanup { + destroy .t +} -result {101.0 0 11.0 0 31.0 101.0} -test text-32.1 {peer widget -start, -end and selection} { - .t delete 1.0 end +test text-34.1 {peer widget -start, -end and selection} -setup { + text .t + set res {} +} -body { for {set i 1} {$i < 100} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add sel 10.0 20.0 - set res {} lappend res [.t tag ranges sel] .t configure -start 5 -end 30 lappend res [.t tag ranges sel] @@ -3604,45 +6627,54 @@ test text-32.1 {peer widget -start, -end and selection} { lappend res [.t tag ranges sel] .t configure -start {} -end {} lappend res [.t tag ranges sel] - set res -} {{10.0 20.0} {6.0 16.0} {6.0 11.0} {1.0 6.0} {1.0 2.0} {} {10.0 20.0}} + return $res +} -cleanup { + destroy .t +} -result {{10.0 20.0} {6.0 16.0} {6.0 11.0} {1.0 6.0} {1.0 2.0} {} {10.0 20.0}} -test text-33.1 {widget dump -command alters tags} { - .t delete 1.0 end - .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c - .t tag configure b -background red - proc Dumpy {key value index} { - #puts "KK: $key, $value" +test text-35.1 {widget dump -command alters tags} -setup { + proc Dumpy {key value index} { +#puts "KK: $key, $value" .t tag add $value [list $index linestart] [list $index lineend] } - .t dump -all -command Dumpy 1.0 end - set result "ok" -} {ok} -test text-33.2 {widget dump -command makes massive changes} { - .t delete 1.0 end + text .t +} -body { .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c .t tag configure b -background red + .t dump -all -command Dumpy 1.0 end + set result "ok" +} -cleanup { + destroy .t +} -result {ok} +test text-35.2 {widget dump -command makes massive changes} -setup { proc Dumpy {key value index} { - #puts "KK: $key, $value" +#puts "KK: $key, $value" .t delete 1.0 end } - .t dump -all -command Dumpy 1.0 end - set result "ok" -} {ok} -test text-33.3 {widget dump -command destroys widget} { - .t delete 1.0 end + text .t +} -body { .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c .t tag configure b -background red + .t dump -all -command Dumpy 1.0 end + set result "ok" +} -cleanup { + destroy .t +} -result {ok} +test text-35.3 {widget dump -command destroys widget} -setup { proc Dumpy {key value index} { - #puts "KK: $key, $value" - destroy .t +#puts "KK: $key, $value" + destroy .t } + text .t +} -body { + .t insert end "abc\n" a "---" {} "def" b " \n" {} "ghi\n" c + .t tag configure b -background red .t dump -all -command Dumpy 1.0 end set result "ok" -} {ok} +} -cleanup { + destroy .t +} -result {ok} -deleteWindows -option clear test text-36.1 "bug #1777362: event handling with hyphenated windows" -setup { proc bgerror {m} {set ::my_error $m} @@ -3657,7 +6689,6 @@ test text-36.1 "bug #1777362: event handling with hyphenated windows" -setup { } -cleanup { destroy .t-1 } -result {} - test text-36.2 "bug #1777362: event handling with hyphenated windows" -setup { proc bgerror {m} {set ::my_error $m} set ::my_error {} @@ -3671,7 +6702,6 @@ test text-36.2 "bug #1777362: event handling with hyphenated windows" -setup { } -cleanup { destroy $w } -result {} - test text-36.3 "bug #1777362: event handling with hyphenated windows" -setup { proc bgerror {m} {set ::my_error $m} set ::my_error {} @@ -3685,7 +6715,11 @@ test text-36.3 "bug #1777362: event handling with hyphenated windows" -setup { } -cleanup { destroy $w } -result {} - + # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/textBTree.test b/tests/textBTree.test index 3a89e55..41b3d98 100644 --- a/tests/textBTree.test +++ b/tests/textBTree.test @@ -8,642 +8,848 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -catch {destroy .t} +proc setup {} { + .t delete 1.0 100000.0 + .t tag delete x y + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t tag add x 1.1 + .t tag add x 1.5 1.13 + .t tag add x 2.2 2.6 + .t tag add y 1.5 +} + +# setup procedure for tests 10.*, 11.*, 12.* +proc msetup {} { + .t delete 1.0 100000.0 + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + .t mark set m1 1.2 + .t mark set l1 1.2 + .t mark gravity l1 left + .t mark set next 1.6 + .t mark set x 1.6 + .t mark set m2 2.0 + .t mark set m3 2.100 + .t tag add x 1.3 1.8 +} + +# setup procedure for tests 16.*, 17.*, 18.9 +proc setupBig {} { + .t delete 1.0 end + .t tag delete x y + .t tag configure x -foreground blue + .t tag configure y -underline true + # Create a Btree with 2002 lines (2000 + already existing + phantom at end) + # This generates a level 3 node with 9 children + # Most level 2 nodes cover 216 lines and have 6 children, except the last + # level 2 node covers 274 lines and has 7 children. + # Most level 1 nodes cover 36 lines and have 6 children, except the + # rightmost node has 58 lines and 9 children. + # Level 2: 2002 = 8*216 + 274 + # Level 1: 2002 = 54*36 + 58 + # Level 0: 2002 = 332*6 + 10 + for {set i 0} {$i < 2000} {incr i} { + append x "Line $i abcd efgh ijkl\n" + } + .t insert insert $x + .t debug 1 +} + +# Widget used in tests 1.* - 13.* +destroy .t text .t .t debug on -test btree-1.1 {basic insertions} { +test btree-1.1 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-1.2 {basic insertions} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-1.2 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 1.3 XXX .t get 1.0 1000000.0 -} "LinXXXe 1\nLine 2\nLine 3\n" -test btree-1.3 {basic insertions} { +} -result "LinXXXe 1\nLine 2\nLine 3\n" +test btree-1.3 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 3.0 YYY .t get 1.0 1000000.0 -} "Line 1\nLine 2\nYYYLine 3\n" -test btree-1.4 {basic insertions} { +} -result "Line 1\nLine 2\nYYYLine 3\n" +test btree-1.4 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.1 X\nYY .t get 1.0 1000000.0 -} "Line 1\nLX\nYYine 2\nLine 3\n" -test btree-1.5 {basic insertions} { +} -result "Line 1\nLX\nYYine 2\nLine 3\n" +test btree-1.5 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.0 X\n\n\n .t get 1.0 1000000.0 -} "Line 1\nX\n\n\nLine 2\nLine 3\n" -test btree-1.6 {basic insertions} { +} -result "Line 1\nX\n\n\nLine 2\nLine 3\n" +test btree-1.6 {basic insertions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.6 X\n .t get 1.0 1000000.0 -} "Line 1\nLine 2X\n\nLine 3\n" -test btree-1.7 {insertion before start of text} { +} -result "Line 1\nLine 2X\n\nLine 3\n" +test btree-1.7 {insertion before start of text} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 0.4 XXX .t get 1.0 1000000.0 -} "XXXLine 1\nLine 2\nLine 3\n" -test btree-1.8 {insertion past end of text} { +} -result "XXXLine 1\nLine 2\nLine 3\n" +test btree-1.8 {insertion past end of text} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 100.0 ZZ .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3ZZ\n" -test btree-1.9 {insertion before start of line} { +} -result "Line 1\nLine 2\nLine 3ZZ\n" +test btree-1.9 {insertion before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.-3 Q .t get 1.0 1000000.0 -} "Line 1\nQLine 2\nLine 3\n" -test btree-1.10 {insertion past end of line} { +} -result "Line 1\nQLine 2\nLine 3\n" +test btree-1.10 {insertion past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 2.40 XYZZY .t get 1.0 1000000.0 -} "Line 1\nLine 2XYZZY\nLine 3\n" -test btree-1.11 {insertion past end of last line} { +} -result "Line 1\nLine 2XYZZY\nLine 3\n" +test btree-1.11 {insertion past end of last line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t insert 3.40 ABC .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3ABC\n" +} -result "Line 1\nLine 2\nLine 3ABC\n" + -test btree-2.1 {basic deletions} { +test btree-2.1 {basic deletions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.0 1.3 .t get 1.0 1000000.0 -} "e 1\nLine 2\nLine 3\n" -test btree-2.2 {basic deletions} { +} -result "e 1\nLine 2\nLine 3\n" +test btree-2.2 {basic deletions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 2.2 .t get 1.0 1000000.0 -} "Line 1\nLie 2\nLine 3\n" -test btree-2.3 {basic deletions} { +} -result "Line 1\nLie 2\nLine 3\n" +test btree-2.3 {basic deletions} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 2.0 2.3 .t get 1.0 1000000.0 -} "Line 1\ne 2\nLine 3\n" -test btree-2.4 {deleting whole lines} { +} -result "Line 1\ne 2\nLine 3\n" +test btree-2.4 {deleting whole lines} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.2 3.0 .t get 1.0 1000000.0 -} "LiLine 3\n" -test btree-2.5 {deleting whole lines} { +} -result "LiLine 3\n" +test btree-2.5 {deleting whole lines} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\n\n\nLine 5" .t delete 1.0 5.2 .t get 1.0 1000000.0 -} "ne 5\n" -test btree-2.6 {deleting before start of file} { +} -result "ne 5\n" +test btree-2.6 {deleting before start of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 0.3 1.2 .t get 1.0 1000000.0 -} "ne 1\nLine 2\nLine 3\n" -test btree-2.7 {deleting after end of file} { +} -result "ne 1\nLine 2\nLine 3\n" +test btree-2.7 {deleting after end of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 10.3 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.8 {deleting before start of line} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-2.8 {deleting before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.-1 3.3 .t get 1.0 1000000.0 -} "Line 1\nLine 2\ne 3\n" -test btree-2.9 {deleting before start of line} { +} -result "Line 1\nLine 2\ne 3\n" +test btree-2.9 {deleting before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.-1 1.0 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.10 {deleting after end of line} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-2.10 {deleting after end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.8 2.1 .t get 1.0 1000000.0 -} "Line 1ine 2\nLine 3\n" -test btree-2.11 {deleting after end of last line} { +} -result "Line 1ine 2\nLine 3\n" +test btree-2.11 {deleting after end of last line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.8 4.1 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.12 {deleting before start of file} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-2.12 {deleting before start of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.8 0.0 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.13 {deleting past end of file} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-2.13 {deleting past end of file} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.8 4.0 .t get 1.0 1000000.0 -} "Line 1\n" -test btree-2.14 {deleting with end before start of line} { +} -result "Line 1\n" +test btree-2.14 {deleting with end before start of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.3 2.-3 .t get 1.0 1000000.0 -} "LinLine 2\nLine 3\n" -test btree-2.15 {deleting past end of line} { +} -result "LinLine 2\nLine 3\n" +test btree-2.15 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.3 1.9 .t get 1.0 1000000.0 -} "Lin\nLine 2\nLine 3\n" -test btree-2.16 {deleting past end of line} { +} -result "Lin\nLine 2\nLine 3\n" +test btree-2.16 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 3.15 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLi\n" -test btree-2.17 {deleting past end of line} { +} -result "Line 1\nLine 2\nLi\n" +test btree-2.17 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.0 3.15 .t get 1.0 1000000.0 -} "Line 1\nLine 2\n\n" -test btree-2.18 {deleting past end of line} { +} -result "Line 1\nLine 2\n\n" +test btree-2.18 {deleting past end of line} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 1.0 3.15 .t get 1.0 1000000.0 -} "\n" -test btree-2.19 {deleting with negative range} { +} -result "\n" +test btree-2.19 {deleting with negative range} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 2.4 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.20 {deleting with negative range} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-2.20 {deleting with negative range} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 3.1 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" -test btree-2.21 {deleting with negative range} { +} -result "Line 1\nLine 2\nLine 3\n" +test btree-2.21 {deleting with negative range} -body { .t delete 1.0 100000.0 .t insert 1.0 "Line 1\nLine 2\nLine 3" .t delete 3.2 3.2 .t get 1.0 1000000.0 -} "Line 1\nLine 2\nLine 3\n" +} -result "Line 1\nLine 2\nLine 3\n" -proc setup {} { - .t delete 1.0 100000.0 - .t tag delete x y - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t tag add x 1.1 - .t tag add x 1.5 1.13 - .t tag add x 2.2 2.6 - .t tag add y 1.5 -} -test btree-3.1 {inserting with tags} { +test btree-3.1 {inserting with tags} -body { setup .t insert 1.0 XXX list [.t tag ranges x] [.t tag ranges y] -} {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}} -test btree-3.2 {inserting with tags} { +} -result {{1.4 1.5 1.8 1.16 2.2 2.6} {1.8 1.9}} +test btree-3.2 {inserting with tags} -body { setup .t insert 1.15 YYY list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}} -test btree-3.3 {inserting with tags} { +} -result {{1.1 1.2 1.5 1.13 2.2 2.6} {1.5 1.6}} +test btree-3.3 {inserting with tags} -body { setup .t insert 1.7 ZZZZ list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}} -test btree-3.4 {inserting with tags} { +} -result {{1.1 1.2 1.5 1.17 2.2 2.6} {1.5 1.6}} +test btree-3.4 {inserting with tags} -body { setup .t insert 1.7 \n\n list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}} -test btree-3.5 {inserting with tags} { +} -result {{1.1 1.2 1.5 3.6 4.2 4.6} {1.5 1.6}} +test btree-3.5 {inserting with tags} -body { setup .t insert 1.5 A\n list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}} -test btree-3.6 {inserting with tags} { +} -result {{1.1 1.2 2.0 2.8 3.2 3.6} {2.0 2.1}} +test btree-3.6 {inserting with tags} -body { setup .t insert 1.13 A\n list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}} +} -result {{1.1 1.2 1.5 1.13 3.2 3.6} {1.5 1.6}} + -test btree-4.1 {deleting with tags} { +test btree-4.1 {deleting with tags} -body { setup .t delete 1.6 1.9 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} -test btree-4.2 {deleting with tags} { +} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} +test btree-4.2 {deleting with tags} -body { setup .t delete 1.1 2.3 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.4} {}} -test btree-4.3 {deleting with tags} { +} -result {{1.1 1.4} {}} +test btree-4.3 {deleting with tags} -body { setup .t delete 1.4 2.1 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.9} {}} -test btree-4.4 {deleting with tags} { +} -result {{1.1 1.2 1.5 1.9} {}} +test btree-4.4 {deleting with tags} -body { setup .t delete 1.14 2.1 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}} -test btree-4.5 {deleting with tags} { +} -result {{1.1 1.2 1.5 1.13 1.15 1.19} {1.5 1.6}} +test btree-4.5 {deleting with tags} -body { setup .t delete 1.0 2.10 list [.t tag ranges x] [.t tag ranges y] -} {{} {}} -test btree-4.6 {deleting with tags} { +} -result {{} {}} +test btree-4.6 {deleting with tags} -body { setup .t delete 1.0 1.5 list [.t tag ranges x] [.t tag ranges y] -} {{1.0 1.8 2.2 2.6} {1.0 1.1}} -test btree-4.7 {deleting with tags} { +} -result {{1.0 1.8 2.2 2.6} {1.0 1.1}} +test btree-4.7 {deleting with tags} -body { setup .t delete 1.6 1.9 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} -test btree-4.8 {deleting with tags} { +} -result {{1.1 1.2 1.5 1.10 2.2 2.6} {1.5 1.6}} +test btree-4.8 {deleting with tags} -body { setup .t delete 1.5 1.13 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 2.2 2.6} {}} +} -result {{1.1 1.2 2.2 2.6} {}} -set bigText1 {} -for {set i 0} {$i < 10} {incr i} { - append bigText1 "Line $i\n" -} -set bigText2 {} -for {set i 0} {$i < 200} {incr i} { - append bigText2 "Line $i\n" -} -test btree-5.1 {very large inserts, with tags} { + +test btree-5.1 {very large inserts, with tags} -setup { + set bigText1 {} + for {set i 0} {$i < 10} {incr i} { + append bigText1 "Line $i\n" + } +} -body { setup .t insert 1.0 $bigText1 list [.t tag ranges x] [.t tag ranges y] -} {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}} -test btree-5.2 {very large inserts, with tags} { +} -result {{11.1 11.2 11.5 11.13 12.2 12.6} {11.5 11.6}} +test btree-5.2 {very large inserts, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.2 $bigText2 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}} -test btree-5.3 {very large inserts, with tags} { +} -result {{1.1 1.2 201.3 201.11 202.2 202.6} {201.3 201.4}} +test btree-5.3 {very large inserts, with tags} -body { setup for {set i 0} {$i < 200} {incr i} { - .t insert 1.8 "longer line $i\n" + .t insert 1.8 "longer line $i\n" } - list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] [.t get 198.0 198.100] -} {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}} + list [.t tag ranges x] [.t tag ranges y] [.t get 1.0 1.100] \ + [.t get 198.0 198.100] +} -result {{1.1 1.2 1.5 201.5 202.2 202.6} {1.5 1.6} {Text forlonger line 199} {longer line 2}} -test btree-6.1 {very large deletes, with tags} { + +test btree-6.1 {very large deletes, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.1 $bigText2 .t delete 1.2 201.2 list [.t tag ranges x] [.t tag ranges y] -} {{1.4 1.12 2.2 2.6} {1.4 1.5}} -test btree-6.2 {very large deletes, with tags} { +} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}} +test btree-6.2 {very large deletes, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 200} {incr i} { - .t delete 1.2 2.2 + .t delete 1.2 2.2 } list [.t tag ranges x] [.t tag ranges y] -} {{1.4 1.12 2.2 2.6} {1.4 1.5}} -test btree-6.3 {very large deletes, with tags} { +} -result {{1.4 1.12 2.2 2.6} {1.4 1.5}} +test btree-6.3 {very large deletes, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.1 $bigText2 .t delete 2.3 10000.0 .t get 1.0 1000.0 -} {TLine 0 +} -result {TLine 0 Lin } -test btree-6.4 {very large deletes, with tags} { +test btree-6.4 {very large deletes, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - .t delete 30.0 31.0 + .t delete 30.0 31.0 } list [.t tag ranges x] [.t tag ranges y] -} {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}} -test btree-6.5 {very large deletes, with tags} { +} -result {{101.0 101.1 101.4 101.12 102.2 102.6} {101.4 101.5}} +test btree-6.5 {very large deletes, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] - .t tag add x $j.1 $j.3 - .t tag add y $k.1 $k.6 + set j [expr $i+2] + set k [expr 1+2*$i] + .t tag add x $j.1 $j.3 + .t tag add y $k.1 $k.6 } .t delete 2.0 200.0 list [.t tag ranges x] [.t tag ranges y] -} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} -test btree-6.6 {very large deletes, with tags} { +} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} +test btree-6.6 {very large deletes, with tags} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.1 $bigText2 for {set i 0} {$i < 100} {incr i} { - set j [expr $i+2] - set k [expr 1+2*$i] - .t tag add x $j.1 $j.3 - .t tag add y $k.1 $k.6 + set j [expr $i+2] + set k [expr 1+2*$i] + .t tag add x $j.1 $j.3 + .t tag add y $k.1 $k.6 } for {set i 199} {$i >= 2} {incr i -1} { - .t delete $i.0 [expr $i+1].0 + .t delete $i.0 [expr $i+1].0 } list [.t tag ranges x] [.t tag ranges y] -} {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} - -.t delete 1.0 end -.t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" -set i 1 -foreach check { - {1.3 1.6 1.7 2.0 {1.3 1.6 1.7 2.0}} - {1.3 1.6 1.6 2.0 {1.3 2.0}} - {1.3 1.6 1.4 2.0 {1.3 2.0}} - {2.0 4.3 1.4 1.10 {1.4 1.10 2.0 4.3}} - {2.0 4.3 1.4 1.end {1.4 1.19 2.0 4.3}} - {2.0 4.3 1.4 2.0 {1.4 4.3}} - {2.0 4.3 1.4 3.0 {1.4 4.3}} - {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2 {1.1 4.2}} - {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2 {1.2 4.2}} - {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0 {1.1 4.0}} - {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0 {1.2 4.0}} -} { - test btree-7.$i {tag addition and removal} { - .t tag remove x 1.0 end - while {[llength $check] > 2} { - .t tag add x [lindex $check 0] [lindex $check 1] - set check [lrange $check 2 end] - } - .t tag ranges x - } [lindex $check [expr [llength $check]-1]] - incr i -} +} -result {{3.0 3.1 3.4 3.12 4.2 4.6} {1.1 1.6 3.4 3.5}} + + +test btree-7.1 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.3 1.6 1.7 2.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.3 1.6 1.7 2.0} +test btree-7.2 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.3 1.6 1.6 2.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.3 2.0} +test btree-7.3 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.3 1.6 1.4 2.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.3 2.0} +test btree-7.4 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {2.0 4.3 1.4 1.10} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.4 1.10 2.0 4.3} +test btree-7.5 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {2.0 4.3 1.4 1.end} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.4 1.19 2.0 4.3} +test btree-7.6 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {2.0 4.3 1.4 2.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.4 4.3} +test btree-7.7 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {2.0 4.3 1.4 3.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.4 4.3} +test btree-7.8 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 4.2} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.1 4.2} +test btree-7.9 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.3 4.2} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.2 4.2} +test btree-7.10 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.1 3.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.1 4.0} +test btree-7.11 {tag addition and removal} -setup { + .t delete 1.0 end + .t tag remove x 1.0 end +} -body { + .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" + set check {1.2 1.3 1.6 1.7 1.end 2.0 2.4 2.7 3.0 4.0 1.2 3.0} + while {[llength $check]} { + .t tag add x [lindex $check 0] [lindex $check 1] + set check [lrange $check 2 end] + } + .t tag ranges x +} -result {1.2 4.0} -test btree-8.1 {tag addition and removal, weird ranges} { + +test btree-8.1 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 0.0 1.3 .t tag ranges x -} {1.0 1.3} -test btree-8.2 {tag addition and removal, weird ranges} { +} -result {1.0 1.3} +test btree-8.2 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.40 2.4 .t tag ranges x -} {1.19 2.4} -test btree-8.3 {tag addition and removal, weird ranges} { +} -result {1.19 2.4} +test btree-8.3 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 4.40 4.41 .t tag ranges x -} {} -test btree-8.4 {tag addition and removal, weird ranges} { +} -result {} +test btree-8.4 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 5.1 5.2 .t tag ranges x -} {} -test btree-8.5 {tag addition and removal, weird ranges} { +} -result {} +test btree-8.5 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 9.0 .t tag ranges x -} {1.1 5.0} -test btree-8.6 {tag addition and removal, weird ranges} { +} -result {1.1 5.0} +test btree-8.6 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 1.90 .t tag ranges x -} {1.1 1.19} -test btree-8.7 {tag addition and removal, weird ranges} { +} -result {1.1 1.19} +test btree-8.7 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 1.1 4.90 .t tag ranges x -} {1.1 4.17} -test btree-8.8 {tag addition and removal, weird ranges} { +} -result {1.1 4.17} +test btree-8.8 {tag addition and removal, weird ranges} -body { .t delete 1.0 100000.0 .t tag delete x .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 3.0 3.0 .t tag ranges x -} {} +} -result {} + -test btree-9.1 {tag names} { +test btree-9.1 {tag names} -body { setup .t tag names -} {sel x y} -test btree-9.2 {tag names} { +} -result {sel x y} +test btree-9.2 {tag names} -body { setup .t tag add tag1 1.8 .t tag add tag2 1.8 .t tag add tag3 1.7 1.9 .t tag names 1.8 -} {x tag1 tag2 tag3} -test btree-9.3 {lots of tag names} { +} -result {x tag1 tag2 tag3} +test btree-9.3 {lots of tag names} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.2 $bigText2 foreach i {tag1 foo ThisOne {x space} q r s t} { - .t tag add $i 150.2 + .t tag add $i 150.2 } foreach i {u tagA tagB tagC and more {$} \{} { - .t tag add $i 150.1 150.3 + .t tag add $i 150.1 150.3 } .t tag names 150.2 -} {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{} -test btree-9.4 {lots of tag names} { +} -result {tag1 foo ThisOne {x space} q r s t u tagA tagB tagC and more {$} \{} +test btree-9.4 {lots of tag names} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.2 $bigText2 .t tag delete tag1 foo ThisOne more {x space} q r s t u .t tag delete tagA tagB tagC and {$} \{ more foreach i {tag1 foo ThisOne more {x space} q r s t} { - .t tag add $i 150.2 + .t tag add $i 150.2 } foreach i {foo ThisOne u tagA tagB tagC and more {$} \{} { - .t tag add $i 150.4 + .t tag add $i 150.4 } .t tag delete tag1 more q r tagA .t tag names 150.2 -} {foo ThisOne {x space} s t} +} -result {foo ThisOne {x space} s t} -proc msetup {} { - .t delete 1.0 100000.0 - .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" - .t mark set m1 1.2 - .t mark set l1 1.2 - .t mark gravity l1 left - .t mark set next 1.6 - .t mark set x 1.6 - .t mark set m2 2.0 - .t mark set m3 2.100 - .t tag add x 1.3 1.8 -} -test btree-10.1 {basic mark facilities} { + +test btree-10.1 {basic mark facilities} -body { msetup list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] -} {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11} -test btree-10.2 {basic mark facilities} { +} -result {{current insert l1 m1 m2 m3 next x} 1.2 2.0 2.11} +test btree-10.2 {basic mark facilities} -body { msetup .t mark unset m2 lsort [.t mark names] -} {current insert l1 m1 m3 next x} -test btree-10.3 {basic mark facilities} { +} -result {current insert l1 m1 m3 next x} +test btree-10.3 {basic mark facilities} -body { msetup .t mark set m2 1.8 list [lsort [.t mark names]] [.t index m1] [.t index m2] [.t index m3] -} {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11} +} -result {{current insert l1 m1 m2 m3 next x} 1.2 1.8 2.11} -test btree-11.1 {marks and inserts} { + +test btree-11.1 {marks and inserts} -body { msetup .t insert 1.1 abcde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.7 1.7 1.11 1.11 2.0 2.11} -test btree-11.2 {marks and inserts} { +} -result {1.7 1.7 1.11 1.11 2.0 2.11} +test btree-11.2 {marks and inserts} -body { msetup .t insert 1.2 abcde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.7 1.11 1.11 2.0 2.11} -test btree-11.3 {marks and inserts} { +} -result {1.2 1.7 1.11 1.11 2.0 2.11} +test btree-11.3 {marks and inserts} -body { msetup .t insert 1.3 abcde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.11 1.11 2.0 2.11} -test btree-11.4 {marks and inserts} { +} -result {1.2 1.2 1.11 1.11 2.0 2.11} +test btree-11.4 {marks and inserts} -body { msetup .t insert 1.1 ab\n\ncde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {3.4 3.4 3.8 3.8 4.0 4.11} -test btree-11.5 {marks and inserts} { +} -result {3.4 3.4 3.8 3.8 4.0 4.11} +test btree-11.5 {marks and inserts} -body { msetup .t insert 1.4 ab\n\ncde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 3.5 3.5 4.0 4.11} -test btree-11.6 {marks and inserts} { +} -result {1.2 1.2 3.5 3.5 4.0 4.11} +test btree-11.6 {marks and inserts} -body { msetup .t insert 1.7 ab\n\ncde list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.6 1.6 4.0 4.11} +} -result {1.2 1.2 1.6 1.6 4.0 4.11} + -test btree-12.1 {marks and deletes} { +test btree-12.1 {marks and deletes} -body { msetup .t delete 1.3 1.5 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.4 1.4 2.0 2.11} -test btree-12.2 {marks and deletes} { +} -result {1.2 1.2 1.4 1.4 2.0 2.11} +test btree-12.2 {marks and deletes} -body { msetup .t delete 1.3 1.8 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.3 1.3 2.0 2.11} -test btree-12.3 {marks and deletes} { +} -result {1.2 1.2 1.3 1.3 2.0 2.11} +test btree-12.3 {marks and deletes} -body { msetup .t delete 1.2 1.8 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.2 1.2 2.0 2.11} -test btree-12.4 {marks and deletes} { +} -result {1.2 1.2 1.2 1.2 2.0 2.11} +test btree-12.4 {marks and deletes} -body { msetup .t delete 1.1 1.8 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.1 1.1 1.1 1.1 2.0 2.11} -test btree-12.5 {marks and deletes} { +} -result {1.1 1.1 1.1 1.1 2.0 2.11} +test btree-12.5 {marks and deletes} -body { msetup .t delete 1.5 3.1 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.5 1.5 1.5 1.5} -test btree-12.6 {marks and deletes} { +} -result {1.2 1.2 1.5 1.5 1.5 1.5} +test btree-12.6 {marks and deletes} -body { msetup .t mark set m2 4.5 .t delete 1.5 4.1 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.2 1.5 1.5 1.9 1.5} -test btree-12.7 {marks and deletes} { +} -result {1.2 1.2 1.5 1.5 1.9 1.5} +test btree-12.7 {marks and deletes} -body { msetup .t mark set m2 4.5 .t mark set m3 4.5 .t mark set m1 4.7 .t delete 1.5 4.1 list [.t index l1] [.t index m1] [.t index next] [.t index x] [.t index m2] [.t index m3] -} {1.2 1.11 1.5 1.5 1.9 1.9} +} -result {1.2 1.11 1.5 1.5 1.9 1.9} -destroy .t -text .t -test btree-13.1 {tag searching} { + +test btree-13.1 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag next x 2.2 2.1 -} {} -test btree-13.2 {tag searching} { +} -result {} +test btree-13.2 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.2 2.4 .t tag next x 2.2 2.3 -} {2.2 2.4} -test btree-13.3 {tag searching} { +} -result {2.2 2.4} +test btree-13.3 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.2 2.4 .t tag next x 2.3 2.6 -} {} -test btree-13.4 {tag searching} { +} -result {} +test btree-13.4 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.5 2.8 .t tag next x 2.1 2.6 -} {2.5 2.8} -test btree-13.5 {tag searching} { +} -result {2.5 2.8} +test btree-13.5 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.5 2.8 .t tag next x 2.1 2.5 -} {} -test btree-13.6 {tag searching} { +} -result {} +test btree-13.6 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.1 2.4 .t tag next x 2.5 2.8 -} {} -test btree-13.7 {tag searching} { +} -result {} +test btree-13.7 {tag searching} -setup { .t delete 1.0 100000.0 +} -body { .t insert 1.0 "Text for first line\nSecond line\n\nLast line of info" .t tag add x 2.5 2.8 .t tag next x 2.1 2.4 -} {} -test btree-13.8 {tag searching} { +} -result {} +test btree-13.8 {tag searching} -setup { + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.2 $bigText2 .t tag add x 190.3 191.2 .t tag next x 3.5 -} {190.3 191.2} +} -result {190.3 191.2} +destroy .t + -test btree-14.1 {check tag presence} { +test btree-14.1 {check tag presence} -setup { + destroy .t + text .t + set bigText2 {} + for {set i 0} {$i < 200} {incr i} { + append bigText2 "Line $i\n" + } +} -body { setup .t insert 1.2 $bigText2 .t tag add x 3.5 3.7 @@ -656,242 +862,371 @@ test btree-14.1 {check tag presence} { .t tag add b 7.5 .t tag add b 140.3 for {set i 120} {$i < 160} {incr i} { - .t tag add c $i.4 + .t tag add c $i.4 } foreach i {a1 a2 a3 a4 a5 a6 a7 a8 a9 10 a11 a12 a13} { - .t tag add $i 122.2 + .t tag add $i 122.2 } .t tag add x 141.3 .t tag names 141.1 -} {x y z} +} -cleanup { + destroy .t +} -result {x y z} + -test btree-15.1 {rebalance with empty node} { - catch {destroy .t} +test btree-15.1 {rebalance with empty node} -setup { + destroy .t +} -body { text .t .t debug 1 .t insert end "1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23" .t delete 6.0 12.0 .t get 1.0 end -} "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n" +} -cleanup { + destroy .t +} -result "1\n2\n3\n4\n5\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22\n23\n" -proc setupBig {} { - .t delete 1.0 end - .t tag delete x y - .t tag configure x -foreground blue - .t tag configure y -underline true - # Create a Btree with 2002 lines (2000 + already existing + phantom at end) - # This generates a level 3 node with 9 children - # Most level 2 nodes cover 216 lines and have 6 children, except the last - # level 2 node covers 274 lines and has 7 children. - # Most level 1 nodes cover 36 lines and have 6 children, except the - # rightmost node has 58 lines and 9 children. - # Level 2: 2002 = 8*216 + 274 - # Level 1: 2002 = 54*36 + 58 - # Level 0: 2002 = 332*6 + 10 - for {set i 0} {$i < 2000} {incr i} { - append x "Line $i abcd efgh ijkl\n" - } - .t insert insert $x - .t debug 1 -} -test btree-16.1 {add tag does not push root above level 0} { - catch {destroy .t} +test btree-16.1 {add tag does not push root above level 0} -setup { + destroy .t text .t +} -body { setupBig + .t debug 0 .t tag add x 1.1 1.10 .t tag add x 5.1 5.10 .t tag ranges x -} {1.1 1.10 5.1 5.10} -test btree-16.2 {add tag pushes root up to level 1 node} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {1.1 1.10 5.1 5.10} +test btree-16.2 {add tag pushes root up to level 1 node} -setup { + destroy .t text .t - .t debug 1 +} -body { setupBig .t tag add x 1.1 1.10 .t tag add x 8.1 8.10 .t tag ranges x -} {1.1 1.10 8.1 8.10} -test btree-16.3 {add tag pushes root up to level 2 node} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.1 1.10 8.1 8.10} +test btree-16.3 {add tag pushes root up to level 2 node} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 8.1 9.10 .t tag add x 180.1 180.end .t tag ranges x -} {8.1 9.10 180.1 180.23} -test btree-16.4 {add tag pushes root up to level 3 node} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {8.1 9.10 180.1 180.23} +test btree-16.4 {add tag pushes root up to level 3 node} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add y 1.1 2000.0 .t tag add x 1.1 8.10 .t tag add x 180.end 217.0 list [.t tag ranges x] [.t tag ranges y] -} {{1.1 8.10 180.23 217.0} {1.1 2000.0}} -test btree-16.5 {add tag doesn't push root up} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {{1.1 8.10 180.23 217.0} {1.1 2000.0}} +test btree-16.5 {add tag doesn't push root up} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.1 8.10 .t tag add x 2000.0 2000.3 .t tag add x 180.end 217.0 .t tag ranges x -} {1.1 8.10 180.23 217.0 2000.0 2000.3} -test btree-16.6 {two node splits at once pushes root up} { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {1.1 8.10 180.23 217.0 2000.0 2000.3} +test btree-16.6 {two node splits at once pushes root up} -setup { + destroy .t + text .t +} -body { for {set i 1} {$i < 10} {incr i} { - .t insert end "Line $i\n" + .t insert end "Line $i\n" } .t tag add x 8.0 8.end .t tag add y 9.0 end set x {} for {} {$i < 50} {incr i} { - append x "Line $i\n" + append x "Line $i\n" } .t insert end $x y list [.t tag ranges x] [.t tag ranges y] -} {{8.0 8.6} {9.0 51.0}} +} -cleanup { + destroy .t +} -result {{8.0 8.6} {9.0 51.0}} # The following find bugs in the SearchStart procedures -test btree-16.7 {Partial tag remove from before first range} { - .t tag remove x 1.0 end +test btree-16.7 {Partial tag remove from before first range} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 2.0 2.6 .t tag remove x 1.0 2.0 .t tag ranges x -} {2.0 2.6} -test btree-16.8 {Partial tag remove from before first range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {2.0 2.6} +test btree-16.8 {Partial tag remove from before first range} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 2.0 2.6 .t tag remove x 1.0 2.1 .t tag ranges x -} {2.1 2.6} -test btree-16.9 {Partial tag remove from before first range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {2.1 2.6} +test btree-16.9 {Partial tag remove from before first range} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 2.0 2.6 .t tag remove x 1.0 2.3 .t tag ranges x -} {2.3 2.6} -test btree-16.10 {Partial tag remove from before first range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {2.3 2.6} +test btree-16.10 {Partial tag remove from before first range} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 1.0 2.6 .t tag remove x 1.0 2.5 .t tag ranges x -} {2.5 2.6} -test btree-16.11 {StartSearchBack boundary case} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {2.5 2.6} +test btree-16.11 {StartSearchBack boundary case} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 1.3 1.4 .t tag prevr x 2.0 1.4 -} {} -test btree-16.12 {StartSearchBack boundary case} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {} +test btree-16.12 {StartSearchBack boundary case} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 1.3 1.4 .t tag prevr x 2.0 1.3 -} {1.3 1.4} -test btree-16.13 {StartSearchBack boundary case} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.3 1.4} +test btree-16.13 {StartSearchBack boundary case} -setup { + destroy .t + text .t + for {set i 1} {$i < 10} {incr i} { + .t insert end "Line $i\n" + } +} -body { .t tag add x 1.0 1.4 .t tag prevr x 1.3 -} {1.0 1.4} +} -cleanup { + destroy .t +} -result {1.0 1.4} -test btree-17.1 {remove tag does not push root down} { - catch {destroy .t} +test btree-17.1 {remove tag does not push root down} -setup { + destroy .t text .t +} -body { .t debug 0 setupBig .t tag add x 1.1 5.10 .t tag remove x 3.1 5.end .t tag ranges x -} {1.1 3.1} -test btree-17.2 {remove tag pushes root from level 1 to level 0} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.1 3.1} +test btree-17.2 {remove tag pushes root from level 1 to level 0} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.1 8.10 .t tag remove x 3.1 end .t tag ranges x -} {1.1 3.1} -test btree-17.3 {remove tag pushes root from level 2 to level 1} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.1 3.1} +test btree-17.3 {remove tag pushes root from level 2 to level 1} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.1 180.10 .t tag remove x 35.1 end .t tag ranges x -} {1.1 35.1} -test btree-17.4 {remove tag doesn't change level 2} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.1 35.1} +test btree-17.4 {remove tag doesn't change level 2} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.1 180.10 .t tag remove x 35.1 180.0 .t tag ranges x -} {1.1 35.1 180.0 180.10} -test btree-17.5 {remove tag pushes root from level 3 to level 0} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.1 35.1 180.0 180.10} +test btree-17.5 {remove tag pushes root from level 3 to level 0} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.1 1.10 .t tag add x 2000.1 2000.10 .t tag remove x 1.0 2000.0 .t tag ranges x -} {2000.1 2000.10} -test btree-17.6 {text deletion pushes root from level 3 to level 0} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {2000.1 2000.10} +test btree-17.6 {text deletion pushes root from level 3 to level 0} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.1 1.10 .t tag add x 2000.1 2000.10 .t delete 1.0 "1000.0 lineend +1 char" .t tag ranges x -} {1000.1 1000.10} +} -cleanup { + destroy .t +} -result {1000.1 1000.10} -catch {destroy .t} -text .t -test btree-18.1 {tag search back, no tag} { + +test btree-18.1 {tag search back, no tag} -setup { + destroy .t + text .t +} -body { .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag prev x 1.1 1.1 -} {} -test btree-18.2 {tag search back, start at existing range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {} +test btree-18.2 {tag search back, start at existing range} -setup { + destroy .t + text .t +} -body { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 1.1 -} {} -test btree-18.3 {tag search back, end at existing range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {} +test btree-18.3 {tag search back, end at existing range} -setup { + destroy .t + text .t +} -body { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 1.3 1.1 -} {1.1 1.4} -test btree-18.4 {tag search back, start within range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.1 1.4} +test btree-18.4 {tag search back, start within range} -setup { + destroy .t + text .t +} -body { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 1.10 1.0 -} {1.8 1.11} -test btree-18.5 {tag search back, start at end of range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.8 1.11} +test btree-18.5 {tag search back, start at end of range} -setup { + destroy .t + text .t +} -body { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 list [.t tag prev x 1.4 1.0] [.t tag prev x 1.11 1.0] -} {{1.1 1.4} {1.8 1.11}} -test btree-18.6 {tag search back, start beyond range, same level 0 node} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {{1.1 1.4} {1.8 1.11}} +test btree-18.6 {tag search back, start beyond range, same level 0 node} -setup { + destroy .t + text .t +} -body { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.8 1.11 .t tag add x 1.16 .t tag prev x 3.0 -} {1.16 1.17} -test btree-18.7 {tag search back, outside any range} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {1.16 1.17} +test btree-18.7 {tag search back, outside any range} -setup { + destroy .t + text .t +} -body { + .t insert 1.0 "Line 1 abcd efgh ijkl\n" .t tag add x 1.1 1.4 .t tag add x 1.16 .t tag prev x 1.8 1.5 -} {} -test btree-18.8 {tag search back, start at start of node boundary} { +} -cleanup { + destroy .t +} -result {} +test btree-18.8 {tag search back, start at start of node boundary} -setup { + destroy .t + text .t +} -body { setupBig - .t tag remove x 1.0 end .t tag add x 2.5 2.8 .t tag prev x 19.0 -} {2.5 2.8} -test btree-18.9 {tag search back, large complex btree spans} { - .t tag remove x 1.0 end +} -cleanup { + destroy .t +} -result {2.5 2.8} +test btree-18.9 {tag search back, large complex btree spans} -setup { + destroy .t + text .t +} -body { + setupBig .t tag add x 1.3 1.end .t tag add x 200.0 220.0 .t tag add x 500.0 520.0 list [.t tag prev x end] [.t tag prev x 433.0] -} {{500.0 520.0} {200.0 220.0}} - -destroy .t +} -cleanup { + destroy .t +} -result {{500.0 520.0} {200.0 220.0}} # cleanup cleanupTests diff --git a/tests/textImage.test b/tests/textImage.test index bb5909c..24246cc 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -7,349 +7,445 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands +imageInit # One time setup. Create a font to insure the tests are font metric invariant. - -catch {destroy .t} +destroy .t font create test_font -family courier -size 14 text .t -font test_font destroy .t -test textImage-1.1 {basic argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image} msg] $msg -} {1 {wrong # args: should be ".t image option ?arg arg ...?"}} - -test textImage-1.2 {basic argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image c} msg] $msg -} {1 {ambiguous option "c": must be cget, configure, create, or names}} - -test textImage-1.3 {cget argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image cget} msg] $msg -} {1 {wrong # args: should be ".t image cget index option"}} - -test textImage-1.4 {cget argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image cget blurf -flurp} msg] $msg -} {1 {bad text index "blurf"}} - -test textImage-1.5 {cget argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image cget 1.1 -flurp} msg] $msg -} {1 {no embedded image at index "1.1"}} - -test textImage-1.6 {configure argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image configure } msg] $msg -} {1 {wrong # args: should be ".t image configure index ?option value ...?"}} - -test textImage-1.7 {configure argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image configure blurf } msg] $msg -} {1 {bad text index "blurf"}} - -test textImage-1.8 {configure argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image configure 1.1 } msg] $msg -} {1 {no embedded image at index "1.1"}} - -test textImage-1.9 {create argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image create} msg] $msg -} {1 {wrong # args: should be ".t image create index ?option value ...?"}} - -test textImage-1.10 {create argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image create blurf } msg] $msg -} {1 {bad text index "blurf"}} - -test textImage-1.11 {basic argument checking} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image create 1000.1000 -image small} msg] $msg -} {0 small} - -test textImage-1.12 {names argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image names dates places} msg] $msg -} {1 {wrong # args: should be ".t image names"}} - - -test textImage-1.13 {names argument checking} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - set result "" - lappend result [.t image names] - .t image create insert -image small - lappend result [.t image names] - .t image create insert -image small - lappend result [.t image names] - .t image create insert -image small -name little - lappend result [.t image names] -} {{} small {small#1 small} {small#1 small little}} - -test textImage-1.14 {basic argument checking} { - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image huh} msg] $msg -} {1 {bad option "huh": must be cget, configure, create, or names}} - -test textImage-1.15 {align argument checking} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - list [catch {.t image create end -image small -align wrong} msg] $msg -} {1 {bad align "wrong": must be baseline, bottom, center, or top}} - -test textImage-1.16 {configure} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t image create end -image small - .t image configure small -} {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}} - -test textImage-1.17 {basic cget options} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t image create end -image small - set result "" - foreach i {align padx pady image name} { - lappend result $i:[.t image cget small -$i] - } - set result -} {align:center padx:0 pady:0 image:small name:} - -test textImage-1.18 {basic configure options} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - image create photo large -width 50 -height 50 - large put green -to 0 0 50 50 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t image create end -image small - set result "" - foreach {option value} {align top padx 5 pady 7 image large name none} { - .t image configure small -$option $value - } - update - .t image configure small -} {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}} - -test textImage-1.19 {basic image naming} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t image create end -image small - .t image create end -image small -name small - .t image create end -image small -name small#6342 - .t image create end -image small -name small - lsort [.t image names] -} {small small#1 small#6342 small#6343} - -test textImage-2.1 {debug} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t debug 1 - .t insert end front - .t image create end -image small - .t insert end back - .t delete small - .t image names - .t debug 0 -} {} - -test textImage-3.1 {image change propagation} { - catch { - image create photo vary -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t image create end -image vary -align top - update - set result "" - lappend result base:[.t bbox vary] - foreach i {10 20 40} { - vary configure -width $i -height $i - update - lappend result $i:[.t bbox vary] - } - set result -} {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}} - -test textImage-3.2 {delayed image management} { - catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - } - catch {destroy .t} - text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 - pack .t - .t image create end -name test - update - set result "" - lappend result [.t bbox test] - .t image configure test -image small -align top - update - lappend result [.t bbox test] -} {{} {0 0 5 5}} +test textImage-1.1 {basic argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be ".t image option ?arg ...?"} + +test textImage-1.2 {basic argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image c +} -cleanup { + destroy .t +} -returnCodes error -result {ambiguous option "c": must be cget, configure, create, or names} + +test textImage-1.3 {cget argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image cget +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be ".t image cget index option"} + +test textImage-1.4 {cget argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image cget blurf -flurp +} -cleanup { + destroy .t +} -returnCodes error -result {bad text index "blurf"} + +test textImage-1.5 {cget argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image cget 1.1 -flurp +} -cleanup { + destroy .t +} -returnCodes error -result {no embedded image at index "1.1"} + +test textImage-1.6 {configure argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image configure +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be ".t image configure index ?-option value ...?"} + +test textImage-1.7 {configure argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image configure blurf +} -cleanup { + destroy .t +} -returnCodes error -result {bad text index "blurf"} + +test textImage-1.8 {configure argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image configure 1.1 +} -cleanup { + destroy .t +} -returnCodes error -result {no embedded image at index "1.1"} + +test textImage-1.9 {create argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be ".t image create index ?-option value ...?"} + +test textImage-1.10 {create argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create blurf +} -cleanup { + destroy .t +} -returnCodes error -result {bad text index "blurf"} + +test textImage-1.11 {basic argument checking} -setup { + destroy .t +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create 1000.1000 -image small +} -cleanup { + destroy .t + image delete small +} -returnCodes ok -result {small} + +test textImage-1.12 {names argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image names dates places +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be ".t image names"} + + +test textImage-1.13 {names argument checking} -setup { + destroy .t + set result "" +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + lappend result [.t image names] + .t image create insert -image small + lappend result [.t image names] + .t image create insert -image small + lappend result [lsort [.t image names]] + .t image create insert -image small -name little + lappend result [lsort [.t image names]] +} -cleanup { + destroy .t + image delete small +} -result {{} small {small small#1} {little small small#1}} + +test textImage-1.14 {basic argument checking} -setup { + destroy .t +} -body { + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image huh +} -cleanup { + destroy .t +} -returnCodes error -result {bad option "huh": must be cget, configure, create, or names} + +test textImage-1.15 {align argument checking} -setup { + destroy .t +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small -align wrong +} -cleanup { + destroy .t + image delete small +} -returnCodes error -result {bad align "wrong": must be baseline, bottom, center, or top} + +test textImage-1.16 {configure} -setup { + destroy .t +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + .t image configure small +} -cleanup { + destroy .t + image delete small +} -result {{-align {} {} center center} {-padx {} {} 0 0} {-pady {} {} 0 0} {-image {} {} {} small} {-name {} {} {} {}}} + +test textImage-1.17 {basic cget options} -setup { + destroy .t + set result "" +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + foreach i {align padx pady image name} { + lappend result $i:[.t image cget small -$i] + } + return $result +} -cleanup { + destroy .t + image delete small +} -result {align:center padx:0 pady:0 image:small name:} + +test textImage-1.18 {basic configure options} -setup { + destroy .t + set result "" +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + image create photo large -width 50 -height 50 + large put green -to 0 0 50 50 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + foreach {option value} {align top padx 5 pady 7 image large name none} { + .t image configure small -$option $value + } + update + .t image configure small +} -cleanup { + destroy .t + image delete small large +} -result {{-align {} {} center top} {-padx {} {} 0 5} {-pady {} {} 0 7} {-image {} {} {} large} {-name {} {} {} none}} + +test textImage-1.19 {basic image naming} -setup { + destroy .t +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image small + .t image create end -image small -name small + .t image create end -image small -name small#6342 + .t image create end -image small -name small + lsort [.t image names] +} -cleanup { + destroy .t + image delete small +} -result {small small#1 small#6342 small#6343} + +test textImage-2.1 {debug} -setup { + destroy .t +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t debug 1 + .t insert end front + .t image create end -image small + .t insert end back + .t delete small + .t image names + .t debug 0 +} -cleanup { + destroy .t + image delete small +} -result {} + + +test textImage-3.1 {image change propagation} -setup { + destroy .t + set result "" +} -body { + catch { + image create photo vary -width 5 -height 5 + vary put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -image vary -align top + update + lappend result base:[.t bbox vary] + foreach i {10 20 40} { + vary configure -width $i -height $i + update + lappend result $i:[.t bbox vary] + } + return $result +} -cleanup { + destroy .t + image delete vary +} -result {{base:0 0 5 5} {10:0 0 10 10} {20:0 0 20 20} {40:0 0 40 40}} + +# Fails in some environments (both in Linux and winXP) +test textImage-3.2 {delayed image management} -setup { + destroy .t + set result "" +} -body { + catch { + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + } + text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 + pack .t + .t image create end -name test + update + lappend result [.t bbox test] + .t image configure test -image small -align top + update + lappend result [.t bbox test] +} -cleanup { + destroy .t + image delete small +} -result {{} {0 0 5 5}} + # some temporary random tests -test textImage-4.1 {alignment checking - except baseline} { +test textImage-4.1 {alignment checking - except baseline} -setup { + destroy .t + set result "" +} -body { catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - image create photo large -width 50 -height 50 - large put green -to 0 0 50 50 + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + image create photo large -width 50 -height 50 + large put green -to 0 0 50 50 } - catch {destroy .t} text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image large .t image create end -image small .t insert end test update - set result "" lappend result default:[.t bbox small] foreach i {top bottom center} { - .t image configure small -align $i - update - lappend result [.t image cget small -align]:[.t bbox small] + .t image configure small -align $i + update + lappend result [.t image cget small -align]:[.t bbox small] } - set result -} {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}} - -test textImage-4.2 {alignment checking - baseline} { + return $result +} -cleanup { + destroy .t + image delete small large +} -result {{default:50 22 5 5} {top:50 0 5 5} {bottom:50 45 5 5} {center:50 22 5 5}} + +test textImage-4.2 {alignment checking - baseline} -setup { + destroy .t + set result "" +} -body { catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - image create photo large -width 50 -height 50 - large put green -to 0 0 50 50 + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + image create photo large -width 50 -height 50 + large put green -to 0 0 50 50 } - catch {destroy .t} font create test_font2 -size 5 text .t -font test_font2 -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image large .t image create end -image small -align baseline .t insert end test - set result "" # Sizes larger than 25 can be too big and lead to a negative 'norm', # at least on Windows XP with certain settings. foreach size {10 15 20 25} { - font configure test_font2 -size $size - array set Metrics [font metrics test_font2] - update - foreach {x y w h} [.t bbox small] {} - set norm [expr { - (([image height large] - $Metrics(-linespace))/2 - + $Metrics(-ascent) - [image height small] - $y) - }] - lappend result "$size $norm" + font configure test_font2 -size $size + array set Metrics [font metrics test_font2] + update + foreach {x y w h} [.t bbox small] {} + set norm [expr { + (([image height large] - $Metrics(-linespace))/2 + + $Metrics(-ascent) - [image height small] - $y) + }] + lappend result "$size $norm" } + return $result +} -cleanup { + destroy .t + image delete small large font delete test_font2 unset Metrics - set result -} {{10 0} {15 0} {20 0} {25 0}} +} -result {{10 0} {15 0} {20 0} {25 0}} -test textImage-4.3 {alignment and padding checking} {fonts} { +test textImage-4.3 {alignment and padding checking} -constraints { + fonts +} -setup { + destroy .t + set result "" +} -body { catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - image create photo large -width 50 -height 50 - large put green -to 0 0 50 50 + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + image create photo large -width 50 -height 50 + large put green -to 0 0 50 50 } - catch {destroy .t} text .t -font test_font -bd 0 -highlightthickness 0 -padx 0 -pady 0 pack .t .t image create end -image large .t image create end -image small -padx 5 -pady 10 .t insert end test update - set result "" lappend result default:[.t bbox small] foreach i {top bottom center baseline} { - .t image configure small -align $i - update - lappend result $i:[.t bbox small] + .t image configure small -align $i + update + lappend result $i:[.t bbox small] } - set result -} {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}} + return $result +} -cleanup { + destroy .t + image delete small large +} -result {{default:55 22 5 5} {top:55 10 5 5} {bottom:55 35 5 5} {center:55 22 5 5} {baseline:55 22 5 5}} + -test textImage-5.0 {peer widget images} { +test textImage-5.1 {peer widget images} -setup { + destroy .t .tt +} -body { catch { - image create photo small -width 5 -height 5 - small put red -to 0 0 4 4 - image create photo large -width 50 -height 50 - large put green -to 0 0 50 50 + image create photo small -width 5 -height 5 + small put red -to 0 0 4 4 + image create photo large -width 50 -height 50 + large put green -to 0 0 50 50 } - catch {destroy .t .tt} pack [text .t] toplevel .tt pack [.t peer create .tt.t] @@ -358,13 +454,19 @@ test textImage-5.0 {peer widget images} { .t insert end test update destroy .t .tt -} {} +} -cleanup { + image delete small large +} -result {} # cleanup -catch {destroy .t} -foreach image [image names] {image delete $image} +destroy .t font delete test_font +imageFinish # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/textIndex.test b/tests/textIndex.test index 6341b6d..a6752cb 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -782,7 +782,7 @@ test textIndex-19.12 {Display lines} { } {2.20} test textIndex-19.13 {Display lines} { - destroy .t + destroy {*}[pack slaves .] text .txt -height 1 -wrap word -yscroll ".sbar set" -width 400 scrollbar .sbar -command ".txt yview" grid .txt .sbar -sticky news diff --git a/tests/textMark.test b/tests/textMark.test index c2810cc..c83b4c8 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -6,29 +6,19 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -catch {destroy .t} +destroy .t text .t -width 20 -height 10 -testConstraint haveCourier12 [expr {[catch { - .t configure -font {Courier 12} -}] == 0}] pack append . .t {top expand fill} update .t debug on wm geometry . {} - -# The statements below reset the main window; it's needed if the window -# manager is mwm to make mwm forget about a previous minimum size setting. - -wm withdraw . -wm minsize . 1 1 -wm positionfrom . user -wm deiconify . - entry .t.e + .t insert 1.0 "Line 1 abcdefghijklm 12345 @@ -36,187 +26,226 @@ Line 4 bOy GIrl .#@? x_yz !@#$% Line 7" + +# The statements below reset the main window; it's needed if the window +# manager is mwm to make mwm forget about a previous minimum size setting. -test textMark-1.1 {TkTextMarkCmd - missing option} haveCourier12 { - list [catch {.t mark} msg] $msg -} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} -test textMark-1.2 {TkTextMarkCmd - bogus option} haveCourier12 { - list [catch {.t mark gorp} msg] $msg -} {1 {bad mark option "gorp": must be gravity, names, next, previous, set, or unset}} -test textMark-1.3 {TkTextMarkCmd - "gravity" option} haveCourier12 { - list [catch {.t mark gravity foo} msg] $msg -} {1 {there is no mark named "foo"}} -test textMark-1.4 {TkTextMarkCmd - "gravity" option} haveCourier12 { - .t mark unset x +wm withdraw . +wm minsize . 1 1 +wm positionfrom . user +wm deiconify . + +test textMark-1.1 {TkTextMarkCmd - missing option} -returnCodes error -body { + .t mark +} -result {wrong # args: should be ".t mark option ?arg ...?"} +test textMark-1.2 {TkTextMarkCmd - bogus option} -returnCodes error -body { + .t mark gorp +} -match glob -result {bad mark option "gorp": must be *} +test textMark-1.3 {TkTextMarkCmd - "gravity" option} -returnCodes error -body { + .t mark gravity foo +} -result {there is no mark named "foo"} +test textMark-1.4 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 .t insert 1.3 x list [.t mark gravity x] [.t index x] -} {right 1.4} -test textMark-1.5 {TkTextMarkCmd - "gravity" option} haveCourier12 { - .t mark unset x +} -result {right 1.4} +test textMark-1.5 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 .t mark g x left .t insert 1.3 x list [.t mark gravity x] [.t index x] -} {left 1.3} -test textMark-1.6 {TkTextMarkCmd - "gravity" option} haveCourier12 { - .t mark unset x +} -result {left 1.3} +test textMark-1.6 {TkTextMarkCmd - "gravity" option} -body { .t mark set x 1.3 .t mark gravity x right .t insert 1.3 x list [.t mark gravity x] [.t index x] -} {right 1.4} -test textMark-1.7 {TkTextMarkCmd - "gravity" option} haveCourier12 { - list [catch {.t mark gravity x gorp} msg] $msg -} {1 {bad mark gravity "gorp": must be left or right}} -test textMark-1.8 {TkTextMarkCmd - "gravity" option} haveCourier12 { - list [catch {.t mark gravity} msg] $msg -} {1 {wrong # args: should be ".t mark gravity markName ?gravity?"}} +} -result {right 1.4} +test textMark-1.7 {TkTextMarkCmd - "gravity" option} -returnCodes error -body { + .t mark set x 1.3 + .t mark gravity x gorp +} -result {bad mark gravity "gorp": must be left or right} +test textMark-1.8 {TkTextMarkCmd - "gravity" option} -returnCodes error -body { + .t mark gravity +} -result {wrong # args: should be ".t mark gravity markName ?gravity?"} -test textMark-2.1 {TkTextMarkCmd - "names" option} haveCourier12 { - list [catch {.t mark names 2} msg] $msg -} {1 {wrong # args: should be ".t mark names"}} -.t mark unset x -test textMark-2.2 {TkTextMarkCmd - "names" option} haveCourier12 { +test textMark-2.1 {TkTextMarkCmd - "names" option} -body { + .t mark names 2 +} -returnCodes error -result {wrong # args: should be ".t mark names"} +test textMark-2.2 {TkTextMarkCmd - "names" option} -setup { + .t mark unset {*}[.t mark names] +} -body { lsort [.t mark na] -} {current insert} -test textMark-2.3 {TkTextMarkCmd - "names" option} haveCourier12 { +} -result {current insert} +test textMark-2.3 {TkTextMarkCmd - "names" option} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set a 1.1 .t mark set "b c" 2.3 lsort [.t mark names] -} {a {b c} current insert} +} -result {a {b c} current insert} -test textMark-3.1 {TkTextMarkCmd - "set" option} haveCourier12 { - list [catch {.t mark set a} msg] $msg -} {1 {wrong # args: should be ".t mark set markName index"}} -test textMark-3.2 {TkTextMarkCmd - "set" option} haveCourier12 { - list [catch {.t mark s a b c} msg] $msg -} {1 {wrong # args: should be ".t mark set markName index"}} -test textMark-3.3 {TkTextMarkCmd - "set" option} haveCourier12 { - list [catch {.t mark set a @x} msg] $msg -} {1 {bad text index "@x"}} -test textMark-3.4 {TkTextMarkCmd - "set" option} haveCourier12 { +test textMark-3.1 {TkTextMarkCmd - "set" option} -returnCodes error -body { + .t mark set a +} -result {wrong # args: should be ".t mark set markName index"} +test textMark-3.2 {TkTextMarkCmd - "set" option} -returnCodes error -body { + .t mark s a b c +} -result {wrong # args: should be ".t mark set markName index"} +test textMark-3.3 {TkTextMarkCmd - "set" option} -body { + .t mark set a @x +} -returnCodes error -result {bad text index "@x"} +test textMark-3.4 {TkTextMarkCmd - "set" option} -body { .t mark set a 1.2 .t index a -} 1.2 -test textMark-3.5 {TkTextMarkCmd - "set" option} haveCourier12 { +} -result 1.2 +test textMark-3.5 {TkTextMarkCmd - "set" option} -body { .t mark set a end .t index a -} {8.0} +} -result {8.0} -test textMark-4.1 {TkTextMarkCmd - "unset" option} haveCourier12 { - list [catch {.t mark unset} msg] $msg -} {0 {}} -test textMark-4.2 {TkTextMarkCmd - "unset" option} haveCourier12 { +test textMark-4.1 {TkTextMarkCmd - "unset" option} -body { + .t mark unset +} -result {} +test textMark-4.2 {TkTextMarkCmd - "unset" option} -body { .t mark set a 1.2 .t mark set b 2.3 .t mark unset a b - list [catch {.t index a} msg] $msg [catch {.t index b} msg2] $msg2 -} {1 {bad text index "a"} 1 {bad text index "b"}} -test textMark-4.3 {TkTextMarkCmd - "unset" option} haveCourier12 { + .t index a +} -returnCodes error -result {bad text index "a"} +test textMark-4.2.1 {TkTextMarkCmd - "unset" option} -body { + .t mark set a 1.2 + .t mark set b 2.3 + .t mark unset a b + .t index b +} -returnCodes error -result {bad text index "b"} +test textMark-4.3 {TkTextMarkCmd - "unset" option} -body { .t mark set a 1.2 .t mark set b 2.3 .t mark set 49ers 3.1 - eval .t mark unset [.t mark names] + .t mark unset {*}[.t mark names] lsort [.t mark names] -} {current insert} +} -result {current insert} -test textMark-5.1 {TkTextMarkCmd - miscellaneous} haveCourier12 { - list [catch {.t mark} msg] $msg -} {1 {wrong # args: should be ".t mark option ?arg arg ...?"}} -test textMark-5.2 {TkTextMarkCmd - miscellaneous} haveCourier12 { - list [catch {.t mark foo} msg] $msg -} {1 {bad mark option "foo": must be gravity, names, next, previous, set, or unset}} +test textMark-5.1 {TkTextMarkCmd - miscellaneous} -returnCodes error -body { + .t mark +} -result {wrong # args: should be ".t mark option ?arg ...?"} +test textMark-5.2 {TkTextMarkCmd - miscellaneous} -returnCodes error -body { + .t mark foo +} -result {bad mark option "foo": must be gravity, names, next, previous, set, or unset} -test textMark-6.1 {TkTextMarkSegToIndex} haveCourier12 { +test textMark-6.1 {TkTextMarkSegToIndex} -body { .t mark set a 1.2 .t mark set b 1.2 .t mark set c 1.2 .t mark set d 1.4 list [.t index a] [.t index b] [.t index c ] [.t index d] -} {1.2 1.2 1.2 1.4} +} -result {1.2 1.2 1.2 1.4} -catch {eval {.t mark unset} [.t mark names]} -test textMark-7.1 {MarkFindNext - invalid mark name} haveCourier12 { - catch {.t mark next bogus} x - set x -} {bad text index "bogus"} -test textMark-7.2 {MarkFindNext - marks at same location} haveCourier12 { +test textMark-7.1 {MarkFindNext - invalid mark name} -body { + .t mark next bogus +} -returnCodes error -result {bad text index "bogus"} +test textMark-7.2 {MarkFindNext - marks at same location} -body { .t mark set insert 2.0 .t mark set current 2.0 .t mark next current -} {insert} -test textMark-7.3 {MarkFindNext - numerical starting mark} haveCourier12 { +} -result {insert} +test textMark-7.3 {MarkFindNext - numerical starting mark} -body { .t mark set current 1.0 .t mark set insert 1.0 .t mark next 1.0 -} {insert} -test textMark-7.4 {MarkFindNext - mark on the same line} haveCourier12 { +} -result {insert} +test textMark-7.4 {MarkFindNext - mark on the same line} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.0 .t mark set insert 1.1 .t mark next current -} {insert} -test textMark-7.5 {MarkFindNext - mark on the next line} haveCourier12 { +} -result {insert} +test textMark-7.5 {MarkFindNext - mark on the next line} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.end .t mark set insert 2.0 .t mark next current -} {insert} -test textMark-7.6 {MarkFindNext - mark far away} haveCourier12 { +} -result {insert} +test textMark-7.6 {MarkFindNext - mark far away} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.2 .t mark set insert 7.0 .t mark next current -} {insert} -test textMark-7.7 {MarkFindNext - mark on top of end} haveCourier12 { +} -result {insert} +test textMark-7.7 {MarkFindNext - mark on top of end} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current end .t mark next end -} {current} -test textMark-7.8 {MarkFindNext - no next mark} haveCourier12 { +} -result {current} +test textMark-7.8 {MarkFindNext - no next mark} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.0 .t mark set insert 3.0 .t mark next insert -} {} -test textMark-8.1 {MarkFindPrev - invalid mark name} haveCourier12 { - catch {.t mark prev bogus} x - set x -} {bad text index "bogus"} -test textMark-8.2 {MarkFindPrev - marks at same location} haveCourier12 { +} -result {} + +test textMark-8.1 {MarkFindPrev - invalid mark name} -body { + .t mark prev bogus +} -returnCodes error -result {bad text index "bogus"} +test textMark-8.2 {MarkFindPrev - marks at same location} -body { .t mark set insert 2.0 .t mark set current 2.0 .t mark prev insert -} {current} -test textMark-8.3 {MarkFindPrev - numerical starting mark} haveCourier12 { +} -result {current} +test textMark-8.3 {MarkFindPrev - numerical starting mark} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.0 .t mark set insert 1.0 .t mark prev 1.1 -} {current} -test textMark-8.4 {MarkFindPrev - mark on the same line} haveCourier12 { +} -result {current} +test textMark-8.4 {MarkFindPrev - mark on the same line} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.0 .t mark set insert 1.1 .t mark prev insert -} {current} -test textMark-8.5 {MarkFindPrev - mark on the previous line} haveCourier12 { +} -result {current} +test textMark-8.5 {MarkFindPrev - mark on the previous line} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.end .t mark set insert 2.0 .t mark prev insert -} {current} -test textMark-8.6 {MarkFindPrev - mark far away} haveCourier12 { +} -result {current} +test textMark-8.6 {MarkFindPrev - mark far away} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.2 .t mark set insert 7.0 .t mark prev insert -} {current} -test textMark-8.7 {MarkFindPrev - mark on top of end} haveCourier12 { +} -result {current} +test textMark-8.7 {MarkFindPrev - mark on top of end} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set insert 3.0 .t mark set current end .t mark prev end -} {insert} -test textMark-8.8 {MarkFindPrev - no previous mark} haveCourier12 { +} -result {insert} +test textMark-8.8 {MarkFindPrev - no previous mark} -setup { + .t mark unset {*}[.t mark names] +} -body { .t mark set current 1.0 .t mark set insert 3.0 .t mark prev current -} {} - -catch {destroy .t} +} -result {} + +destroy .t # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/textTag.test b/tests/textTag.test index b112fc2..34ce003 100644 --- a/tests/textTag.test +++ b/tests/textTag.test @@ -6,19 +6,21 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -namespace import -force tcltest::test -catch {destroy .t} +destroy .t text .t -width 20 -height 10 testConstraint haveCourier12 [expr {[catch { .t configure -font {Courier 12} }] == 0}] + pack append . .t {top expand fill} update .t debug on + wm geometry . {} set bigFont {Helvetica 24} @@ -30,9 +32,6 @@ wm minsize . 1 1 wm positionfrom . user wm deiconify . -entry .t.e -.t.e insert 0 "Text" - .t insert 1.0 "Line 1 abcdefghijklm 12345 @@ -41,540 +40,1289 @@ bOy GIrl .#@? x_yz !@#$% Line 7" +test textTag-1.1 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -background #012345 + .t tag cget x -background +} -cleanup { + .t tag configure x -background [lindex [.t tag configure x -background] 3] +} -result {#012345} +test textTag-1.2 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -background non-existent +} -cleanup { + .t tag configure x -background [lindex [.t tag configure x -background] 3] +} -returnCodes error -result {unknown color name "non-existent"} +test textTag-1.3 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -bgstipple gray50 + .t tag cget x -bgstipple +} -cleanup { + .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3] +} -result {gray50} +test textTag-1.4 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -bgstipple badStipple +} -cleanup { + .t tag configure x -bgstipple [lindex [.t tag configure x -bgstipple] 3] +} -returnCodes error -result {bitmap "badStipple" not defined} +test textTag-1.5 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -borderwidth 2 + .t tag cget x -borderwidth +} -cleanup { + .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3] +} -result {2} +test textTag-1.6 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -borderwidth 46q +} -cleanup { + .t tag configure x -borderwidth [lindex [.t tag configure x -borderwidth] 3] +} -returnCodes error -result {bad screen distance "46q"} +test textTag-1.7 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -fgstipple gray25 + .t tag cget x -fgstipple +} -cleanup { + .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3] +} -result {gray25} +test textTag-1.8 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -fgstipple bogus +} -cleanup { + .t tag configure x -fgstipple [lindex [.t tag configure x -fgstipple] 3] +} -returnCodes error -result {bitmap "bogus" not defined} +test textTag-1.9 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -font fixed + .t tag cget x -font +} -cleanup { + .t tag configure x -font [lindex [.t tag configure x -font] 3] +} -result {fixed} +test textTag-1.10 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -foreground #001122 + .t tag cget x -foreground +} -cleanup { + .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3] +} -result {#001122} +test textTag-1.11 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -foreground {silly color} +} -cleanup { + .t tag configure x -foreground [lindex [.t tag configure x -foreground] 3] +} -returnCodes error -result {unknown color name "silly color"} +test textTag-1.12 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -justify left + .t tag cget x -justify +} -cleanup { + .t tag configure x -justify [lindex [.t tag configure x -justify] 3] +} -result {left} +test textTag-1.13 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -justify middle +} -cleanup { + .t tag configure x -justify [lindex [.t tag configure x -justify] 3] +} -returnCodes error -result {bad justification "middle": must be left, right, or center} +test textTag-1.14 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -lmargin1 10 + .t tag cget x -lmargin1 +} -cleanup { + .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3] +} -result {10} +test textTag-1.15 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -lmargin1 bad +} -cleanup { + .t tag configure x -lmargin1 [lindex [.t tag configure x -lmargin1] 3] +} -returnCodes error -result {bad screen distance "bad"} +test textTag-1.16 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -lmargin2 10 + .t tag cget x -lmargin2 +} -cleanup { + .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3] +} -result {10} +test textTag-1.17 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -lmargin2 bad +} -cleanup { + .t tag configure x -lmargin2 [lindex [.t tag configure x -lmargin2] 3] +} -returnCodes error -result {bad screen distance "bad"} +test textTag-1.18 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -offset 2 + .t tag cget x -offset +} -cleanup { + .t tag configure x -offset [lindex [.t tag configure x -offset] 3] +} -result {2} +test textTag-1.19 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -offset 100xyz +} -cleanup { + .t tag configure x -offset [lindex [.t tag configure x -offset] 3] +} -returnCodes error -result {bad screen distance "100xyz"} +test textTag-1.20 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -overstrike on + .t tag cget x -overstrike +} -cleanup { + .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3] +} -result {on} +test textTag-1.21 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -overstrike stupid +} -cleanup { + .t tag configure x -overstrike [lindex [.t tag configure x -overstrike] 3] +} -returnCodes error -result {expected boolean value but got "stupid"} +test textTag-1.22 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -relief raised + .t tag cget x -relief +} -cleanup { + .t tag configure x -relief [lindex [.t tag configure x -relief] 3] +} -result {raised} +test textTag-1.23 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -relief stupid +} -cleanup { + .t tag configure x -relief [lindex [.t tag configure x -relief] 3] +} -returnCodes error -result {bad relief "stupid": must be flat, groove, raised, ridge, solid, or sunken} +test textTag-1.24 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -rmargin 10 + .t tag cget x -rmargin +} -cleanup { + .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3] +} -result {10} +test textTag-1.25 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -rmargin bad +} -cleanup { + .t tag configure x -rmargin [lindex [.t tag configure x -rmargin] 3] +} -returnCodes error -result {bad screen distance "bad"} +test textTag-1.26 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -spacing1 10 + .t tag cget x -spacing1 +} -cleanup { + .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3] +} -result {10} +test textTag-1.27 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -spacing1 bad +} -cleanup { + .t tag configure x -spacing1 [lindex [.t tag configure x -spacing1] 3] +} -returnCodes error -result {bad screen distance "bad"} +test textTag-1.28 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -spacing2 10 + .t tag cget x -spacing2 +} -cleanup { + .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3] +} -result {10} +test textTag-1.29 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -spacing2 bad +} -cleanup { + .t tag configure x -spacing2 [lindex [.t tag configure x -spacing2] 3] +} -returnCodes error -result {bad screen distance "bad"} +test textTag-1.30 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -spacing3 10 + .t tag cget x -spacing3 +} -cleanup { + .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3] +} -result {10} +test textTag-1.31 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -spacing3 bad +} -cleanup { + .t tag configure x -spacing3 [lindex [.t tag configure x -spacing3] 3] +} -returnCodes error -result {bad screen distance "bad"} +test textTag-1.32 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -tabs {10 20 30} + .t tag cget x -tabs +} -cleanup { + .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3] +} -result {10 20 30} +test textTag-1.33 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -tabs {10 fork} +} -cleanup { + .t tag configure x -tabs [lindex [.t tag configure x -tabs] 3] +} -returnCodes error -result {bad tab alignment "fork": must be left, right, center, or numeric} +test textTag-1.34 {tag configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -underline no + .t tag cget x -underline +} -cleanup { + .t tag configure x -underline [lindex [.t tag configure x -underline] 3] +} -result {no} +test textTag-1.35 {configuration options} -constraints { + haveCourier12 +} -body { + .t tag configure x -underline stupid +} -cleanup { + .t tag configure x -underline [lindex [.t tag configure x -underline] 3] +} -returnCodes error -result {expected boolean value but got "stupid"} + -set i 1 -foreach test { - {-background #012345 #012345 non-existent - {unknown color name "non-existent"}} - {-bgstipple gray50 gray50 badStipple - {bitmap "badStipple" not defined}} - {-borderwidth 2 2 46q - {bad screen distance "46q"}} - {-fgstipple gray25 gray25 bogus - {bitmap "bogus" not defined}} - {-font fixed fixed {} - {font "" doesn't exist}} - {-foreground #001122 #001122 {silly color} - {unknown color name "silly color"}} - {-justify left left middle - {bad justification "middle": must be left, right, or center}} - {-lmargin1 10 10 bad - {bad screen distance "bad"}} - {-lmargin2 10 10 bad - {bad screen distance "bad"}} - {-offset 2 2 100xyz - {bad screen distance "100xyz"}} - {-overstrike on on stupid - {expected boolean value but got "stupid"}} - {-relief raised raised stupid - {bad relief type "stupid": must be flat, groove, raised, ridge, solid, or sunken}} - {-rmargin 10 10 bad - {bad screen distance "bad"}} - {-spacing1 10 10 bad - {bad screen distance "bad"}} - {-spacing2 10 10 bad - {bad screen distance "bad"}} - {-spacing3 10 10 bad - {bad screen distance "bad"}} - {-tabs {10 20 30} {10 20 30} {10 fork} - {bad tab alignment "fork": must be left, right, center, or numeric}} - {-underline no no stupid - {expected boolean value but got "stupid"}} -} { - set name [lindex $test 0] - test textTag-1.$i {tag configuration options} haveCourier12 { - .t tag configure x $name [lindex $test 1] - .t tag cget x $name - } [lindex $test 2] - incr i - if {[lindex $test 3] != ""} { - test textTag-1.$i {configuration options} haveCourier12 { - list [catch {.t tag configure x $name [lindex $test 3]} msg] $msg - } [list 1 [lindex $test 4]] - } - .t tag configure x $name [lindex [.t tag configure x $name] 3] - incr i -} -test textTag-2.1 {TkTextTagCmd - "add" option} haveCourier12 { - list [catch {.t tag} msg] $msg -} {1 {wrong # args: should be ".t tag option ?arg arg ...?"}} -test textTag-2.2 {TkTextTagCmd - "add" option} haveCourier12 { - list [catch {.t tag gorp} msg] $msg -} {1 {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove}} -test textTag-2.3 {TkTextTagCmd - "add" option} haveCourier12 { - list [catch {.t tag add foo} msg] $msg -} {1 {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"}} -test textTag-2.4 {TkTextTagCmd - "add" option} haveCourier12 { - list [catch {.t tag add x gorp} msg] $msg -} {1 {bad text index "gorp"}} -test textTag-2.5 {TkTextTagCmd - "add" option} haveCourier12 { - list [catch {.t tag add x 1.2 gorp} msg] $msg -} {1 {bad text index "gorp"}} -test textTag-2.6 {TkTextTagCmd - "add" option} haveCourier12 { +test textTag-2.1 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { + .t tag +} -returnCodes error -result {wrong # args: should be ".t tag option ?arg ...?"} +test textTag-2.2 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { + .t tag gorp +} -returnCodes error -result {bad tag option "gorp": must be add, bind, cget, configure, delete, lower, names, nextrange, prevrange, raise, ranges, or remove} +test textTag-2.3 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { + .t tag add foo +} -returnCodes error -result {wrong # args: should be ".t tag add tagName index1 ?index2 index1 index2 ...?"} +test textTag-2.4 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { + .t tag add x gorp +} -returnCodes error -result {bad text index "gorp"} +test textTag-2.5 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { + .t tag add x 1.2 gorp +} -returnCodes error -result {bad text index "gorp"} +test textTag-2.6 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -setup { + .t tag delete sel +} -body { .t tag add sel 3.2 3.4 .t tag add sel 3.2 3.0 .t tag ranges sel -} {3.2 3.4} -test textTag-2.7 {TkTextTagCmd - "add" option} haveCourier12 { +} -result {3.2 3.4} +test textTag-2.7 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { .t tag add x 1.0 1.end .t tag ranges x -} {1.0 1.6} -test textTag-2.8 {TkTextTagCmd - "add" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {1.0 1.6} +test textTag-2.8 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -setup { .t tag remove x 1.0 end +} -body { .t tag add x 1.2 .t tag ranges x -} {1.2 1.3} -test textTag-2.9 {TkTextTagCmd - "add" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {1.2 1.3} +test textTag-2.9 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -setup { + destroy .t.e +} -body { + entry .t.e + .t.e insert 0 "Text" .t.e select from 0 .t.e select to 4 .t tag add sel 3.2 3.4 selection get -} 34 -test textTag-2.11 {TkTextTagCmd - "add" option} haveCourier12 { +} -cleanup { + destroy .t.e +} -result 34 +test textTag-2.10 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -setup { + destroy .t.e +} -body { + entry .t.e + .t.e insert 0 "Text" .t.e select from 0 .t.e select to 4 .t configure -exportselection 0 .t tag add sel 3.2 3.4 selection get -} Text -test textTag-2.12 {TkTextTagCmd - "add" option} haveCourier12 { +} -cleanup { + destroy .t.e +} -result {Text} +test textTag-2.11 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 3.1 4.2 4.4 .t tag ranges sel -} {1.1 1.5 2.4 3.1 4.2 4.4} -test textTag-2.13 {TkTextTagCmd - "add" option} haveCourier12 { +} -result {1.1 1.5 2.4 3.1 4.2 4.4} +test textTag-2.12 {TkTextTagCmd - "add" option} -constraints { + haveCourier12 +} -body { .t tag remove sel 1.0 end .t tag add sel 1.1 1.5 2.4 .t tag ranges sel -} {1.1 1.5 2.4 2.5} - -catch {.t tag delete x} -test textTag-3.1 {TkTextTagCmd - "bind" option} haveCourier12 { - list [catch {.t tag bind} msg] $msg -} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}} -test textTag-3.2 {TkTextTagCmd - "bind" option} haveCourier12 { - list [catch {.t tag bind 1 2 3 4} msg] $msg -} {1 {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"}} -test textTag-3.3 {TkTextTagCmd - "bind" option} haveCourier12 { +} -cleanup { + .t tag remove sel 1.0 end +} -result {1.1 1.5 2.4 2.5} + + +test textTag-3.1 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { + .t tag bind +} -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"} +test textTag-3.2 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { + .t tag bind 1 2 3 4 +} -returnCodes error -result {wrong # args: should be ".t tag bind tagName ?sequence? ?command?"} +test textTag-3.3 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { .t tag bind x <Enter> script1 .t tag bind x <Enter> -} script1 -test textTag-3.4 {TkTextTagCmd - "bind" option} haveCourier12 { - list [catch {.t tag bind x <Gorp> script2} msg] $msg -} {1 {bad event type or keysym "Gorp"}} -test textTag-3.5 {TkTextTagCmd - "bind" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {script1} +test textTag-3.4 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { + .t tag bind x <Gorp> script2 +} -returnCodes error -result {bad event type or keysym "Gorp"} +test textTag-3.5 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag bind x <Enter> script1 - list [catch {.t tag bind x <FocusIn> script2} msg] $msg [.t tag bind x] -} {1 {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} <Enter>} -test textTag-3.6 {TkTextTagCmd - "bind" option} haveCourier12 { + .t tag bind x <FocusIn> script2 +} -cleanup { + .t tag delete x +} -returnCodes error -result {requested illegal events; only key, button, motion, enter, leave, and virtual events may be used} +test textTag-3.6 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag bind x <Enter> script1 + catch {.t tag bind x <FocusIn> script2} + .t tag bind x +} -cleanup { + .t tag delete x +} -result {<Enter>} +test textTag-3.7 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Leave> script2 .t tag bind x a xyzzy list [lsort [.t tag bind x]] [.t tag bind x <Enter>] [.t tag bind x a] -} {{<Enter> <Leave> a} script1 xyzzy} -test textTag-3.7 {TkTextTagCmd - "bind" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {{<Enter> <Leave> a} script1 xyzzy} +test textTag-3.8 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag bind x <Enter> script1 .t tag bind x <Enter> +script2 .t tag bind x <Enter> -} {script1 +} -cleanup { + .t tag delete x +} -result {script1 script2} -test textTag-3.7a {TkTextTagCmd - "bind" option} haveCourier12 { - .t tag delete x - list [catch {.t tag bind x <Enter>} msg] $msg -} {0 {}} -test textTag-3.8 {TkTextTagCmd - "bind" option} haveCourier12 { - .t tag delete x - list [catch {.t tag bind x <} msg] $msg -} {1 {no event type or button # or keysym}} - -test textTag-4.1 {TkTextTagCmd - "cget" option} haveCourier12 { - list [catch {.t tag cget a} msg] $msg -} {1 {wrong # args: should be ".t tag cget tagName option"}} -test textTag-4.2 {TkTextTagCmd - "cget" option} haveCourier12 { - list [catch {.t tag cget a b c} msg] $msg -} {1 {wrong # args: should be ".t tag cget tagName option"}} -test textTag-4.3 {TkTextTagCmd - "cget" option} haveCourier12 { +test textTag-3.9 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag bind x <Enter> +} -cleanup { + .t tag delete x +} -returnCodes ok -result {} +test textTag-3.10 {TkTextTagCmd - "bind" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag bind x < +} -cleanup { + .t tag delete x +} -returnCodes error -result {no event type or button # or keysym} + + +test textTag-4.1 {TkTextTagCmd - "cget" option} -constraints { + haveCourier12 +} -body { + .t tag cget a +} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"} +test textTag-4.2 {TkTextTagCmd - "cget" option} -constraints { + haveCourier12 +} -body { + .t tag cget a b c +} -returnCodes error -result {wrong # args: should be ".t tag cget tagName option"} +test textTag-4.3 {TkTextTagCmd - "cget" option} -constraints { + haveCourier12 +} -body { .t tag delete foo - list [catch {.t tag cget foo bar} msg] $msg -} {1 {tag "foo" isn't defined in text widget}} -test textTag-4.4 {TkTextTagCmd - "cget" option} haveCourier12 { - list [catch {.t tag cget sel bogus} msg] $msg -} {1 {unknown option "bogus"}} -test textTag-4.5 {TkTextTagCmd - "cget" option} haveCourier12 { + .t tag cget foo bar +} -returnCodes error -result {tag "foo" isn't defined in text widget} +test textTag-4.4 {TkTextTagCmd - "cget" option} -constraints { + haveCourier12 +} -body { + .t tag cget sel bogus +} -returnCodes error -result {unknown option "bogus"} +test textTag-4.5 {TkTextTagCmd - "cget" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -background red - list [catch {.t tag cget x -background} msg] $msg -} {0 red} - -test textTag-5.1 {TkTextTagCmd - "configure" option} haveCourier12 { - list [catch {.t tag configure} msg] $msg -} {1 {wrong # args: should be ".t tag configure tagName ?option? ?value? ?option value ...?"}} -test textTag-5.2 {TkTextTagCmd - "configure" option} haveCourier12 { - list [catch {.t tag configure x -foo} msg] $msg -} {1 {unknown option "-foo"}} -test textTag-5.3 {TkTextTagCmd - "configure" option} haveCourier12 { - list [catch {.t tag configure x -background red -underline} msg] $msg -} {1 {value for "-underline" missing}} -test textTag-5.4 {TkTextTagCmd - "configure" option} haveCourier12 { + .t tag cget x -background +} -cleanup { + .t tag delete x +} -result {red} + + +test textTag-5.1 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag configure +} -returnCodes error -result {wrong # args: should be ".t tag configure tagName ?-option? ?value? ?-option value ...?"} +test textTag-5.2 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag configure x -foo +} -returnCodes error -result {unknown option "-foo"} +test textTag-5.3 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag configure x -background red -underline +} -cleanup { + .t tag delete x +} -returnCodes error -result {value for "-underline" missing} +test textTag-5.4 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -underline yes .t tag configure x -underline -} {-underline {} {} {} yes} -test textTag-5.5 {TkTextTagCmd - "configure" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {-underline {} {} {} yes} +test textTag-5.5 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -overstrike on .t tag cget x -overstrike -} {on} -test textTag-5.6 {TkTextTagCmd - "configure" option} haveCourier12 { - list [catch {.t tag configure x -overstrike foo} msg] $msg -} {1 {expected boolean value but got "foo"}} -test textTag-5.7 {TkTextTagCmd - "configure" option} haveCourier12 { +} -cleanup { .t tag delete x - list [catch {.t tag configure x -underline stupid} msg] $msg -} {1 {expected boolean value but got "stupid"}} -test textTag-5.8 {TkTextTagCmd - "configure" option} haveCourier12 { +} -result {on} +test textTag-5.6 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag configure x -overstrike foo +} -cleanup { + .t tag delete x +} -returnCodes error -result {expected boolean value but got "foo"} +test textTag-5.7 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -underline stupid +} -cleanup { + .t tag delete x +} -returnCodes error -result {expected boolean value but got "stupid"} +test textTag-5.8 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -justify left .t tag configure x -justify -} {-justify {} {} {} left} -test textTag-5.9 {TkTextTagCmd - "configure" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {-justify {} {} {} left} +test textTag-5.9 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -justify bogus +} -cleanup { .t tag delete x - list [catch {.t tag configure x -justify bogus} msg] $msg -} {1 {bad justification "bogus": must be left, right, or center}} -test textTag-5.10 {TkTextTagCmd - "configure" option} haveCourier12 { +} -returnCodes error -result {bad justification "bogus": must be left, right, or center} +test textTag-5.10 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x - list [catch {.t tag configure x -justify fill} msg] $msg -} {1 {bad justification "fill": must be left, right, or center}} -test textTag-5.11 {TkTextTagCmd - "configure" option} haveCourier12 { + .t tag configure x -justify fill +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad justification "fill": must be left, right, or center} +test textTag-5.11 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -offset 2 .t tag configure x -offset -} {-offset {} {} {} 2} -test textTag-5.12 {TkTextTagCmd - "configure" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {-offset {} {} {} 2} +test textTag-5.12 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -offset 1.0q +} -cleanup { .t tag delete x - list [catch {.t tag configure x -offset 1.0q} msg] $msg -} {1 {bad screen distance "1.0q"}} -test textTag-5.13 {TkTextTagCmd - "configure" option} haveCourier12 { +} -returnCodes error -result {bad screen distance "1.0q"} +test textTag-5.13 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -lmargin1 2 -lmargin2 4 -rmargin 5 list [.t tag configure x -lmargin1] [.t tag configure x -lmargin2] \ - [.t tag configure x -rmargin] -} {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}} -test textTag-5.14 {TkTextTagCmd - "configure" option} haveCourier12 { + [.t tag configure x -rmargin] +} -cleanup { + .t tag delete x +} -result {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}} +test textTag-5.14 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -lmargin1 2.0x +} -cleanup { .t tag delete x - list [catch {.t tag configure x -lmargin1 2.0x} msg] $msg -} {1 {bad screen distance "2.0x"}} -test textTag-5.15 {TkTextTagCmd - "configure" option} haveCourier12 { +} -returnCodes error -result {bad screen distance "2.0x"} +test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x - list [catch {.t tag configure x -lmargin2 gorp} msg] $msg -} {1 {bad screen distance "gorp"}} -test textTag-5.16 {TkTextTagCmd - "configure" option} haveCourier12 { + .t tag configure x -lmargin2 gorp +} -cleanup { .t tag delete x - list [catch {.t tag configure x -rmargin 140.1.1} msg] $msg -} {1 {bad screen distance "140.1.1"}} +} -returnCodes error -result {bad screen distance "gorp"} +test textTag-5.16 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -rmargin 140.1.1 +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad screen distance "140.1.1"} .t tag delete x -test textTag-5.17 {TkTextTagCmd - "configure" option} haveCourier12 { +test textTag-5.17 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag configure x -spacing1 2 -spacing2 4 -spacing3 6 list [.t tag configure x -spacing1] [.t tag configure x -spacing2] \ - [.t tag configure x -spacing3] -} {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}} -test textTag-5.18 {TkTextTagCmd - "configure" option} haveCourier12 { + [.t tag configure x -spacing3] +} -cleanup { + .t tag delete x +} -result {{-spacing1 {} {} {} 2} {-spacing2 {} {} {} 4} {-spacing3 {} {} {} 6}} +test textTag-5.18 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -spacing1 2.0x +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad screen distance "2.0x"} +test textTag-5.19 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x - list [catch {.t tag configure x -spacing1 2.0x} msg] $msg -} {1 {bad screen distance "2.0x"}} -test textTag-5.19 {TkTextTagCmd - "configure" option} haveCourier12 { + .t tag configure x -spacing1 lousy +} -cleanup { .t tag delete x - list [catch {.t tag configure x -spacing1 lousy} msg] $msg -} {1 {bad screen distance "lousy"}} -test textTag-5.20 {TkTextTagCmd - "configure" option} haveCourier12 { +} -returnCodes error -result {bad screen distance "lousy"} +test textTag-5.20 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t tag delete x - list [catch {.t tag configure x -spacing1 4.2.3} msg] $msg -} {1 {bad screen distance "4.2.3"}} -test textTag-5.21 {TkTextTagCmd - "configure" option} haveCourier12 { + .t tag configure x -spacing1 4.2.3 +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad screen distance "4.2.3"} +test textTag-5.21 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t configure -selectborderwidth 2 -selectforeground blue \ - -selectbackground black + -selectbackground black .t tag configure sel -borderwidth 4 -foreground green -background yellow set x {} foreach i {-selectborderwidth -selectforeground -selectbackground} { - lappend x [lindex [.t configure $i] 4] + lappend x [lindex [.t configure $i] 4] } - set x -} {4 green yellow} -test textTag-5.22 {TkTextTagCmd - "configure" option} haveCourier12 { + return $x +} -result {4 green yellow} +test textTag-5.22 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { .t configure -selectborderwidth 20 .t tag configure sel -borderwidth {} .t cget -selectborderwidth -} {} +} -result {} -test textTag-6.1 {TkTextTagCmd - "delete" option} haveCourier12 { - list [catch {.t tag delete} msg] $msg -} {1 {wrong # args: should be ".t tag delete tagName ?tagName ...?"}} -test textTag-6.2 {TkTextTagCmd - "delete" option} haveCourier12 { - list [catch {.t tag delete zork} msg] $msg -} {0 {}} -test textTag-6.3 {TkTextTagCmd - "delete" option} haveCourier12 { - .t tag delete x + +test textTag-6.1 {TkTextTagCmd - "delete" option} -constraints { + haveCourier12 +} -body { + .t tag delete +} -returnCodes error -result {wrong # args: should be ".t tag delete tagName ?tagName ...?"} +test textTag-6.2 {TkTextTagCmd - "delete" option} -constraints { + haveCourier12 +} -body { + .t tag delete zork +} -returnCodes ok -result {} +test textTag-6.3 {TkTextTagCmd - "delete" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] +} -body { .t tag config x -background black .t tag config y -foreground white .t tag config z -background black .t tag delete y z lsort [.t tag names] -} {sel x} -test textTag-6.4 {TkTextTagCmd - "delete" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {sel x} +test textTag-6.4 {TkTextTagCmd - "delete" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] +} -body { .t tag config x -background black .t tag config y -foreground white .t tag config z -background black eval .t tag delete [.t tag names] .t tag names -} {sel} -test textTag-6.5 {TkTextTagCmd - "delete" option} haveCourier12 { +} -result {sel} +test textTag-6.5 {TkTextTagCmd - "delete" option} -constraints { + haveCourier12 +} -body { .t tag bind x <Enter> foo .t tag delete x .t tag configure x -background black .t tag bind x -} {} +} -cleanup { + .t tag delete x +} -result {} -proc tagsetup {} { - .t tag delete x y z a b c d + +test textTag-7.1 {TkTextTagCmd - "lower" option} -constraints { + haveCourier12 +} -body { + .t tag lower +} -returnCodes error -result {wrong # args: should be ".t tag lower tagName ?belowThis?"} +test textTag-7.2 {TkTextTagCmd - "lower" option} -constraints { + haveCourier12 +} -body { + .t tag lower foo +} -returnCodes error -result {tag "foo" isn't defined in text widget} +test textTag-7.3 {TkTextTagCmd - "lower" option} -constraints { + haveCourier12 +} -body { + .t tag lower sel bar +} -returnCodes error -result {tag "bar" isn't defined in text widget} +test textTag-7.4 {TkTextTagCmd - "lower" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] .t tag remove sel 1.0 end foreach i {a b c d} { - .t tag configure $i -background black + .t tag configure $i -background black } -} -test textTag-7.1 {TkTextTagCmd - "lower" option} haveCourier12 { - list [catch {.t tag lower} msg] $msg -} {1 {wrong # args: should be ".t tag lower tagName ?belowThis?"}} -test textTag-7.2 {TkTextTagCmd - "lower" option} haveCourier12 { - list [catch {.t tag lower foo} msg] $msg -} {1 {tag "foo" isn't defined in text widget}} -test textTag-7.3 {TkTextTagCmd - "lower" option} haveCourier12 { - list [catch {.t tag lower sel bar} msg] $msg -} {1 {tag "bar" isn't defined in text widget}} -test textTag-7.4 {TkTextTagCmd - "lower" option} haveCourier12 { - tagsetup +} -body { .t tag lower c .t tag names -} {c sel a b d} -test textTag-7.5 {TkTextTagCmd - "lower" option} haveCourier12 { - tagsetup +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {c sel a b d} +test textTag-7.5 {TkTextTagCmd - "lower" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag lower d b .t tag names -} {sel a d b c} -test textTag-7.6 {TkTextTagCmd - "lower" option} haveCourier12 { - tagsetup +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {sel a d b c} +test textTag-7.6 {TkTextTagCmd - "lower" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag lower a c .t tag names -} {sel b a c d} +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {sel b a c d} + -test textTag-8.1 {TkTextTagCmd - "names" option} haveCourier12 { - list [catch {.t tag names a b} msg] $msg -} {1 {wrong # args: should be ".t tag names ?index?"}} -test textTag-8.2 {TkTextTagCmd - "names" option} haveCourier12 { - tagsetup +test textTag-8.1 {TkTextTagCmd - "names" option} -constraints { + haveCourier12 +} -body { + .t tag names a b +} -cleanup { + .t tag delete {*}[.t tag names] +} -returnCodes error -result {wrong # args: should be ".t tag names ?index?"} +test textTag-8.2 {TkTextTagCmd - "names" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag names -} {sel a b c d} -test textTag-8.3 {TkTextTagCmd - "names" option} haveCourier12 { - tagsetup +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {sel a b c d} +test textTag-8.3 {TkTextTagCmd - "names" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag add "a b" 2.1 2.6 .t tag add c 2.4 2.7 .t tag names 2.5 -} {c {a b}} - -.t tag delete x y z a b c d {a b} -.t tag add x 2.3 2.5 -.t tag add x 2.9 3.1 -.t tag add x 7.2 -test textTag-9.1 {TkTextTagCmd - "nextrange" option} haveCourier12 { - list [catch {.t tag nextrange x} msg] $msg -} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test textTag-9.2 {TkTextTagCmd - "nextrange" option} haveCourier12 { - list [catch {.t tag nextrange x 1 2 3} msg] $msg -} {1 {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"}} -test textTag-9.3 {TkTextTagCmd - "nextrange" option} haveCourier12 { - list [catch {.t tag nextrange foo 1.0} msg] $msg -} {0 {}} -test textTag-9.4 {TkTextTagCmd - "nextrange" option} haveCourier12 { - list [catch {.t tag nextrange x foo} msg] $msg -} {1 {bad text index "foo"}} -test textTag-9.5 {TkTextTagCmd - "nextrange" option} haveCourier12 { - list [catch {.t tag nextrange x 1.0 bar} msg] $msg -} {1 {bad text index "bar"}} -test textTag-9.6 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {c {a b}} + + +test textTag-9.1 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -body { + .t tag nextrange x +} -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"} +test textTag-9.2 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -body { + .t tag nextrange x 1 2 3 +} -returnCodes error -result {wrong # args: should be ".t tag nextrange tagName index1 ?index2?"} +test textTag-9.3 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -body { + .t tag nextrange foo 1.0 +} -returnCodes ok -result {} +test textTag-9.4 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag nextrange x foo +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad text index "foo"} +test textTag-9.5 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 + .t tag nextrange x 1.0 bar +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad text index "bar"} +test textTag-9.6 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 1.0 -} {2.3 2.5} -test textTag-9.7 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-9.7 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 2.2 -} {2.3 2.5} -test textTag-9.8 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-9.8 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 2.3 -} {2.3 2.5} -test textTag-9.9 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-9.9 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 2.4 -} {2.9 3.1} -test textTag-9.10 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.9 3.1} +test textTag-9.10 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 2.4 2.9 -} {} -test textTag-9.11 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {} +test textTag-9.11 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 2.4 2.10 -} {2.9 3.1} -test textTag-9.12 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.9 3.1} +test textTag-9.12 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 2.4 2.11 -} {2.9 3.1} -test textTag-9.13 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.9 3.1} +test textTag-9.13 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 7.0 -} {7.2 7.3} -test textTag-9.14 {TkTextTagCmd - "nextrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {7.2 7.3} +test textTag-9.14 {TkTextTagCmd - "nextrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag nextrange x 7.3 -} {} - -test textTag-10.1 {TkTextTagCmd - "prevrange" option} haveCourier12 { - list [catch {.t tag prevrange x} msg] $msg -} {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}} -test textTag-10.2 {TkTextTagCmd - "prevrange" option} haveCourier12 { - list [catch {.t tag prevrange x 1 2 3} msg] $msg -} {1 {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"}} -test textTag-10.3 {TkTextTagCmd - "prevrange" option} haveCourier12 { - list [catch {.t tag prevrange foo end} msg] $msg -} {0 {}} -test textTag-10.4 {TkTextTagCmd - "prevrange" option} haveCourier12 { - list [catch {.t tag prevrange x foo} msg] $msg -} {1 {bad text index "foo"}} -test textTag-10.5 {TkTextTagCmd - "prevrange" option} haveCourier12 { - list [catch {.t tag prevrange x end bar} msg] $msg -} {1 {bad text index "bar"}} -test textTag-10.6 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {} + + +test textTag-10.1 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -body { + .t tag prevrange x +} -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"} +test textTag-10.2 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -body { + .t tag prevrange x 1 2 3 +} -returnCodes error -result {wrong # args: should be ".t tag prevrange tagName index1 ?index2?"} +test textTag-10.3 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag prevrange foo end +} -cleanup { + .t tag delete x +} -returnCodes ok -result {} +test textTag-10.4 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 + .t tag prevrange x foo +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad text index "foo"} +test textTag-10.5 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 + .t tag prevrange x end bar +} -cleanup { + .t tag delete x +} -returnCodes error -result {bad text index "bar"} +test textTag-10.6 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x end -} {7.2 7.3} -test textTag-10.7 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {7.2 7.3} +test textTag-10.7 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.4 -} {2.3 2.5} -test textTag-10.8 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-10.8 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.5 -} {2.3 2.5} -test textTag-10.9 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-10.9 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.9 -} {2.3 2.5} -test textTag-10.10 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-10.10 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.9 2.6 -} {} -test textTag-10.11 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {} +test textTag-10.11 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.9 2.5 -} {} -test textTag-10.12 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {} +test textTag-10.12 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.9 2.3 -} {2.3 2.5} -test textTag-10.13 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.3 2.5} +test textTag-10.13 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 7.0 -} {2.9 3.1} -test textTag-10.14 {TkTextTagCmd - "prevrange" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.9 3.1} +test textTag-10.14 {TkTextTagCmd - "prevrange" option} -constraints { + haveCourier12 +} -setup { + .t tag delete x +} -body { + .t tag add x 2.3 2.5 + .t tag add x 2.9 3.1 + .t tag add x 7.2 .t tag prevrange x 2.3 -} {} - -test textTag-11.1 {TkTextTagCmd - "raise" option} haveCourier12 { - list [catch {.t tag raise} msg] $msg -} {1 {wrong # args: should be ".t tag raise tagName ?aboveThis?"}} -test textTag-11.2 {TkTextTagCmd - "raise" option} haveCourier12 { - list [catch {.t tag raise foo} msg] $msg -} {1 {tag "foo" isn't defined in text widget}} -test textTag-11.3 {TkTextTagCmd - "raise" option} haveCourier12 { - list [catch {.t tag raise sel bar} msg] $msg -} {1 {tag "bar" isn't defined in text widget}} -test textTag-11.4 {TkTextTagCmd - "raise" option} haveCourier12 { - tagsetup +} -cleanup { + .t tag delete x +} -result {} + + +test textTag-11.1 {TkTextTagCmd - "raise" option} -constraints { + haveCourier12 +} -body { + .t tag raise +} -returnCodes error -result {wrong # args: should be ".t tag raise tagName ?aboveThis?"} +test textTag-11.2 {TkTextTagCmd - "raise" option} -constraints { + haveCourier12 +} -body { + .t tag raise foo +} -returnCodes error -result {tag "foo" isn't defined in text widget} +test textTag-11.3 {TkTextTagCmd - "raise" option} -constraints { + haveCourier12 +} -body { + .t tag raise sel bar +} -returnCodes error -result {tag "bar" isn't defined in text widget} +test textTag-11.4 {TkTextTagCmd - "raise" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag raise c .t tag names -} {sel a b d c} -test textTag-11.5 {TkTextTagCmd - "raise" option} haveCourier12 { - tagsetup +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {sel a b d c} +test textTag-11.5 {TkTextTagCmd - "raise" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag raise d b .t tag names -} {sel a b d c} -test textTag-11.6 {TkTextTagCmd - "raise" option} haveCourier12 { - tagsetup +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {sel a b d c} +test textTag-11.6 {TkTextTagCmd - "raise" option} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + .t tag remove sel 1.0 end + foreach i {a b c d} { + .t tag configure $i -background black + } +} -body { .t tag raise a c .t tag names -} {sel b c a d} +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {sel b c a d} -test textTag-12.1 {TkTextTagCmd - "ranges" option} haveCourier12 { - list [catch {.t tag ranges} msg] $msg -} {1 {wrong # args: should be ".t tag ranges tagName"}} -test textTag-12.2 {TkTextTagCmd - "ranges" option} haveCourier12 { + +test textTag-12.1 {TkTextTagCmd - "ranges" option} -constraints { + haveCourier12 +} -body { + .t tag ranges +} -returnCodes error -result {wrong # args: should be ".t tag ranges tagName"} +test textTag-12.2 {TkTextTagCmd - "ranges" option} -constraints { + haveCourier12 +} -body { .t tag delete x .t tag ranges x -} {} -test textTag-12.3 {TkTextTagCmd - "ranges" option} haveCourier12 { +} -result {} +test textTag-12.3 {TkTextTagCmd - "ranges" option} -constraints { + haveCourier12 +} -setup { .t tag delete x +} -body { .t tag add x 2.2 .t tag add x 2.7 4.15 .t tag add x 5.2 5.5 .t tag ranges x -} {2.2 2.3 2.7 4.6 5.2 5.5} -test textTag-12.4 {TkTextTagCmd - "ranges" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.2 2.3 2.7 4.6 5.2 5.5} +test textTag-12.4 {TkTextTagCmd - "ranges" option} -constraints { + haveCourier12 +} -setup { .t tag delete x +} -body { .t tag add x 1.0 3.0 .t tag add x 4.0 end .t tag ranges x -} {1.0 3.0 4.0 8.0} +} -cleanup { + .t tag delete x +} -result {1.0 3.0 4.0 8.0} -test textTag-13.1 {TkTextTagCmd - "remove" option} haveCourier12 { - list [catch {.t tag remove} msg] $msg -} {1 {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"}} -test textTag-13.2 {TkTextTagCmd - "remove" option} haveCourier12 { + +test textTag-13.1 {TkTextTagCmd - "remove" option} -constraints { + haveCourier12 +} -body { + .t tag remove +} -returnCodes error -result {wrong # args: should be ".t tag remove tagName index1 ?index2 index1 index2 ...?"} +test textTag-13.2 {TkTextTagCmd - "remove" option} -constraints { + haveCourier12 +} -setup { .t tag delete x +} -body { .t tag add x 2.2 2.11 .t tag remove x 2.3 2.7 .t tag ranges x -} {2.2 2.3 2.7 2.11} -test textTag-13.3 {TkTextTagCmd - "remove" option} haveCourier12 { +} -cleanup { + .t tag delete x +} -result {2.2 2.3 2.7 2.11} +test textTag-13.3 {TkTextTagCmd - "remove" option} -constraints { + haveCourier12 +} -setup { + destroy .t.e +} -body { + entry .t.e + .t.e insert 0 "Text" .t configure -exportselection 1 .t tag remove sel 1.0 end .t tag add sel 2.4 3.3 .t.e select to 4 .t tag remove sel 2.7 3.1 selection get -} Text +} -cleanup { + destroy .t.e +} -result {Text} -.t tag delete x a b c d -test textTag-14.1 {SortTags} haveCourier12 { + +test textTag-14.1 {SortTags} -constraints haveCourier12 -setup { + .t tag delete a b c d +} -body { foreach i {a b c d} { - .t tag add $i 2.0 2.2 + .t tag add $i 2.0 2.2 } .t tag names 2.1 -} {a b c d} +} -cleanup { + .t tag delete a b c d +} -result {a b c d} .t tag delete a b c d -test textTag-14.2 {SortTags} haveCourier12 { +test textTag-14.2 {SortTags} -constraints haveCourier12 -setup { + .t tag delete a b c d +} -body { foreach i {a b c d} { - .t tag configure $i -background black + .t tag configure $i -background black } foreach i {d c b a} { - .t tag add $i 2.0 2.2 + .t tag add $i 2.0 2.2 } .t tag names 2.1 -} {a b c d} -.t tag delete x a b c d -test textTag-14.3 {SortTags} haveCourier12 { +} -cleanup { + .t tag delete a b c d +} -result {a b c d} +test textTag-14.3 {SortTags} -constraints haveCourier12 -setup { + .t tag delete {*}[.t tag names] +} -body { for {set i 0} {$i < 30} {incr i} { - .t tag add x$i 2.0 2.2 + .t tag add x$i 2.0 2.2 } .t tag names 2.1 -} {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} -test textTag-14.4 {SortTags} haveCourier12 { +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} +test textTag-14.4 {SortTags} -constraints haveCourier12 -setup { + .t tag delete {*}[.t tag names] +} -body { for {set i 0} {$i < 30} {incr i} { - .t tag configure x$i -background black + .t tag configure x$i -background black } for {set i 29} {$i >= 0} {incr i -1} { - .t tag add x$i 2.0 2.2 + .t tag add x$i 2.0 2.2 } .t tag names 2.1 -} {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29} + + -foreach tag [.t tag names] { - catch {.t tag delete $tag} -} set c [.t bbox 2.1] set x1 [expr [lindex $c 0] + [lindex $c 2]/2] set y1 [expr [lindex $c 1] + [lindex $c 3]/2] @@ -585,7 +1333,10 @@ set c [.t bbox 4.3] set x3 [expr [lindex $c 0] + [lindex $c 2]/2] set y3 [expr [lindex $c 1] + [lindex $c 3]/2] -test textTag-15.1 {TkTextBindProc} haveCourier12 { +test textTag-15.1 {TkTextBindProc} -constraints haveCourier12 -setup { + .t tag delete x y + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { bind .t <ButtonRelease> {lappend x up} .t tag bind x <ButtonRelease> {lappend x x-up} .t tag bind y <ButtonRelease> {lappend x y-up} @@ -601,12 +1352,16 @@ test textTag-15.1 {TkTextBindProc} haveCourier12 { event gen .t <Button> -x $x2 -y $y2 event gen .t <Motion> -x $x3 -y $y3 event gen .t <ButtonRelease> -x $x3 -y $y3 + return $x +} -cleanup { + .t tag delete x y bind .t <ButtonRelease> {} - set x -} {x-up up up y-up up} -test textTag-15.2 {TkTextBindProc} haveCourier12 { - catch {.t tag delete x} - catch {.t tag delete y} +} -result {x-up up up y-up up} + +test textTag-15.2 {TkTextBindProc} -constraints haveCourier12 -setup { + .t tag delete x y + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { .t tag bind x <Enter> {lappend x x-enter} .t tag bind x <ButtonPress> {lappend x x-down} .t tag bind x <ButtonRelease> {lappend x x-up} @@ -626,11 +1381,15 @@ test textTag-15.2 {TkTextBindProc} haveCourier12 { event gen .t <Motion> -x $x3 -y $y3 -state 0x100 lappend x | event gen .t <ButtonRelease> -x $x3 -y $y3 - set x -} {x-enter | x-down | | x-up x-leave y-enter} -test textTag-15.3 {TkTextBindProc} haveCourier12 { - catch {.t tag delete x} - catch {.t tag delete y} + return $x +} -cleanup { + .t tag delete x y +} -result {x-enter | x-down | | x-up x-leave y-enter} + +test textTag-15.3 {TkTextBindProc} -constraints haveCourier12 -setup { + .t tag delete x y + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { .t tag bind x <Enter> {lappend x x-enter} .t tag bind x <Any-ButtonPress-1> {lappend x x-down} .t tag bind x <Any-ButtonRelease-1> {lappend x x-up} @@ -654,14 +1413,18 @@ test textTag-15.3 {TkTextBindProc} haveCourier12 { event gen .t <ButtonRelease-1> -x $x3 -y $y3 -state 0x300 lappend x | event gen .t <ButtonRelease-2> -x $x3 -y $y3 -state 0x200 - set x -} {x-enter | x-down | | | x-up | x-leave y-enter} - -foreach tag [.t tag names] { - catch {.t tag delete $tag} -} -.t tag configure big -font $bigFont -test textTag-16.1 {TkTextPickCurrent procedure} haveCourier12 { + return $x +} -cleanup { + .t tag delete x y +} -result {x-enter | x-down | | | x-up | x-leave y-enter} + + +test textTag-16.1 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 set x [.t index current] event gen .t <Motion> -x $x2 -y $y2 @@ -676,23 +1439,36 @@ test textTag-16.1 {TkTextPickCurrent procedure} haveCourier12 { lappend x [.t index current] event gen .t <ButtonRelease-1> -state 0x100 -x $x3 -y $y3 lappend x [.t index current] -} {2.1 3.2 3.2 3.2 3.2 3.2 4.3} -test textTag-16.2 {TkTextPickCurrent procedure} haveCourier12 { +} -result {2.1 3.2 3.2 3.2 3.2 3.2 4.3} + +test textTag-16.2 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { + .t tag delete {*}[.t tag names] + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { + .t tag configure big -font $bigFont event gen .t <ButtonRelease-1> -state 0x100 -x $x1 -y $y1 event gen .t <Motion> -x $x2 -y $y2 set x [.t index current] .t tag add big 3.0 update lappend x [.t index current] -} {3.2 3.1} -.t tag remove big 1.0 end -foreach i {a b c d} { - .t tag bind $i <Enter> "lappend x enter-$i" - .t tag bind $i <Leave> "lappend x leave-$i" -} -test textTag-16.3 {TkTextPickCurrent procedure} haveCourier12 { +} -cleanup { + .t tag delete big +} -result {3.2 3.1} + +test textTag-16.3 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { + foreach i {a b c d} { + .t tag remove $i 1.0 end + } + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { foreach i {a b c d} { - .t tag remove $i 1.0 end + .t tag bind $i <Enter> "lappend x enter-$i" + .t tag bind $i <Leave> "lappend x leave-$i" } .t tag lower b .t tag lower a @@ -706,11 +1482,22 @@ test textTag-16.3 {TkTextPickCurrent procedure} haveCourier12 { event gen .t <Motion> -x $x2 -y $y2 lappend x | event gen .t <Motion> -x $x3 -y $y3 - set x -} {enter-a enter-b | leave-b enter-c | leave-a leave-c} -test textTag-16.4 {TkTextPickCurrent procedure} haveCourier12 { + return $x +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {enter-a enter-b | leave-b enter-c | leave-a leave-c} + +test textTag-16.4 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { foreach i {a b c d} { - .t tag remove $i 1.0 end + .t tag remove $i 1.0 end + } + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { + foreach i {a b c d} { + .t tag bind $i <Enter> "lappend x enter-$i" + .t tag bind $i <Leave> "lappend x leave-$i" } .t tag lower b .t tag lower a @@ -723,55 +1510,86 @@ test textTag-16.4 {TkTextPickCurrent procedure} haveCourier12 { lappend x | .t tag lower c event gen .t <Motion> -x $x2 -y $y2 - set x -} {enter-a enter-b enter-c | leave-c leave-b} -foreach i {a b c d} { - .t tag delete $i -} -test textTag-16.5 {TkTextPickCurrent procedure} haveCourier12 { - foreach i {a b c d} { - .t tag remove $i 1.0 end + return $x +} -cleanup { + .t tag delete {*}[.t tag names] +} -result {enter-a enter-b enter-c | leave-c leave-b} + +test textTag-16.5 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { + foreach i {big a b c d} { + .t tag remove $i 1.0 end } + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { + .t tag configure big -font $bigFont event gen .t <Motion> -x $x1 -y $y1 .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 event gen .t <Motion> -x $x2 -y $y2 .t index current -} {3.2} -test textTag-16.6 {TkTextPickCurrent procedure} haveCourier12 { - foreach i {a b c d} { - .t tag remove $i 1.0 end +} -cleanup { + .t tag delete a big +} -result {3.2} + +test textTag-16.6 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { + foreach i {big a b c d} { + .t tag remove $i 1.0 end } + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { + .t tag configure big -font $bigFont event gen .t <Motion> -x $x1 -y $y1 .t tag bind a <Enter> {.t tag add big 3.0 3.2} .t tag add a 3.2 event gen .t <Motion> -x $x2 -y $y2 update .t index current -} {3.1} -test textTag-16.7 {TkTextPickCurrent procedure} haveCourier12 { - foreach i {a b c d} { - .t tag remove $i 1.0 end +} -cleanup { + .t tag delete a big +} -result {3.1} + +test textTag-16.7 {TkTextPickCurrent procedure} -constraints { + haveCourier12 +} -setup { + foreach i {big a b c d} { + .t tag remove $i 1.0 end } + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { + .t tag configure big -font $bigFont + .t tag bind a <Enter> {.t tag add big 3.0 3.2} + .t tag add a 3.2 + event gen .t <Motion> -x $x1 -y $y1 .t tag bind a <Leave> {.t tag add big 3.0 3.2} .t tag add a 2.1 event gen .t <Motion> -x $x2 -y $y2 + update .t index current -} {3.1} +} -cleanup { + .t tag delete a big +} -result {3.1} + -test textTag-17.1 {insert procedure inserts tags} { +test textTag-17.1 {insert procedure inserts tags} -setup { .t delete 1.0 end +} -body { # Objectification of the text widget had a problem # with inserting tags when using 'end'. Check that # bug has been fixed. .t insert end abcd {x} \n {} efgh {y} \n {} .t dump -tag 1.0 end -} {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4} +} -result {tagon x 1.0 tagoff x 1.4 tagon y 2.0 tagoff y 2.4} -catch {destroy .t} -test textTag-18.1 {TkTextPickCurrent tag bindings} { +test textTag-18.1 {TkTextPickCurrent tag bindings} -setup { + destroy .t + event generate {} <Motion> -warp 1 -x -1 -y -1; update +} -body { text .t -width 30 -height 4 -relief sunken -borderwidth 10 \ -highlightthickness 10 -pady 2 pack .t @@ -792,10 +1610,12 @@ test textTag-18.1 {TkTextPickCurrent tag bindings} { event gen .t <Motion> -warp 1 -x 20 -y 20 ; update event gen .t <Motion> -warp 1 -x 10 -y 10 ; update event gen .t <Motion> -warp 1 -x 25 -y 25 ; update - set res -} {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}} + return $res +} -cleanup { + destroy .t +} -result {Enter {25 25 tag-Enter} {20 20 tag-Leave} {25 25 tag-Enter}} -catch {destroy .t} +destroy .t # cleanup cleanupTests diff --git a/tests/textWind.test b/tests/textWind.test index 79dca50..c3483e6 100644 --- a/tests/textWind.test +++ b/tests/textWind.test @@ -6,8 +6,9 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands # Create entries in the option database to be sure that geometry options @@ -17,26 +18,21 @@ option add *Text.borderWidth 2 option add *Text.highlightThickness 2 option add *Text.font {Courier -12} -set fixedFont {Courier -12} -# 15 on XP, 13 on Solaris 8 -set fixedHeight [font metrics $fixedFont -linespace] -# 7 on all platforms -set fixedWidth [font measure $fixedFont m] -# 12 on XP -set fixedAscent [font metrics $fixedFont -ascent] -set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP - -catch {destroy .f} -catch {destroy .t} -catch {destroy .t2} +deleteWindows +# Widget used in tests 1.* - 16.* text .t -width 30 -height 6 -bd 2 -highlightthickness 2 pack append . .t {top expand fill} update .t debug on -wm geometry . {} + +# 15 on XP, 13 on Solaris 8 +set fixedHeight [font metrics {Courier -12} -linespace] +set fixedDiff [expr {$fixedHeight - 13}] ;# 2 on XP set color [expr {[winfo depth .t] > 1 ? "green" : "black"}] - + +wm geometry . {} + # The statements below reset the main window; it's needed if the window # manager is mwm to make mwm forget about a previous minimum size setting. @@ -45,206 +41,323 @@ wm minsize . 1 1 wm positionfrom . user wm deiconify . -test textWind-1.1 {basic tests of options} {fonts} { +# ---------------------------------------------------------------------- + +test textWind-1.1 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 3 -height 3 -bg $color .t window create 2.2 -window .f update list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \ - [.t window configure .f -window] -} {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}} -test textWind-1.2 {basic tests of options} {fonts} { + [.t window configure .f -window] +} -result {1 3x3+19+23 {19 23 3 3} {-window {} {} {} .f}} +test textWind-1.2 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 3 -height 3 -bg $color .t window create 2.2 -window .f -align top update list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] \ - [.t window configure .f -align] -} {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}} -test textWind-1.3 {basic tests of options} { + [.t window configure .f -align] +} -result {1 3x3+19+18 {19 18 3 3} {-align {} {} center top}} +test textWind-1.3 {basic tests of options} -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" .t window create 2.2 -create "Test script" .t window configure 2.2 -create -} {-create {} {} {} {Test script}} -test textWind-1.4 {basic tests of options} {fonts} { +} -result {-create {} {} {} {Test script}} +test textWind-1.4 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 20 -bg $color .t window create 2.2 -window .f -padx 5 update list [winfo geom .f] [.t window configure .f -padx] [.t bbox 2.3] -} {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}} -test textWind-1.5 {basic tests of options} {fonts} { +} -result {10x20+24+18 {-padx {} {} 0 5} {39 21 7 13}} +test textWind-1.5 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 20 -bg $color .t window create 2.2 -window .f -pady 4 update list [winfo geom .f] [.t window configure .f -pady] [.t bbox 2.31] -} {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}} -test textWind-1.6 {basic tests of options} {fonts} { +} -result {10x20+19+22 {-pady {} {} 0 4} {19 46 7 13}} +test textWind-1.6 {basic tests of options} -constraints fonts -setup { .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 5 -height 5 -bg $color .t window create 2.2 -window .f -stretch 1 update list [winfo geom .f] [.t window configure .f -stretch] -} {5x13+19+18 {-stretch {} {} 0 1}} +} -result {5x13+19+18 {-stretch {} {} 0 1}} + .t delete 1.0 end .t insert end "This is the first line" -frame .f -width 10 -height 6 -bg $color -.t window create 1.3 -window .f -padx 1 -pady 2 -test textWind-2.1 {TkTextWindowCmd procedure} { - list [catch {.t window} msg] $msg -} {1 {wrong # args: should be ".t window option ?arg arg ...?"}} -test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget} msg] $msg -} {1 {wrong # args: should be ".t window cget index option"}} -test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget a b c} msg] $msg -} {1 {wrong # args: should be ".t window cget index option"}} -test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget gorp -padx} msg] $msg -} {1 {bad text index "gorp"}} -test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget 1.2 -padx} msg] $msg -} {1 {no embedded window at index "1.2"}} -test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget .f -bogus} msg] $msg -} {1 {unknown option "-bogus"}} -test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} { - list [catch {.t window cget .f -pady} msg] $msg -} {0 2} -test textWind-2.8 {TkTextWindowCmd procedure} { - list [catch {.t window co} msg] $msg -} {1 {wrong # args: should be ".t window configure index ?option value ...?"}} -test textWind-2.9 {TkTextWindowCmd procedure} { - list [catch {.t window configure gorp} msg] $msg -} {1 {bad text index "gorp"}} -test textWind-2.10 {TkTextWindowCmd procedure} { - .t delete 1.0 end - list [catch {.t window configure 1.0} msg] $msg -} {1 {no embedded window at index "1.0"}} -test textWind-2.11 {TkTextWindowCmd procedure} { +test textWind-2.1 {TkTextWindowCmd procedure} -body { + .t window +} -returnCodes error -result {wrong # args: should be ".t window option ?arg ...?"} +test textWind-2.2 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget +} -returnCodes error -result {wrong # args: should be ".t window cget index option"} +test textWind-2.3 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget a b c +} -returnCodes error -result {wrong # args: should be ".t window cget index option"} +test textWind-2.4 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget gorp -padx +} -returnCodes error -result {bad text index "gorp"} +test textWind-2.5 {TkTextWindowCmd procedure, "cget" option} -body { + .t window cget 1.2 -padx +} -returnCodes error -result {no embedded window at index "1.2"} +test textWind-2.6 {TkTextWindowCmd procedure, "cget" option} -setup { + destroy .f +} -body { + frame .f -width 10 -height 6 -bg $color + .t window create 1.3 -window .f -padx 1 -pady 2 + .t window cget .f -bogus +} -cleanup { + destroy .f +} -returnCodes error -result {unknown option "-bogus"} +test textWind-2.7 {TkTextWindowCmd procedure, "cget" option} -setup { + destroy .f +} -body { + frame .f -width 10 -height 6 -bg $color + .t window create 1.3 -window .f -padx 1 -pady 2 + .t window cget .f -pady +} -cleanup { + destroy .f +} -returnCodes ok -result {2} +test textWind-2.8 {TkTextWindowCmd procedure} -body { + .t window co +} -returnCodes error -result {wrong # args: should be ".t window configure index ?-option value ...?"} +test textWind-2.9 {TkTextWindowCmd procedure} -body { + .t window configure gorp +} -returnCodes error -result {bad text index "gorp"} +test textWind-2.10 {TkTextWindowCmd procedure} -body { + .t delete 1.0 end + .t window configure 1.0 +} -returnCodes error -result {no embedded window at index "1.0"} +test textWind-2.11 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 1.3 -window .f -padx 1 -pady 2 .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 6 -bg $color .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo update - list [catch {.t window configure .f} msg] $msg -} {0 {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}}} -test textWind-2.12 {TkTextWindowCmd procedure} { + .t window configure .f +} -cleanup { + destroy .f +} -result {{-align {} {} center baseline} {-create {} {} {} foo} {-padx {} {} 0 1} {-pady {} {} 0 2} {-stretch {} {} 0 0} {-window {} {} {} .f}} +test textWind-2.12 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 6 -bg $color .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo update list [.t window configure .f -padx 33] [.t window configure .f -padx] -} {{} {-padx {} {} 0 33}} -test textWind-2.13 {TkTextWindowCmd procedure} { +} -cleanup { + destroy .f +} -result {{} {-padx {} {} 0 33}} +test textWind-2.13 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 -create foo .t delete 1.0 end +} -body { .t insert end "This is the first line" .t insert end "\nAnd this is a second line, which wraps around" frame .f -width 10 -height 6 -bg $color .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 update list [.t window configure .f -padx 14 -pady 15] \ - [.t window configure .f -padx] [.t window configure .f -pady] -} {{} {-padx {} {} 0 14} {-pady {} {} 0 15}} -test textWind-2.14 {TkTextWindowCmd procedure} { - list [catch {.t window create} msg] $msg -} {1 {wrong # args: should be ".t window create index ?option value ...?"}} -test textWind-2.15 {TkTextWindowCmd procedure} { - list [catch {.t window create gorp} msg] $msg -} {1 {bad text index "gorp"}} -test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} { + [.t window configure .f -padx] [.t window configure .f -pady] +} -cleanup { + destroy .f +} -result {{} {-padx {} {} 0 14} {-pady {} {} 0 15}} +test textWind-2.14 {TkTextWindowCmd procedure} -setup { + .t delete 1.0 end +} -body { + .t window create +} -returnCodes error -result {wrong # args: should be ".t window create index ?-option value ...?"} +test textWind-2.15 {TkTextWindowCmd procedure} -setup { + .t delete 1.0 end +} -body { + .t window create gorp +} -returnCodes error -result {bad text index "gorp"} +test textWind-2.16 {TkTextWindowCmd procedure, don't insert after end} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 10 -height 6 -bg $color + .t window create 2.2 -window .f -align baseline -padx 1 -pady 2 .t delete 1.0 end +} -body { .t insert end "Line 1\nLine 2" frame .f -width 20 -height 10 -bg $color .t window create end -window .f .t index .f -} {2.6} -test textWind-2.17 {TkTextWindowCmd procedure} { +} -result {2.6} +test textWind-2.17 {TkTextWindowCmd procedure} -setup { .t delete 1.0 end +} -body { list [catch {.t window create 1.0} msg] $msg [.t window configure 1.0] -} {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}} -test textWind-2.18 {TkTextWindowCmd procedure} { +} -result {0 {} {{-align {} {} center center} {-create {} {} {} {}} {-padx {} {} 0 0} {-pady {} {} 0 0} {-stretch {} {} 0 0} {-window {} {} {} {}}}} +test textWind-2.18 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 20 -height 10 -bg $color + .t window create end -window .f + .t delete 1.0 end +} -body { + frame .f -width 10 -height 6 -bg $color + .t window create 1.0 -window .f -gorp stupid +} -returnCodes error -result {unknown option "-gorp"} +test textWind-2.19 {TkTextWindowCmd procedure} -setup { +# I kept this as it "influenced" the test case in previous releases + destroy .f + frame .f -width 20 -height 10 -bg $color + .t window create end -window .f + .t delete 1.0 end +} -body { + frame .f -width 10 -height 6 -bg $color + catch {.t window create 1.0 -window .f -gorp stupid} + list [winfo exists .f] [.t index 1.end] [catch {.t index .f}] +} -result {0 1.0 1} +test textWind-2.20 {TkTextWindowCmd procedure} -setup { .t delete 1.0 end + destroy .f +} -body { frame .f -width 10 -height 6 -bg $color - list [catch {.t window create 1.0 -window .f -gorp stupid} msg] $msg \ - [winfo exists .f] [.t index 1.end] [catch {.t index .f}] -} {1 {unknown option "-gorp"} 0 1.0 1} -test textWind-2.19 {TkTextWindowCmd procedure} { + .t window create 1.0 -gorp -window .f stupid +} -returnCodes error -result {unknown option "-gorp"} +test textWind-2.21 {TkTextWindowCmd procedure} -setup { .t delete 1.0 end - catch {destroy .f} + destroy .f +} -body { frame .f -width 10 -height 6 -bg $color - list [catch {.t window create 1.0 -gorp -window .f stupid} msg] $msg \ - [winfo exists .f] [.t index 1.end] [catch {.t index .f}] -} {1 {unknown option "-gorp"} 1 1.0 1} -test textWind-2.20 {TkTextWindowCmd procedure} { - list [catch {.t window c} msg] $msg -} {1 {ambiguous window option "c": must be cget, configure, create, or names}} + catch {.t window create 1.0 -gorp -window .f stupid} + list [winfo exists .f] [.t index 1.end] [catch {.t index .f}] +} -result {1 1.0 1} +test textWind-2.22 {TkTextWindowCmd procedure} -setup { + .t delete 1.0 end +} -body { + .t window c +} -returnCodes error -result {ambiguous window option "c": must be cget, configure, create, or names} destroy .f -test textWind-2.21 {TkTextWindowCmd procedure, "names" option} { - list [catch {.t window names foo} msg] $msg -} {1 {wrong # args: should be ".t window names"}} -test textWind-2.22 {TkTextWindowCmd procedure, "names" option} { +test textWind-2.23 {TkTextWindowCmd procedure, "names" option} -setup { + .t delete 1.0 end +} -body { + .t window names foo +} -returnCodes error -result {wrong # args: should be ".t window names"} +test textWind-2.24 {TkTextWindowCmd procedure, "names" option} -setup { .t delete 1.0 end +} -body { .t window names -} {} -test textWind-2.23 {TkTextWindowCmd procedure, "names" option} { +} -result {} +test textWind-2.25 {TkTextWindowCmd procedure, "names" option} -setup { .t delete 1.0 end + destroy .f .f2 .t.f .t.f2 +} -body { foreach i {.f .f2 .t.f .t.f2} { - frame $i -width 20 -height 20 - .t window create end -window $i + frame $i -width 20 -height 20 + .t window create end -window $i } - set result [.t window names] + lsort [.t window names] +} -cleanup { destroy .f .f2 .t.f .t.f2 - lsort $result -} {.f .f2 .t.f .t.f2} +} -result {.f .f2 .t.f .t.f2} -test textWind-3.1 {EmbWinConfigure procedure} { - .t delete 1.0 end + +test textWind-3.1 {EmbWinConfigure procedure} -setup { + destroy .f +} -body { frame .f -width 10 -height 6 -bg $color .t window create 1.0 -window .f - list [catch {.t window configure 1.0 -foo bar} msg] $msg -} {1 {unknown option "-foo"}} -test textWind-3.2 {EmbWinConfigure procedure} {fonts} { - .t delete 1.0 end + .t window configure 1.0 -foo bar +} -cleanup { + destroy .f +} -returnCodes error -result {unknown option "-foo"} +test textWind-3.2 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.3 -window .f update .t window configure 1.3 -window {} update - list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4] -} {1 {bad text index ".f"} 0 {26 5 7 13}} -catch {destroy .f} -test textWind-3.3 {EmbWinConfigure procedure} {fonts} { - .t delete 1.0 end + .t index .f +} -cleanup { + destroy .f +} -returnCodes error -result {bad text index ".f"} +test textWind-3.3 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .f +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.3 -window .f + update + .t window configure 1.3 -window {} + update + catch {.t index .f} + list [winfo ismapped .f] [.t bbox 1.4] +} -cleanup { + destroy .f +} -result {0 {26 5 7 13}} +test textWind-3.4 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .t.f +} -body { .t insert 1.0 "Some sample text" frame .t.f -width 10 -height 20 -bg $color .t window create 1.3 -window .t.f update .t window configure 1.3 -window {} update - list [catch {.t index .t.f} msg] $msg [winfo ismapped .t.f] [.t bbox 1.4] -} {1 {bad text index ".t.f"} 0 {26 5 7 13}} -catch {destroy .t.f} -test textWind-3.4 {EmbWinConfigure procedure} {fonts} { - .t delete 1.0 end + .t index .t.f +} -cleanup { + destroy .t.f +} -returnCodes error -result {bad text index ".t.f"} +test textWind-3.5 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .t.f +} -body { + .t insert 1.0 "Some sample text" + frame .t.f -width 10 -height 20 -bg $color + .t window create 1.3 -window .t.f + update + .t window configure 1.3 -window {} + update + catch {.t index .t.f} + list [winfo ismapped .t.f] [.t bbox 1.4] +} -cleanup { + destroy .t.f +} -result {0 {26 5 7 13}} +test textWind-3.6 {EmbWinConfigure procedure} -constraints fonts -setup { + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.3 @@ -252,89 +365,143 @@ test textWind-3.4 {EmbWinConfigure procedure} {fonts} { .t window configure 1.3 -window .f update list [catch {.t index .f} msg] $msg [winfo ismapped .f] [.t bbox 1.4] -} {0 1.3 1 {36 8 7 13}} -test textWind-3.5 {EmbWinConfigure procedure} { - .t delete 1.0 end +} -cleanup { + destroy .f +} -result {0 1.3 1 {36 8 7 13}} +test textWind-3.7 {EmbWinConfigure procedure} -setup { + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f frame .f.f -width 15 -height 20 -bg $color pack .f.f - list [catch {.t window create 1.3 -window .f.f} msg] $msg -} {1 {can't embed .f.f in .t}} -catch {destroy .f} -test textWind-3.6 {EmbWinConfigure procedure} { - .t delete 1.0 end + .t window create 1.3 -window .f.f +} -cleanup { + destroy .f +} -returnCodes error -result {can't embed .f.f in .t} +test textWind-3.8 {EmbWinConfigure procedure} -setup { + destroy .t2 +} -body { .t insert 1.0 "Some sample text" toplevel .t2 -width 20 -height 10 -bg $color .t window create 1.3 - list [catch {.t window configure 1.3 -window .t2} msg] $msg \ - [.t window configure 1.3 -window] -} {1 {can't embed .t2 in .t} {-window {} {} {} {}}} -catch {destroy .t2} -test textWind-3.7 {EmbWinConfigure procedure} { - .t delete 1.0 end + .t window configure 1.3 -window .t2 +} -cleanup { + destroy .t2 +} -returnCodes error -result {can't embed .t2 in .t} +test textWind-3.9 {EmbWinConfigure procedure} -setup { + destroy .t2 +} -body { + .t insert 1.0 "Some sample text" + toplevel .t2 -width 20 -height 10 -bg $color + .t window create 1.3 + catch {.t window configure 1.3 -window .t2} + .t window configure 1.3 -window +} -cleanup { + destroy .t2 +} -result {-window {} {} {} {}} +test textWind-3.10 {EmbWinConfigure procedure} -setup { + .t delete 1.0 end +} -body { .t insert 1.0 "Some sample text" .t window create 1.3 - list [catch {.t window configure 1.3 -window .t} msg] $msg -} {1 {can't embed .t in .t}} -test textWind-3.8 {EmbWinConfigure procedure} { + .t window configure 1.3 -window .t +} -returnCodes error -result {can't embed .t in .t} +test textWind-3.11 {EmbWinConfigure procedure} -setup { + .t delete 1.0 end +} -body { # This test checks for various errors when the text claims # a window away from itself. - .t delete 1.0 end .t insert 1.0 "Some sample text" button .t.b -text "Hello!" .t window create 1.4 -window .t.b .t window create 1.6 -window .t.b update .t index .t.b -} {1.6} +} -result {1.6} + .t delete 1.0 end frame .f -width 10 -height 20 -bg $color .t window create 1.0 -window .f -test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} { +test textWind-4.1 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align baseline .t window configure 1.0 -align -} {-align {} {} center baseline} -test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center baseline} +test textWind-4.2 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align bottom .t window configure 1.0 -align -} {-align {} {} center bottom} -test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center bottom} +test textWind-4.3 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align center .t window configure 1.0 -align -} {-align {} {} center center} -test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center center} +test textWind-4.4 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align top .t window configure 1.0 -align -} {-align {} {} center top} -test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} { +} -result {-align {} {} center top} +test textWind-4.5 {AlignParseProc and AlignPrintProc procedures} -body { + .t window configure 1.0 -align top + .t window configure 1.0 -align gorp +} -returnCodes error -result {bad align "gorp": must be baseline, bottom, center, or top} +test textWind-4.6 {AlignParseProc and AlignPrintProc procedures} -body { .t window configure 1.0 -align top - list [catch {.t window configure 1.0 -align gorp} msg] $msg \ - [.t window configure 1.0 -align] -} {1 {bad align "gorp": must be baseline, bottom, center, or top} {-align {} {} center top}} + catch {.t window configure 1.0 -align gorp} + .t window configure 1.0 -align +} -result {-align {} {} center top} + -test textWind-5.1 {EmbWinStructureProc procedure} {fonts} { +test textWind-5.1 {EmbWinStructureProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f update destroy .f - list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] -} {1 {bad text index ".f"} {19 11 0 0} {19 5 7 13}} -test textWind-5.2 {EmbWinStructureProc procedure} {fonts} { + .t index .f +} -returnCodes error -result {bad text index ".f"} +test textWind-5.2 {EmbWinStructureProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + update + destroy .f + catch {.t index .f} + list [.t bbox 1.2] [.t bbox 1.3] +} -result {{19 11 0 0} {19 5 7 13}} +test textWind-5.3 {EmbWinStructureProc procedure} -constraints fonts -setup { + .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -align bottom .t window configure 1.2 -window .f update destroy .f - list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] -} {1 {bad text index ".f"} {19 18 0 0} {19 5 7 13}} -test textWind-5.3 {EmbWinStructureProc procedure} {fonts} { + .t index .f +} -returnCodes error -result {bad text index ".f"} +test textWind-5.4 {EmbWinStructureProc procedure} -constraints fonts -setup { + .t delete 1.0 end +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -align bottom + .t window configure 1.2 -window .f + update + destroy .f + catch {.t index .f} + list [.t bbox 1.2] [.t bbox 1.3] +} -result {{19 18 0 0} {19 5 7 13}} +test textWind-5.5 {EmbWinStructureProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" .t window create 1.2 -create {frame .f -width 10 -height 20 -bg $color} update @@ -342,21 +509,31 @@ test textWind-5.3 {EmbWinStructureProc procedure} {fonts} { destroy .f update list [catch {.t index .f} msg] $msg [.t bbox 1.2] [.t bbox 1.3] -} {0 1.2 {19 6 20 10} {39 5 7 13}} +} -result {0 1.2 {19 6 20 10} {39 5 7 13}} + -test textWind-6.1 {EmbWinRequestProc procedure} {fonts} { +test textWind-6.1 {EmbWinRequestProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f + set result {} +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f - set result {} lappend result [.t bbox 1.2] [.t bbox 1.3] .f configure -width 25 -height 30 lappend result [.t bbox 1.2] [.t bbox 1.3] -} {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}} +} -cleanup { + destroy .f +} -result {{19 5 10 20} {29 8 7 13} {19 5 25 30} {44 13 7 13}} -test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} { + +test textWind-7.1 {EmbWinLostSlaveProc procedure} -constraints { + textfonts +} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f @@ -364,9 +541,15 @@ test textWind-7.1 {EmbWinLostSlaveProc procedure} {textfonts} { place .f -in .t -x 100 -y 50 update list [winfo geom .f] [.t bbox 1.2] -} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} { +} -cleanup { + destroy .f +} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-7.2 {EmbWinLostSlaveProc procedure} -constraints { + textfonts +} -setup { .t delete 1.0 end + destroy .t.f +} -body { .t insert 1.0 "Some sample text" frame .t.f -width 10 -height 20 -bg $color .t window create 1.2 -window .t.f @@ -374,76 +557,124 @@ test textWind-7.2 {EmbWinLostSlaveProc procedure} {textfonts} { place .t.f -x 100 -y 50 update list [winfo geom .t.f] [.t bbox 1.2] -} [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] -catch {destroy .f} -catch {destroy .t.f} +} -cleanup { + destroy .t.f +} -result [list 10x20+105+55 [list 19 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-8.1 {EmbWinDeleteProc procedure} {fonts} { + +test textWind-8.1 {EmbWinDeleteProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 10 -height 20 -bg $color .t window create 1.2 -window .f bind .f <Destroy> {set x destroyed} set x XXX .t delete 1.2 - list $x [.t bbox 1.2] [.t bbox 1.3] [catch {.t index .f} msg] $msg \ - [winfo exists .f] -} {destroyed {19 5 7 13} {26 5 7 13} 1 {bad text index ".f"} 0} + list $x [.t bbox 1.2] [.t bbox 1.3] [winfo exists .f] +} -result {destroyed {19 5 7 13} {26 5 7 13} 0} +test textWind-8.2 {EmbWinDeleteProc procedure} -constraints fonts -setup { + .t delete 1.0 end + destroy .f +} -body { + .t insert 1.0 "Some sample text" + frame .f -width 10 -height 20 -bg $color + .t window create 1.2 -window .f + bind .f <Destroy> {set x destroyed} + set x XXX + .t delete 1.2 + .t index .f +} -returnCodes error -result {bad text index ".f"} -test textWind-9.1 {EmbWinCleanupProc procedure} { + +test textWind-9.1 {EmbWinCleanupProc procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text\nA second line." frame .f -width 10 -height 20 -bg $color .t window create 2.3 -window .f .t delete 1.5 2.1 .t index .f -} 1.7 +} -cleanup { + destroy .f +} -result {1.7} -proc bgerror args { - global msg - set msg $args -} -test textWind-10.1 {EmbWinLayoutProc procedure} { +test textWind-10.1 {EmbWinLayoutProc procedure} -setup { .t delete 1.0 end - .t insert 1.0 "Some sample text" destroy .f +} -body { + .t insert 1.0 "Some sample text" .t window create 1.5 -create { - frame .f -width 10 -height 20 -bg $color + frame .f -width 10 -height 20 -bg $color } update list [winfo exists .f] [winfo width .f] [winfo height .f] [.t index .f] -} {1 10 20 1.5} -test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} {fonts} { - .t delete 1.0 end +} -cleanup { + destroy .f +} -result {1 10 20 1.5} +test textWind-10.2 {EmbWinLayoutProc procedure, error in creating window} -constraints { + fonts +} -setup { + .t delete 1.0 end + proc bgerror args { + global msg + set msg $args + } +} -body { .t insert 1.0 "Some sample text" - .t window create 1.5 -create { - error "couldn't create window" + .t window create 1.5 -create { + error "couldn't create window" } set msg xyzzy update list $msg [.t bbox 1.5] -} {{{couldn't create window}} {40 11 0 0}} -test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} {fonts} { - .t delete 1.0 end +} -cleanup { + rename bgerror {} +} -result {{{couldn't create window}} {40 11 0 0}} +test textWind-10.3 {EmbWinLayoutProc procedure, error in creating window} -constraints { + fonts +} -setup { + .t delete 1.0 end + proc bgerror args { + global msg + set msg $args + } +} -body { .t insert 1.0 "Some sample text" .t window create 1.5 -create { - concat gorp + concat gorp } set msg xyzzy update list $msg [.t bbox 1.5] -} {{{bad window path name "gorp"}} {40 11 0 0}} -proc bgerror args { - global msg - if {[lsearch -exact $msg $args] == -1} { - lappend msg $args +} -cleanup { + rename bgerror {} +} -result {{{bad window path name "gorp"}} {40 11 0 0}} + .t delete 1.0 end + destroy .t.f + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } } -} -test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end + +test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + destroy .t.f + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t.f} set msg {} after idle { .t window create 1.5 -create { @@ -453,68 +684,116 @@ test textWind-10.4 {EmbWinLayoutProc procedure, error in creating window} {textf } set count 0 while {([llength $msg] < 2) && ($count < 100)} { - update ; incr count; .t bbox 1.5 ; after 10 + update + incr count + .t bbox 1.5 + after 10 } lappend msg [.t bbox 1.5] [winfo exists .t.f.f] -} [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1] -test textWind-10.4.1 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end +} -cleanup { + destroy .t.f + rename bgerror {} +} -result [list {{can't embed .t.f.f relative to .t}} {{window name "f" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0] 1] +test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + destroy .t.f + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t.f} .t window create 1.5 -create { - frame .t.f - frame .t.f.f -width 10 -height 20 -bg $color + frame .t.f + frame .t.f.f -width 10 -height 20 -bg $color } set msg {} update idletasks lappend msg [winfo exists .t.f.f] -} [list {{can't embed .t.f.f relative to .t}} 1] +} -cleanup { + destroy .t.f + rename bgerror {} +} -result {{{can't embed .t.f.f relative to .t}} 1} catch {destroy .t.f} -test textWind-10.5 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end +test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" .t window create 1.5 -create { - concat .t + concat .t } set msg {} update lappend msg [.t bbox 1.5] -} [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-10.6 {EmbWinLayoutProc procedure, error in creating window} {textfonts} { - .t delete 1.0 end +} -cleanup { + rename bgerror {} +} -result [list {{can't embed .t relative to .t}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-10.7 {EmbWinLayoutProc procedure, error in creating window} -constraints { + textfonts +} -setup { + .t delete 1.0 end + destroy .t2 + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t2} .t window create 1.5 -create { - toplevel .t2 -width 100 -height 150 - wm geom .t2 +0+0 - concat .t2 + toplevel .t2 -width 100 -height 150 + wm geom .t2 +0+0 + concat .t2 } set msg {} update lappend msg [.t bbox 1.5] -} [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] -test textWind-10.6.1 {EmbWinLayoutProc procedure, error in creating window} { - .t delete 1.0 end +} -cleanup { + rename bgerror {} +} -result [list {{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}} [list 40 [expr {11+$fixedDiff/2}] 0 0]] +test textWind-10.8 {EmbWinLayoutProc procedure, error in creating window} -setup { + .t delete 1.0 end + destroy .t2 + proc bgerror args { + global msg + if {[lsearch -exact $msg $args] == -1} { + lappend msg $args + } + } +} -body { .t insert 1.0 "Some sample text" - catch {destroy .t2} .t window create 1.5 -create { - toplevel .t2 -width 100 -height 150 - wm geom .t2 +0+0 - concat .t2 + toplevel .t2 -width 100 -height 150 + wm geom .t2 +0+0 + concat .t2 } set msg {} update set i 0 while {[llength $msg] == 1 && [incr i] < 200} { update } - set msg -} {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}} + return $msg +} -cleanup { + destroy .t2 + rename bgerror {} +} -result {{{can't embed .t2 relative to .t}} {{window name "t2" already exists in parent}}} -proc bgerror args { - global msg - set msg $args -} -test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} { +test textWind-10.9 {EmbWinLayoutProc procedure, steal window from self} -setup { .t delete 1.0 end + destroy .t.b +} -body { .t insert 1.0 ABCDEFGHIJKLMNOP button .t.b -text "Hello!" .t window create 1.5 -window .t.b @@ -522,64 +801,104 @@ test textWind-10.7 {EmbWinLayoutProc procedure, steal window from self} { .t window create 1.3 -create {concat .t.b} update .t index .t.b -} {1.3} -catch {destroy .t2} -test textWind-10.8 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .t.b +} -result {1.3} +test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 125 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 20} {5 25 7 13}} -test textWind-10.9 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .f +} -result {{89 5 126 20} {5 25 7 13}} +test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 126 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 20} {5 25 7 13}} -test textWind-10.10 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .f +} -result {{89 5 126 20} {5 25 7 13}} +test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 127 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{5 18 127 20} {132 21 7 13}} -test textWind-10.11 {EmbWinLayoutProc procedure, doesn't fit on line} { - .t configure -wrap none +} -cleanup { + destroy .f +} -result {{5 18 127 20} {132 21 7 13}} +test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" frame .f -width 130 -height 20 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 20} {}} -test textWind-10.12 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap none +} -cleanup { + destroy .f +} -result {{89 5 126 20} {}} +test textWind-10.14 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" frame .f -width 130 -height 220 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{89 5 126 78} {}} -test textWind-10.13 {EmbWinLayoutProc procedure, doesn't fit on line} {fonts} { - .t configure -wrap char +} -cleanup { + destroy .f +} -result {{89 5 126 78} {}} +test textWind-10.15 {EmbWinLayoutProc procedure, doesn't fit on line} -constraints { + fonts +} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap char .t insert 1.0 "Some sample text" frame .f -width 250 -height 220 -bg $color -bd 2 -relief raised .t window create 1.12 -window .f update list [.t bbox .f] [.t bbox 1.13] -} {{5 18 210 65} {}} +} -cleanup { + destroy .f +} -result {{5 18 210 65} {}} + -test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} { +test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} -setup { .t delete 1.0 end + destroy .f + place forget .t + pack .t +} -body { .t insert 1.0 "Some sample text" pack forget .t place .t -x 30 -y 50 @@ -587,11 +906,16 @@ test textWind-11.1 {EmbWinDisplayProc procedure, geometry transforms} { .t window create 1.12 -window .f update winfo geom .f -} {30x20+119+55} -place forget .t -pack .t -test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} { - .t delete 1.0 end +} -cleanup { + destroy .f + place forget .t +} -result {30x20+119+55} +test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} -setup { + .t delete 1.0 end + destroy .t.f + place forget .t + pack .t +} -body { .t insert 1.0 "Some sample text" pack forget .t place .t -x 30 -y 50 @@ -599,11 +923,17 @@ test textWind-11.2 {EmbWinDisplayProc procedure, geometry transforms} { .t window create 1.12 -window .t.f update winfo geom .t.f -} {30x20+89+5} -place forget .t -pack .t -test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} { +} -cleanup { + destroy .t.f + place forget .t + pack .t +} -result {30x20+89+5} +test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} -setup { .t delete 1.0 end + destroy .f + place forget .t + pack .t +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.12 -window .f @@ -613,10 +943,18 @@ test textWind-11.3 {EmbWinDisplayProc procedure, configuration optimization} { .t delete 1.0 .t insert 1.0 "X" update - set x -} {no configures} -test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { - .t delete 1.0 end + return $x +} -cleanup { + destroy .f + place forget .t + pack .t +} -result {no configures} +test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints { + fonts +} -setup { + .t delete 1.0 end + destroy .f .f2 +} -body { .t insert 1.0 "xyzzy\nFirst window here: " .t configure -wrap none frame .f -width 30 -height 20 -bg $color @@ -629,9 +967,15 @@ test textWind-11.4 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { .t xview scroll 5 units update list [winfo ismapped .f] [winfo geom .f] [.t bbox .f] [winfo ismapped .f2] -} {1 30x20+103+18 {103 18 30 20} 0} -test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { - .t delete 1.0 end +} -cleanup { + destroy .f .f2 +} -result {1 30x20+103+18 {103 18 30 20} 0} +test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} -constraints { + fonts +} -setup { + .t delete 1.0 end + destroy .f .f2 +} -body { .t insert 1.0 "xyzzy\nFirst window here: " .t configure -wrap none frame .f -width 30 -height 20 -bg $color @@ -645,11 +989,16 @@ test textWind-11.5 {EmbWinDisplayProc procedure, horizontal scrolling} {fonts} { .t xview scroll 25 units update list [winfo ismapped .f] [winfo ismapped .f2] [winfo geom .f2] [.t bbox .f2] -} {0 1 40x10+119+23 {119 23 40 10}} +} -cleanup { + destroy .f .f2 +} -result {0 1 40x10+119+23 {119 23 40 10}} .t configure -wrap char -test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} { + +test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -669,74 +1018,114 @@ test textWind-12.1 {EmbWinUndisplayProc procedure, mapping/unmapping} { .t configure -wrap none .t insert 1.0 "Enough text to make the line run off-screen" update - set x -} {created mapped modified replaced unmapped mapped off-screen unmapped} + return $x +} -cleanup { + destroy .f +} -result {created mapped modified replaced unmapped mapped off-screen unmapped} + -test textWind-13.1 {EmbWinBboxProc procedure} { +test textWind-13.1 {EmbWinBboxProc procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align top -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+6 {21 6 5 5}} -test textWind-13.2 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+6 {21 6 5 5}} +test textWind-13.2 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align center -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+9 {21 9 5 5}} -test textWind-13.3 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+9 {21 9 5 5}} +test textWind-13.3 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+10 {21 10 5 5}} -test textWind-13.4 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+10 {21 10 5 5}} +test textWind-13.4 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+12 {21 12 5 5}} -test textWind-13.5 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x5+21+12 {21 12 5 5}} +test textWind-13.5 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align top -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x11+21+6 {21 6 5 11}} -test textWind-13.6 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x11+21+6 {21 6 5 11}} +test textWind-13.6 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align center -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x11+21+6 {21 6 5 11}} -test textWind-13.7 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x11+21+6 {21 6 5 11}} +test textWind-13.7 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align baseline -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x9+21+6 {21 6 5 9}} -test textWind-13.8 {EmbWinBboxProc procedure} {fonts} { +} -cleanup { + destroy .f +} -result {5x9+21+6 {21 6 5 9}} +test textWind-13.8 {EmbWinBboxProc procedure} -constraints fonts -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 5 -height 5 -bg $color .t window create 1.2 -window .f -align bottom -padx 2 -pady 1 -stretch 1 update list [winfo geom .f] [.t bbox .f] -} {5x11+21+6 {21 6 5 11}} -test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} { +} -cleanup { + destroy .f +} -result {5x11+21+6 {21 6 5 11}} +test textWind-13.9 {EmbWinBboxProc procedure, spacing options} -constraints { + fonts +} -setup { + .t delete 1.0 end + destroy .f +} -body { .t configure -spacing1 5 -spacing3 2 .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -744,11 +1133,15 @@ test textWind-13.9 {EmbWinBboxProc procedure, spacing options} {fonts} { .t window create 1.2 -window .f -align center -padx 2 -pady 1 update list [winfo geom .f] [.t bbox .f] -} {5x5+21+14 {21 14 5 5}} -.t configure -spacing1 0 -spacing2 0 -spacing3 0 +} -cleanup { + destroy .f +} -result {5x5+21+14 {21 14 5 5}} + -test textWind-14.1 {EmbWinDelayedUnmap procedure} { +test textWind-14.1 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -760,11 +1153,14 @@ test textWind-14.1 {EmbWinDelayedUnmap procedure} { .t window configure .f -window {} lappend x updated update - set x -} {modified removed unmapped updated} -catch {destroy .f} -test textWind-14.2 {EmbWinDelayedUnmap procedure} { + return $x +} -cleanup { + destroy .f +} -result {modified removed unmapped updated} +test textWind-14.2 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -776,10 +1172,14 @@ test textWind-14.2 {EmbWinDelayedUnmap procedure} { .t delete .f lappend x updated update - set x -} {modified deleted updated} -test textWind-14.3 {EmbWinDelayedUnmap procedure} { + return $x +} -cleanup { + destroy .f +} -result {modified deleted updated} +test textWind-14.3 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .f +} -body { .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9" frame .f -width 30 -height 20 -bg $color .t window create 1.2 -window .f @@ -788,9 +1188,13 @@ test textWind-14.3 {EmbWinDelayedUnmap procedure} { set result [winfo ismapped .f] update ; after 10 list $result [winfo ismapped .f] -} {1 0} -test textWind-14.4 {EmbWinDelayedUnmap procedure} { +} -cleanup { + destroy .f +} -result {1 0} +test textWind-14.4 {EmbWinDelayedUnmap procedure} -setup { .t delete 1.0 end + destroy .t.f +} -body { .t insert 1.0 "Some sample text\nAnother line\n3\n4\n5\n6\n7\n8\n9" frame .t.f -width 30 -height 20 -bg $color .t window create 1.2 -window .t.f @@ -799,27 +1203,38 @@ test textWind-14.4 {EmbWinDelayedUnmap procedure} { set result [winfo ismapped .t.f] update list $result [winfo ismapped .t.f] -} {1 0} -catch {destroy .t.f} -catch {destroy .f} +} -cleanup { + destroy .t.f +} -result {1 0} -test textWind-15.1 {TkTextWindowIndex procedure} { - list [catch {.t index .foo} msg] $msg -} {1 {bad text index ".foo"}} -test textWind-15.2 {TkTextWindowIndex procedure} {fonts} { - .t configure -wrap none + +test textWind-15.1 {TkTextWindowIndex procedure} -setup { .t delete 1.0 end +} -body { + .t index .foo +} -returnCodes error -result {bad text index ".foo"} +test textWind-15.2 {TkTextWindowIndex procedure} -constraints fonts -setup { + .t delete 1.0 end + destroy .f +} -body { + .t configure -spacing1 0 -spacing2 0 -spacing3 0 \ + -wrap none .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.6 -window .f .t tag add a 1.1 .t tag add a 1.3 list [.t index .f] [.t bbox 1.7] -} {1.6 {77 8 7 13}} +} -cleanup { + destroy .f +} -result {1.6 {77 8 7 13}} -test textWind-16.1 {EmbWinTextStructureProc procedure} { - .t configure -wrap none + +test textWind-16.1 {EmbWinTextStructureProc procedure} -setup { .t delete 1.0 end + destroy .f +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.6 -window .f @@ -827,11 +1242,15 @@ test textWind-16.1 {EmbWinTextStructureProc procedure} { pack forget .t update winfo ismapped .f -} 0 -pack .t -test textWind-16.2 {EmbWinTextStructureProc procedure} { - .t configure -wrap none - .t delete 1.0 end +} -cleanup { + pack .t +} -result 0 +test textWind-16.2 {EmbWinTextStructureProc procedure} -setup { + .t delete 1.0 end + destroy .f .f2 +} -body { + .t configure -spacing1 0 -spacing2 0 -spacing3 0 \ + -wrap none .t insert 1.0 "Some sample text" frame .f -width 30 -height 20 -bg $color .t window create 1.6 -window .f @@ -842,21 +1261,26 @@ test textWind-16.2 {EmbWinTextStructureProc procedure} { pack .f2 -before .t update lappend result [winfo geom .f] [.t bbox .f] -} {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}} -catch {destroy .f2} -test textWind-16.3 {EmbWinTextStructureProc procedure} { - .t configure -wrap none +} -cleanup { + destroy .f .f2 +} -result {30x20+47+5 {47 5 30 20} 30x20+47+35 {47 5 30 20}} +test textWind-16.3 {EmbWinTextStructureProc procedure} -setup { .t delete 1.0 end +} -body { + .t configure -wrap none .t insert 1.0 "Some sample text" .t window create 1.6 update pack forget .t update -} {} -pack .t -test textWind-16.4 {EmbWinTextStructureProc procedure} { - .t configure -wrap none +} -cleanup { + pack .t +} -result {} +test textWind-16.4 {EmbWinTextStructureProc procedure} -setup { .t delete 1.0 end +} -body { + .t configure -spacing1 0 -spacing2 0 -spacing3 0 \ + -wrap none .t insert 1.0 "Some sample text" frame .t.f -width 30 -height 20 -bg $color .t window create 1.6 -window .t.f @@ -864,13 +1288,15 @@ test textWind-16.4 {EmbWinTextStructureProc procedure} { pack forget .t update list [winfo ismapped .t.f] [.t bbox .t.f] -} {1 {47 5 30 20}} -pack .t +} -cleanup { + pack .t +} -result {1 {47 5 30 20}} -test textWind-17.1 {peer widgets and embedded windows} { - catch {destroy .t .tt} + +test textWind-17.1 {peer widgets and embedded windows} -setup { + destroy .t .tt .f +} -body { pack [text .t] - .t delete 1.0 end .t insert end "Line 1" frame .f -width 20 -height 10 -bg blue .t window create 1.3 -window .f @@ -879,12 +1305,12 @@ test textWind-17.1 {peer widgets and embedded windows} { update ; update destroy .t .tt winfo exists .f -} {0} +} -result {0} -test textWind-17.2 {peer widgets and embedded windows} { - catch {destroy .t .f} +test textWind-17.2 {peer widgets and embedded windows} -setup { + destroy .t .f .tt +} -body { pack [text .t] - .t delete 1.0 end .t insert end "Line 1\nLine 2" frame .f -width 20 -height 10 -bg blue .t window create 1.4 -window .f @@ -895,10 +1321,11 @@ test textWind-17.2 {peer widgets and embedded windows} { .tt.t insert 1.0 "foo" update destroy .tt -} {} +} -result {} -test textWind-17.3 {peer widget and -create} { - catch {destroy .t} +test textWind-17.3 {peer widget and -create} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -908,10 +1335,12 @@ test textWind-17.3 {peer widget and -create} { .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update destroy .t .tt -} {} +} -result {} -test textWind-17.4 {peer widget deleted one window shouldn't delete others} { - catch {destroy .t .tt} +test textWind-17.4 {peer widget deleted one window shouldn't delete others} -setup { + destroy .t .tt + set res {} +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -920,14 +1349,16 @@ test textWind-17.4 {peer widget deleted one window shouldn't delete others} { .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update ; update destroy .tt - set res {} lappend res [.t get 1.2] update lappend res [.t get 1.2] -} {{} {}} +} -cleanup { + destroy .t +} -result {{} {}} -test textWind-17.5 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.5 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -935,13 +1366,14 @@ test textWind-17.5 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update ; update - set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]] + list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {.t.f .tt.t.f} +} -result {.t.f .tt.t.f} -test textWind-17.6 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.6 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -949,14 +1381,15 @@ test textWind-17.6 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -create {frame %W.f -width 10 -height 20 -bg blue} update ; update - set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} -test textWind-17.7 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.7 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -964,13 +1397,14 @@ test textWind-17.7 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] update ; update - set res [list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window]] + list [.t window cget 1.2 -window] [.tt.t window cget 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {.t.f {}} +} -result {.t.f {}} -test textWind-17.8 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.8 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -978,14 +1412,15 @@ test textWind-17.8 {peer widget window configuration} { pack [.t peer create .tt.t] .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] update ; update - set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + list [.t window configure 1.2 -window] \ + [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} .t.f} {-window {} {} {} {}}} +} -result {{-window {} {} {} .t.f} {-window {} {} {} {}}} -test textWind-17.8a {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.9 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -994,14 +1429,14 @@ test textWind-17.8a {peer widget window configuration} { .t window create 1.2 -window [frame .t.f -width 10 -height 20 -bg blue] update ; update .tt.t window configure 1.2 -window [frame .tt.t.f -width 10 -height 20 -bg red] - set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + list [.t window configure 1.2 -window] [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +} -result {{-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} -test textWind-17.9 {peer widget window configuration} { - catch {destroy .t .tt} +test textWind-17.10 {peer widget window configuration} -setup { + destroy .t .tt +} -body { pack [text .t] .t delete 1.0 end .t insert 1.0 "Some sample text" @@ -1015,15 +1450,14 @@ test textWind-17.9 {peer widget window configuration} { .tt.t window configure 1.2 -window {} .t window configure 1.2 -window {} set res [list [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window]] + [.tt.t window configure 1.2 -window]] update lappend res [.t window configure 1.2 -window] \ - [.tt.t window configure 1.2 -window] + [.tt.t window configure 1.2 -window] +} -cleanup { destroy .tt .t - set res -} {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} +} -result {{-window {} {} {} {}} {-window {} {} {} {}} {-window {} {} {} .t.f} {-window {} {} {} .tt.t.f}} -catch {destroy .t} option clear # cleanup diff --git a/tests/tk.test b/tests/tk.test index 02b4257..748a6cf 100644 --- a/tests/tk.test +++ b/tests/tk.test @@ -5,135 +5,147 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2002 ActiveState Corporation. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test -test tk-1.1 {tk command: general} \ - -body {tk} -returnCodes 1 \ - -result {wrong # args: should be "tk option ?arg?"} -test tk-1.2 {tk command: general} \ - -body {tk xyz} -returnCodes 1 \ - -result {bad option "xyz": must be appname, caret, scaling, useinputmethods, windowingsystem, or inactive} +test tk-1.1 {tk command: general} -body { + tk +} -returnCodes error -result {wrong # args: should be "tk subcommand ?arg ...?"} +test tk-1.2 {tk command: general} -body { + tk xyz +} -returnCodes error -result {unknown or ambiguous subcommand "xyz": must be appname, busy, caret, fontchooser, inactive, scaling, useinputmethods, or windowingsystem} +# Value stored to restore default settings after 2.* tests set appname [tk appname] -test tk-2.1 {tk command: appname} { - list [catch {tk appname xyz abc} msg] $msg -} {1 {wrong # args: should be "tk appname ?newName?"}} -test tk-2.2 {tk command: appname} { +test tk-2.1 {tk command: appname} -body { + tk appname xyz abc +} -returnCodes error -result {wrong # args: should be "tk appname ?newName?"} +test tk-2.2 {tk command: appname} -body { tk appname foobazgarply -} {foobazgarply} -test tk-2.3 {tk command: appname} unix { +} -result {foobazgarply} +test tk-2.3 {tk command: appname} -constraints unix -body { tk appname bazfoogarply expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} -} {1} -test tk-2.4 {tk command: appname} { - tk appname $appname -} $appname +} -result {1} +test tk-2.4 {tk command: appname} -body { + tk appname [tk appname] +} -result [tk appname] tk appname $appname +# Value stored to restore default settings after 3.* tests set scaling [tk scaling] -test tk-3.1 {tk command: scaling} { - list [catch {tk scaling -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test tk-3.2 {tk command: scaling: get current} { +test tk-3.1 {tk command: scaling} -body { + tk scaling -displayof +} -returnCodes error -result {value for "-displayof" missing} +test tk-3.2 {tk command: scaling: get current} -body { tk scaling 1 format %.2g [tk scaling] -} 1 -test tk-3.3 {tk command: scaling: get current} { +} -result 1 +test tk-3.3 {tk command: scaling: get current} -body { tk scaling -displayof . 1.25 format %.3g [tk scaling] -} 1.25 -test tk-3.4 {tk command: scaling: set new} { - list [catch {tk scaling xyz} msg] $msg -} {1 {expected floating-point number but got "xyz"}} -test tk-3.5 {tk command: scaling: set new} { - list [catch {tk scaling -displayof . xyz} msg] $msg -} {1 {expected floating-point number but got "xyz"}} -test tk-3.6 {tk command: scaling: set new} { +} -result 1.25 +test tk-3.4 {tk command: scaling: set new} -body { + tk scaling xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test tk-3.5 {tk command: scaling: set new} -body { + tk scaling -displayof . xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test tk-3.6 {tk command: scaling: set new} -body { tk scaling 1 format %.2g [tk scaling] -} 1 -test tk-3.7 {tk command: scaling: set new} { +} -result 1 +test tk-3.7 {tk command: scaling: set new} -body { tk scaling -displayof . 1.25 format %.3g [tk scaling] -} 1.25 -test tk-3.8 {tk command: scaling: negative} { +} -result 1.25 +test tk-3.8 {tk command: scaling: negative} -body { tk scaling -1 expr {[tk scaling] > 0} -} {1} -test tk-3.9 {tk command: scaling: too big} { +} -result {1} +test tk-3.9 {tk command: scaling: too big} -body { tk scaling 1000000 expr {[tk scaling] < 10000} -} {1} -test tk-3.10 {tk command: scaling: widthmm} { +} -result {1} +test tk-3.10 {tk command: scaling: widthmm} -body { tk scaling 1.25 - expr {int((25.4*[winfo screenwidth .])/(72*1.25)+0.5)-[winfo screenmmwidth .]} -} {0} -test tk-3.11 {tk command: scaling: heightmm} { + expr {int((25.4*[winfo screenwidth .])/(72*1.25) + 0.5) \ + - [winfo screenmmwidth .]} +} -result {0} +test tk-3.11 {tk command: scaling: heightmm} -body { tk scaling 1.25 - expr {int((25.4*[winfo screenheight .])/(72*1.25)+0.5)-[winfo screenmmheight .]} -} {0} + expr {int((25.4*[winfo screenheight .])/(72*1.25) + 0.5) \ + - [winfo screenmmheight .]} +} -result {0} tk scaling $scaling +# Value stored to restore default settings after 4.* tests set useim [tk useinputmethods] -test tk-4.1 {tk command: useinputmethods} { - list [catch {tk useinputmethods -displayof} msg] $msg -} {1 {value for "-displayof" missing}} -test tk-4.2 {tk command: useinputmethods: get current} { +test tk-4.1 {tk command: useinputmethods} -body { + tk useinputmethods -displayof +} -returnCodes error -result {value for "-displayof" missing} +test tk-4.2 {tk command: useinputmethods: get current} -body { + tk useinputmethods no +} -cleanup { + tk useinputmethods $useim +} -result 0 +test tk-4.3 {tk command: useinputmethods: get current} -body { tk useinputmethods no -} 0 -test tk-4.3 {tk command: useinputmethods: get current} { tk useinputmethods -displayof . -} 0 -test tk-4.4 {tk command: useinputmethods: set new} { - list [catch {tk useinputmethods xyz} msg] $msg -} {1 {expected boolean value but got "xyz"}} -test tk-4.5 {tk command: useinputmethods: set new} { - list [catch {tk useinputmethods -displayof . xyz} msg] $msg -} {1 {expected boolean value but got "xyz"}} -test tk-4.6 {tk command: useinputmethods: set new} unix { - # This isn't really a test, but more of a check... - # The answer is what was given, because we may be on a Unix - # system that doesn't have the XIM stuff +} -cleanup { + tk useinputmethods $useim +} -result 0 +test tk-4.4 {tk command: useinputmethods: set new} -body { + tk useinputmethods xyz +} -returnCodes error -result {expected boolean value but got "xyz"} +test tk-4.5 {tk command: useinputmethods: set new} -body { + tk useinputmethods -displayof . xyz +} -returnCodes error -result {expected boolean value but got "xyz"} +test tk-4.6 {tk command: useinputmethods: set new} -body { + # This isn't really a test, but more of a check... The answer is what was + # given, because we may be on a Unix system that doesn't have the XIM + # stuff if {[tk useinputmethods 1] == 0} { puts "this wish doesn't have XIM (X Input Methods) support" } - set useim -} $useim -test tk-4.7 {tk command: useinputmethods: set new} win { - # Mac and Windows don't have X Input Methods, so this should - # always return 0 + return $useim +} -result $useim +test tk-4.7 {tk command: useinputmethods: set new} -constraints win -body { + # Mac and Windows don't have X Input Methods, so this should always return + # 0 tk useinputmethods 1 -} 0 -tk useinputmethods $useim +} -cleanup { + tk useinputmethods $useim +} -result 0 -test tk-5.1 {tk caret} { - list [catch {tk caret} msg] $msg -} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}} -test tk-5.2 {tk caret} { - list [catch {tk caret bogus} msg] $msg -} {1 {bad window path name "bogus"}} -test tk-5.3 {tk caret} { - list [catch {tk caret . -foo} msg] $msg -} {1 {bad caret option "-foo": must be -x, -y, or -height}} -test tk-5.4 {tk caret} { - list [catch {tk caret . -x 0 -y} msg] $msg -} {1 {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"}} -test tk-5.5 {tk caret} { - list [catch {tk caret . -x 10 -y 11 -h 12; tk caret .} msg] $msg -} {0 {-height 12 -x 10 -y 11}} -test tk-5.6 {tk caret} { - list [catch {tk caret . -x 20 -y 25 -h 30; tk caret . -hei} msg] $msg -} {0 30} +test tk-5.1 {tk caret} -body { + tk caret +} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"} +test tk-5.2 {tk caret} -body { + tk caret bogus +} -returnCodes error -result {bad window path name "bogus"} +test tk-5.3 {tk caret} -body { + tk caret . -foo +} -returnCodes error -result {bad caret option "-foo": must be -x, -y, or -height} +test tk-5.4 {tk caret} -body { + tk caret . -x 0 -y +} -returnCodes error -result {wrong # args: should be "tk caret window ?-x x? ?-y y? ?-height height?"} +test tk-5.5 {tk caret} -body { + tk caret . -x 10 -y 11 -h 12; tk caret . +} -result {-height 12 -x 10 -y 11} +test tk-5.6 {tk caret} -body { + tk caret . -x 20 -y 25 -h 30; tk caret . -hei +} -result {30} # tk inactive test tk-6.1 {tk inactive} -body { string is integer [tk inactive] } -result 1 test tk-6.2 {tk inactive reset} -body { - catch {tk inactive reset} -} -result 0 + tk inactive reset +} -returnCodes ok -match glob -result * test tk-6.3 {tk inactive wrong argument} -body { tk inactive foo } -returnCodes 1 -result {bad option "foo": must be reset} @@ -148,16 +160,24 @@ test tk-6.5 {tk inactive} -body { expr {$i == -1 || ( $i > 90 && $i < 200 )} } -result 1 -# tk inactive in safe interpreters -safe::interpCreate foo -safe::loadTk foo test tk-7.1 {tk inactive in a safe interpreter} -body { +# tk inactive in safe interpreters + safe::interpCreate foo + safe::loadTk foo foo eval {tk inactive} +} -cleanup { + ::safe::interpDelete foo } -result -1 test tk-7.2 {tk inactive reset in a safe interpreter} -body { +# tk inactive in safe interpreters + safe::interpCreate foo + safe::loadTk foo foo eval {tk inactive reset} +} -cleanup { + ::safe::interpDelete foo } -returnCodes 1 -result {resetting the user inactivity timer is not allowed in a safe interpreter} -::safe::interpDelete foo + +# tests of [tk busy] in busy.test # cleanup cleanupTests diff --git a/tests/unixButton.test b/tests/unixButton.test index a51e259..137ef33 100644 --- a/tests/unixButton.test +++ b/tests/unixButton.test @@ -8,9 +8,11 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test +imageInit # Create entries in the option database to be sure that geometry options # like border width have predictable values. @@ -32,19 +34,14 @@ option add *Radiobutton.font {Helvetica -12 bold} proc bogusTrace args { error "trace aborted" } -catch {unset value} -catch {unset value2} -eval image delete [image names] -label .l -text Label -button .b -text Button -checkbutton .c -text Checkbutton -radiobutton .r -text Radiobutton -pack .l .b .c .r -update -test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { +test unixbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { + unix testImageType +} -setup { deleteWindows + imageCleanup +} -body { image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 @@ -54,12 +51,18 @@ test unixbutton-1.1 {TkpComputeButtonGeometry procedure} {unix testImageType} { pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {68 48 74 54 112 52 112 52} -test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows + image delete image1 +} -result {68 48 74 54 112 52 112 52} +test unixbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { + deleteWindows +} -body { label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 @@ -67,27 +70,37 @@ test unixbutton-1.2 {TkpComputeButtonGeometry procedure} unix { pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {23 33 29 39 54 37 54 37} -test unixbutton-1.3 {TkpComputeButtonGeometry procedure} unix { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {23 33 29 39 54 37 54 37} +test unixbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { deleteWindows +} -body { label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ - -indicatoron 0 + -indicatoron 0 radiobutton .b4 -bitmap question -bd 3 -highlightthickness 1 \ - -indicatoron false + -indicatoron false pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {31 41 25 35 25 35 25 35} -test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {31 41 25 35 25 35 25 35} +test unixbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { + deleteWindows +} -body { label .b1 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} button .b2 -text Xagqpim -padx 0 -pady 2 -font {Helvetica -18 bold} checkbutton .b3 -text Xagqpim -padx 1 -pady 1 -font {Helvetica -18 bold} @@ -95,26 +108,41 @@ test unixbutton-1.4 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {82 29 88 35 114 31 121 29} -test unixbutton-1.5 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {82 29 88 35 114 31 121 29} +test unixbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { deleteWindows +} -body { label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {136 88} -test unixbutton-1.6 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { +} -cleanup { deleteWindows +} -result {136 88} +test unixbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { + deleteWindows +} -body { label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {231 46} -test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { +} -cleanup { + deleteWindows +} -result {231 46} +test unixbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 @@ -122,73 +150,106 @@ test unixbutton-1.7 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {74 22 60 84 168 38 61 22} -test unixbutton-1.8 {TkpComputeButtonGeometry procedure} {unix nonPortable fonts} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {74 22 60 84 168 38 61 22} +test unixbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints { + unix nonPortable fonts +} -setup { + deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ - -highlightthickness 4 + -highlightthickness 4 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ - -highlightthickness 0 + -highlightthickness 0 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \ - -highlightthickness 1 -indicatoron no + -highlightthickness 1 -indicatoron no radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0 pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {62 30 56 24 58 22 62 22} -test unixbutton-1.9 {TkpComputeButtonGeometry procedure} unix { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {62 30 56 24 58 22 62 22} +test unixbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { deleteWindows +} -body { button .b2 -bitmap question -default active list [winfo reqwidth .b2] [winfo reqheight .b2] -} {37 47} -test unixbutton-1.10 {TkpComputeButtonGeometry procedure} unix { +} -cleanup { deleteWindows +} -result {37 47} +test unixbutton-1.10 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { + deleteWindows +} -body { button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] -} {37 47} -test unixbutton-1.11 {TkpComputeButtonGeometry procedure} unix { +} -cleanup { + deleteWindows +} -result {37 47} +test unixbutton-1.11 {TkpComputeButtonGeometry procedure} -constraints { + unix +} -setup { deleteWindows +} -body { button .b2 -bitmap question -default disabled list [winfo reqwidth .b2] [winfo reqheight .b2] -} {27 37} +} -cleanup { + deleteWindows +} -result {27 37} -test unixbutton-2.1 {disabled coloring check, bug 669595} unix { - # this was just a visual bug, but at least this shows the visual + +test unixbutton-2.1 {disabled coloring check, bug 669595} -constraints { + unix +} -setup { deleteWindows + catch {unset value} +} -body { + # this was just a visual bug, but at least this shows the visual set on 1 set off 0 label .l -text "The following widgets should\ - \nshow significant visible diffs\ - \nfor selected vs unselected." + \nshow significant visible diffs\ + \nfor selected vs unselected." checkbutton .cb0 -anchor w -state disabled \ - -text Unselected -variable off + -text Unselected -variable off checkbutton .cb1 -anchor w -state disabled \ - -text Selected -variable on + -text Selected -variable on checkbutton .cb2 -anchor w -state disabled \ - -text Unselected -variable off -disabledforeground "" + -text Unselected -variable off -disabledforeground "" checkbutton .cb3 -anchor w -state disabled \ - -text Selected -variable on -disabledforeground "" + -text Selected -variable on -disabledforeground "" radiobutton .rb0 -anchor w -state disabled \ - -text Unselected -variable off + -text Unselected -variable off radiobutton .rb1 -anchor w -state disabled \ - -text Selected -variable on -value 1 + -text Selected -variable on -value 1 radiobutton .rb2 -anchor w -state disabled \ - -text Unselected -variable off -disabledforeground "" + -text Unselected -variable off -disabledforeground "" radiobutton .rb3 -anchor w -state disabled \ - -text Selected -variable on -value 1 -disabledforeground "" + -text Selected -variable on -value 1 -disabledforeground "" pack .l .cb0 .cb1 .cb2 .cb3 .rb0 .rb1 .rb2 .rb3 -side top -fill x after 400 set on -} 1 +} -cleanup { + deleteWindows +} -result 1 -deleteWindows # cleanup +imageFinish cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/unixEmbed.test b/tests/unixEmbed.test index 1e8f03b..8aaa3c4 100644 --- a/tests/unixEmbed.test +++ b/tests/unixEmbed.test @@ -6,9 +6,10 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test setupbg dobg {wm withdraw .} @@ -53,41 +54,53 @@ proc colorsFree {w {red 31} {green 245} {blue 192}} { && ([lindex $vals 2]/256 == $blue) } -test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} unix { - catch {destroy .t} - list [catch {toplevel .t -use xyz} msg] $msg -} {1 {expected integer but got "xyz"}} -test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} unix { - catch {destroy .t} - list [catch {toplevel .t -use 47} msg] $msg -} {1 {couldn't create child of window "47"}} -test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} { - catch {destroy .t} - catch {destroy .x} +test unixEmbed-1.1 {TkpUseWindow procedure, bad window identifier} -constraints { + unix +} -setup { + deleteWindows +} -body { + toplevel .t -use xyz +} -returnCodes error -result {expected integer but got "xyz"} +test unixEmbed-1.2 {TkpUseWindow procedure, bad window identifier} -constraints { + unix +} -setup { + deleteWindows +} -body { + toplevel .t -use 47 +} -returnCodes error -result {couldn't create child of window "47"} +test unixEmbed-1.3 {TkpUseWindow procedure, inheriting colormap} -constraints { + unix nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -colormap new wm geometry .t +0+0 eatColors .t.t frame .t.f -container 1 toplevel .x -use [winfo id .t.f] - set result [colorsFree .x] - destroy .t - set result -} {0} -test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} {unix nonPortable} { - catch {destroy .t} - catch {destroy .t2} - catch {destroy .x} + colorsFree .x +} -cleanup { + deleteWindows +} -result {0} +test unixEmbed-1.4 {TkpUseWindow procedure, inheriting colormap} -constraints { + unix nonPortable +} -setup { + deleteWindows +} -body { toplevel .t -container 1 -colormap new wm geometry .t +0+0 eatColors .t2 toplevel .x -use [winfo id .t] - set result [colorsFree .x] - destroy .t - set result -} {1} + colorsFree .x +} -cleanup { + deleteWindows +} -result {1} -test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix testembed} { - deleteWindows +test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 @@ -97,74 +110,103 @@ test unixEmbed-1.5 {TkpUseWindow procedure, creating Container records} {unix te toplevel .t -use $w list [testembed] [expr [lindex [lindex [testembed all] 0] 0] - $w] } -} {{{XXX {} {} .t}} 0} -test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{XXX {} {} .t}} 0} +test unixEmbed-1.6 {TkpUseWindow procedure, creating Container records} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 dobg "set w1 [winfo id .f1]" dobg "set w2 [winfo id .f2]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - toplevel .t2 -use $w2 - testembed - } -} {{XXX {} {} .t2} {XXX {} {} .t1}} -test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} {unix testembed} { - deleteWindows + eval destroy [winfo child .] + toplevel .t1 -use $w1 + toplevel .t2 -use $w2 + testembed + } +} -cleanup { + deleteWindows +} -result {{XXX {} {} .t2} {XXX {} {} .t1}} +test unixEmbed-1.7 {TkpUseWindow procedure, container and embedded in same app} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 pack .f1 .f2 toplevel .t1 -use [winfo id .f1] toplevel .t2 -use [winfo id .f2] testembed -} {{XXX .f2 {} .t2} {XXX .f1 {} .t1}} +} -cleanup { + deleteWindows +} -result {{XXX .f2 {} .t2} {XXX .f1 {} .t1}} # Can't think of any way to test the procedures TkpMakeWindow, # TkpMakeContainer, or EmbedErrorProc. -test unixEmbed-2.1 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows + +test unixEmbed-2.1 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - testembed + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed } destroy .f1 update dobg { - testembed + testembed } -} {} -test unixEmbed-2.2 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {} +test unixEmbed-2.2 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - testembed - destroy .t1 - testembed - } -} {} -test unixEmbed-2.3 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows + eval destroy [winfo child .] + toplevel .t1 -use $w1 + testembed + destroy .t1 + testembed + } +} -cleanup { + deleteWindows +} -result {} +test unixEmbed-2.3 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] update destroy .f1 testembed -} {} -test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { - deleteWindows +} -result {} +test unixEmbed-2.4 {EmbeddedEventProc procedure} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] @@ -173,166 +215,221 @@ test unixEmbed-2.4 {EmbeddedEventProc procedure} {unix testembed} { set x [testembed] update list $x [testembed] -} {{{XXX .f1 {} {}}} {}} +} -cleanup { + deleteWindows +} -result {{{XXX .f1 {} {}}} {}} -test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} \ - {unix testembed nonPortable} { - deleteWindows + +test unixEmbed-3.1 {ContainerEventProc procedure, detect creation} -constraints { + unix testembed nonPortable +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" set x [testembed] dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - wm withdraw .t1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 + wm withdraw .t1 } list $x [testembed] -} {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} -test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{XXX .f1 {} {}}} {{XXX .f1 XXX {}}}} +test unixEmbed-3.2 {ContainerEventProc procedure, set size on creation} -constraints { + unix +} -setup { + deleteWindows +} -body { toplevel .t1 -container 1 wm geometry .t1 +0+0 toplevel .t2 -use [winfo id .t1] -bg red update wm geometry .t2 -} {200x200+0+0} -test unixEmbed-3.2a {ContainerEventProc procedure, disallow position changes} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {200x200+0+0} +test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 -bd 2 -relief raised - update - wm geometry .t1 +30+40 + eval destroy [winfo child .] + toplevel .t1 -use $w1 -bd 2 -relief raised + update + wm geometry .t1 +30+40 } update dobg { - wm geometry .t1 + wm geometry .t1 } -} {200x200+0+0} -test unixEmbed-3.3 {ContainerEventProc procedure, disallow position changes} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {200x200+0+0} +test unixEmbed-3.4 {ContainerEventProc procedure, disallow position changes} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - update - wm geometry .t1 300x100+30+40 + eval destroy [winfo child .] + toplevel .t1 -use $w1 + update + wm geometry .t1 300x100+30+40 } update dobg { - wm geometry .t1 + wm geometry .t1 } -} {300x100+0+0} -test unixEmbed-3.4 {ContainerEventProc procedure, geometry requests} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {300x100+0+0} +test unixEmbed-3.5 {ContainerEventProc procedure, geometry requests} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - .t1 configure -width 300 -height 80 + .t1 configure -width 300 -height 80 } update list [winfo width .f1] [winfo height .f1] [dobg {wm geometry .t1}] -} {300 80 300x80+0+0} -test unixEmbed-3.5 {ContainerEventProc procedure, map requests} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {300 80 300x80+0+0} +test unixEmbed-3.6 {ContainerEventProc procedure, map requests} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - set x unmapped - bind .t1 <Map> {set x mapped} + eval destroy [winfo child .] + toplevel .t1 -use $w1 + set x unmapped + bind .t1 <Map> {set x mapped} } update dobg { - after 100 - update - set x + after 100 + update + set x } -} {mapped} -test unixEmbed-3.6 {ContainerEventProc procedure, destroy events} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {mapped} +test unixEmbed-3.7 {ContainerEventProc procedure, destroy events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" bind .f1 <Destroy> {set x dead} set x alive dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - destroy .t1 + destroy .t1 } update list $x [winfo exists .f1] -} {dead 0} +} -cleanup { + deleteWindows +} -result {dead 0} -test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} unix { - deleteWindows + +test unixEmbed-4.1 {EmbedStructureProc procedure, configure events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - .t1 configure -width 180 -height 100 + .t1 configure -width 180 -height 100 } update dobg { - winfo geometry .t1 + winfo geometry .t1 } -} {180x100+0+0} -test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {180x100+0+0} +test unixEmbed-4.2 {EmbedStructureProc procedure, destroy events} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update set x [testembed] destroy .f1 list $x [testembed] -} {{{XXX .f1 XXX {}}} {}} +} -cleanup { + deleteWindows +} -result {{{XXX .f1 XXX {}}} {}} -test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} unix { - deleteWindows + +test unixEmbed-5.1 {EmbedFocusProc procedure, FocusIn events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - bind .t1 <FocusIn> {lappend x "focus in %W"} - bind .t1 <FocusOut> {lappend x "focus out %W"} - set x {} + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} } focus -force .f1 update dobg {set x} -} {{focus in .t1}} -test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {{focus in .t1}} +test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" @@ -342,23 +439,28 @@ test unixEmbed-5.2 {EmbedFocusProc procedure, focusing on dead window} unix { } update dobg { - after 200 {destroy .t1} + after 200 {destroy .t1} } after 400 focus -force .f1 update -} {} -test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {} +test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 - bind .t1 <FocusIn> {lappend x "focus in %W"} - bind .t1 <FocusOut> {lappend x "focus out %W"} - set x {} + eval destroy [winfo child .] + toplevel .t1 -use $w1 + bind .t1 <FocusIn> {lappend x "focus in %W"} + bind .t1 <FocusOut> {lappend x "focus out %W"} + set x {} } focus -force .f1 update @@ -366,79 +468,102 @@ test unixEmbed-5.3 {EmbedFocusProc procedure, FocusOut events} unix { focus . update list $x [dobg {update; set x}] -} {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} +} -cleanup { + deleteWindows +} -result {{{focus in .t1}} {{focus in .t1} {focus out .t1}}} -test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} unix { - deleteWindows + +test unixEmbed-6.1 {EmbedGeometryRequest procedure, window changes size} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update dobg { - bind .t1 <Configure> {lappend x {configure .t1 %w %h}} - set x {} - .t1 configure -width 300 -height 120 - update - list $x [winfo geom .t1] + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] } -} {{{configure .t1 300 120}} 300x120+0+0} -test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{configure .t1 300 120}} 300x120+0+0} +test unixEmbed-6.2 {EmbedGeometryRequest procedure, window changes size} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 place .f1 -width 200 -height 200 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } after 300 {set x done} vwait x dobg { - bind .t1 <Configure> {lappend x {configure .t1 %w %h}} - set x {} - .t1 configure -width 300 -height 120 - update - list $x [winfo geom .t1] + bind .t1 <Configure> {lappend x {configure .t1 %w %h}} + set x {} + .t1 configure -width 300 -height 120 + update + list $x [winfo geom .t1] } -} {{{configure .t1 200 200}} 200x200+0+0} +} -cleanup { + deleteWindows +} -result {{{configure .t1 200 200}} 200x200+0+0} # Can't think up any tests for TkpGetOtherWindow procedure. -test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} unix { + +test unixEmbed-7.1 {TkpRedirectKeyEvent procedure, forward keystroke} -constraints { + unix +} -setup { + deleteWindows +} -body { deleteWindows frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } focus -force . bind . <KeyPress> {lappend x {key %A %E}} set x {} set y [dobg { - update - bind .t1 <KeyPress> {lappend y {key %A}} - set y {} - event generate .t1 <KeyPress> -keysym a - set y + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym a + set y }] update - bind . <KeyPress> {} list $x $y -} {{{key a 1}} {}} -test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} unix { - deleteWindows +} -cleanup { + deleteWindows + bind . <KeyPress> {} +} -result {{{key a 1}} {}} +test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 + eval destroy [winfo child .] + toplevel .t1 -use $w1 } update focus -force .f1 @@ -446,41 +571,49 @@ test unixEmbed-7.2 {TkpRedirectKeyEvent procedure, don't forward keystroke width bind . <KeyPress> {lappend x {key %A}} set x {} set y [dobg { - update - bind .t1 <KeyPress> {lappend y {key %A}} - set y {} - event generate .t1 <KeyPress> -keysym b - set y + update + bind .t1 <KeyPress> {lappend y {key %A}} + set y {} + event generate .t1 <KeyPress> -keysym b + set y }] update - bind . <KeyPress> {} list $x $y -} {{} {{key b}}} +} -cleanup { + deleteWindows + bind . <KeyPress> {} +} -result {{} {{key b}}} -test unixEmbed-8.1 {TkpClaimFocus procedure} unix { - deleteWindows + +test unixEmbed-8.1 {TkpClaimFocus procedure} -constraints unix -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken } focus -force .f2 update list [dobg { - focus .t1 - set x [list [focus]] - update - after 500 - update - lappend x [focus] + focus .t1 + set x [list [focus]] + update + after 500 + update + lappend x [focus] }] [focus] -} {{{} .t1} .f1} -test unixEmbed-8.2 {TkpClaimFocus procedure} unix { +} -cleanup { + deleteWindows +} -result {{{} .t1} .f1} +test unixEmbed-8.2 {TkpClaimFocus procedure} -constraints unix -setup { + deleteWindows catch {interp delete child} deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -width 200 -height 50 pack .f1 .f2 @@ -488,21 +621,27 @@ test unixEmbed-8.2 {TkpClaimFocus procedure} unix { child eval "set argv {-use [winfo id .f1]}" load {} Tk child child eval { - . configure -bd 2 -highlightthickness 2 -relief sunken + . configure -bd 2 -highlightthickness 2 -relief sunken } focus -force .f2 update list [child eval { - focus . - set x [list [focus]] - update - lappend x [focus] + focus . + set x [list [focus]] + update + lappend x [focus] }] [focus] -} {{{} .} .f1} +} -cleanup { + deleteWindows +} -result {{{} .} .f1} catch {interp delete child} -test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testembed} { - deleteWindows + +test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 frame .f2 -container 1 -width 200 -height 50 frame .f3 -container 1 -width 200 -height 50 @@ -511,28 +650,39 @@ test unixEmbed-9.1 {EmbedWindowDeleted procedure, check parentPtr} {unix testemb set x {} lappend x [testembed] foreach w {.f3 .f4 .f1 .f2} { - destroy $w - lappend x [testembed] + destroy $w + lappend x [testembed] } set x -} {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} -test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} {unix testembed} { - deleteWindows +} -cleanup { + deleteWindows +} -result {{{XXX .f4 {} {}} {XXX .f3 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f4 {} {}} {XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}} {XXX .f1 {} {}}} {{XXX .f2 {} {}}} {}} +test unixEmbed-9.2 {EmbedWindowDeleted procedure, check embeddedPtr} -constraints { + unix testembed +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 dobg "set w1 [winfo id .f1]" dobg { - eval destroy [winfo child .] - toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken - set x {} - lappend x [testembed] - destroy .t1 - lappend x [testembed] + eval destroy [winfo child .] + toplevel .t1 -use $w1 -highlightthickness 2 -bd 2 -relief sunken + set x {} + lappend x [testembed] + destroy .t1 + lappend x [testembed] } -} {{{XXX {} {} .t1}} {}} +} -cleanup { + deleteWindows +} -result {{{XXX {} {} .t1}} {}} -test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { - deleteWindows + +test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -540,9 +690,14 @@ test unixEmbed-10.1 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix wm geometry .t1 +40+50 update wm geometry .t1 -} {150x80+0+0} -test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix { - deleteWindows +} -cleanup { + deleteWindows +} -result {150x80+0+0} +test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} -constraints { + unix +} -setup { + deleteWindows +} -body { frame .f1 -container 1 -width 200 -height 50 pack .f1 toplevel .t1 -use [winfo id .f1] -width 150 -height 80 @@ -550,10 +705,13 @@ test unixEmbed-10.2 {geometry propagation in tkUnixWm.c/UpdateGeometryInfo} unix wm geometry .t1 70x300+10+20 update wm geometry .t1 -} {70x300+0+0} +} -cleanup { + deleteWindows +} -result {70x300+0+0} # cleanup deleteWindows cleanupbg cleanupTests return + diff --git a/tests/unixMenu.test b/tests/unixMenu.test index 802a7c2..3d655e4 100644 --- a/tests/unixMenu.test +++ b/tests/unixMenu.test @@ -7,474 +7,648 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 +namespace import ::tcltest::* eval tcltest::configure $argv tcltest::loadTestedCommands -test unixMenu-1.1 {TkpNewMenu - normal menu} unix { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test unixMenu-1.2 {TkpNewMenu - help menu} unix { - catch {destroy .m1} + +test unixMenu-1.1 {TkpNewMenu - normal menu} -constraints unix -setup { + destroy .m1 +} -body { + list [menu .m1] [destroy .m1] +} -returnCodes ok -result {.m1 {}} +test unixMenu-1.2 {TkpNewMenu - help menu} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label Help -menu .m1.help - list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 .m1.help {} {}} + list [menu .m1.help] [. configure -menu ""] [destroy .m1] +} -returnCodes ok -result {.m1.help {} {}} + + +test unixMenu-2.1 {TkpDestroyMenu - nothing to do} -constraints unix -body {} -test unixMenu-2.1 {TkpDestroyMenu - nothing to do} {} {} -test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} {} {} -test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} unix { - catch {destroy .m1} +test unixMenu-3.1 {TkpDestroymenuEntry - nothing to do} -constraints unix -body {} + + +test unixMenu-4.1 {TkpConfigureMenuEntry - non-cascade entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label test - list [catch {.m1 entryconfigure test -label foo} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} unix { - catch {destroy .m1} + list [.m1 entryconfigure test -label foo] [destroy .m1] +} -returnCodes ok -result {{} {}} +test unixMenu-4.2 {TkpConfigureMenuEntry - cascade entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m2 -label test menu .m1.foo -tearoff 0 - list [catch {.m1 entryconfigure test -menu .m1.foo} msg] $msg [destroy .m1] -} {0 {} {}} + list [.m1 entryconfigure test -menu .m1.foo] [destroy .m1] +} -returnCodes ok -result {{} {}} + -test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} {} {} +test unixMenu-5.1 {TkpMenuNewEntry - nothing to do} -constraints unix -body {} -test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} unix { - catch {destroy .m1} + +test unixMenu-6.1 {TkpSetWindowMenuBar - null menu} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo . configure -menu .m1 - list [catch {. configure -menu ""} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-6.2 {TkpSetWindowMenuBar - menu} unix { - catch {destroy .m1} + list [. configure -menu ""] [destroy .m1] +} -returnCodes ok -result {{} {}} +test unixMenu-6.2 {TkpSetWindowMenuBar - menu} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo - list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} + list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] +} -returnCodes ok -result {{} {} {}} + + +test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} -constraints unix -body {} -test unixMenu-7.1 {TkpSetMainMenubar - nothing to do} {} {} -test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} unix { - catch {destroy .m1} +test unixMenu-8.1 {GetMenuIndicatorGeometry - indicator off} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -indicatoron 0 - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-8.2 {GetMenuIndicatorGeometry - not checkbutton or radio} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} {unix testImageType} { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-8.3 {GetMenuIndicatorGeometry - checkbutton image} -constraints { + unix testImageType +} -setup { + destroy .m1 catch {image delete image1} +} -body { menu .m1 image create test image1 .m1 add checkbutton -image image1 -label foo .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1] -} {0 {} {}} -test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -cleanup { + image delete image1 +} -returnCodes ok +test unixMenu-8.4 {GetMenuIndicatorGeometry - checkbutton bitmap} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -bitmap questhead -label foo .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-8.5 {GetMenuIndicatorGeometry - checkbutton} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} {unix testImageType} { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-8.6 {GetMenuIndicatorGeometry - radiobutton image} -constraints { + unix testImageType +} -setup { + destroy .m1 catch {image delete image1} +} -body { menu .m1 image create test image1 .m1 add radiobutton -image image1 -label foo .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] [image delete image1] -} {0 {} {}} -test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 + image delete image1 +} -returnCodes ok +test unixMenu-8.7 {GetMenuIndicatorGeometry - radiobutton bitmap} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -bitmap questhead -label foo .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-8.8 {GetMenuIndicatorGeometry - radiobutton} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-8.9 {GetMenuIndicatorGeometry - hideMargin} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo -hidemargin 1 .m1 invoke foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok -test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} unix { - catch {destroy .m1} + +test unixMenu-9.1 {GetMenuAccelGeometry - cascade entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-9.2 {GetMenuAccelGeometry - non-null label} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+S" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test unixMenu-9.3 {GetMenuAccelGeometry - null label} unix { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test unixMenu-9.3 {GetMenuAccelGeometry - null label} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok + -test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} unix { - catch {destroy .m1} +test unixMenu-10.1 {DrawMenuEntryBackground - active menubar} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo . configure -menu .m1 .m1 activate 1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-10.2 {DrawMenuEntryBackground - active} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -returnCodes ok -result {{} {} {}} +test unixMenu-10.2 {DrawMenuEntryBackground - active} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] $tearoff activate 0 - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-10.3 {DrawMenuEntryBackground - non-active} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -returnCodes ok -result {{} {}} +test unixMenu-10.3 {DrawMenuEntryBackground - non-active} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -returnCodes ok -result {{} {}} + -test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} unix { - catch {destroy .m1} +test unixMenu-11.1 {DrawMenuEntryAccelerator - menubar} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} # drawArrow parameter is never false under Unix -test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} unix { - catch {destroy .m1} +test unixMenu-11.2 {DrawMenuEntryAccelerator - cascade entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-11.3 {DrawMenuEntryAccelerator - normal entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-11.4 {DrawMenuEntryAccelerator - null entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -result {{} {}} + -test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} unix { - catch {destroy .m1} +test unixMenu-12.1 {DrawMenuEntryIndicator - non-check or radio} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-12.2 {DrawMenuEntryIndicator - checkbutton - indicator off} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -indicatoron 0 set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-12.3 {DrawMenuEntryIndicator - checkbutton - not selected} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-12.4 {DrawMenuEntryIndicator - checkbutton - selected} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-12.5 {DrawMenuEntryIndicator - radiobutton - indicator off} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo -indicatoron 0 set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-12.6 {DrawMenuEntryIndicator - radiobutton - not selected} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} -test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} unix { - catch {destroy .m1} + list [update] [destroy .m1] +} -result {{} {}} +test unixMenu-12.7 {DrawMenuEntryIndicator - radiobutton - selected} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -result {{} {}} + -test unixMenu-13.1 {DrawMenuSeparator - menubar case} unix { - catch {destroy .m1} +test unixMenu-13.1 {DrawMenuSeparator - menubar case} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-13.2 {DrawMenuSepartor - normal menu} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-13.2 {DrawMenuSepartor - normal menu} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -result {{} {}} + -test unixMenu-14.1 {DrawMenuEntryLabel} unix { - catch {destroy .m1} +test unixMenu-14.1 {DrawMenuEntryLabel} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -result {{} {}} -test unixMenu-15.1 {DrawMenuUnderline - menubar} unix { - catch {destroy .m1} + +test unixMenu-15.1 {DrawMenuUnderline - menubar} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -underline 0 . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-15.2 {DrawMenuUnderline - no menubar} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-15.2 {DrawMenuUnderline - no menubar} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -underline 0 set tearoff [tk::TearOffMenu .m1 40 40] - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -result {{} {}} + -test unixMenu-16.1 {TkpPostMenu} unix { - catch {destroy .m1} +test unixMenu-16.1 {TkpPostMenu} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok -test unixMenu-17.1 {GetMenuSeparatorGeometry} unix { - catch {destroy .m1} + +test unixMenu-17.1 {GetMenuSeparatorGeometry} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok + -test unixMenu-18.1 {GetTearoffEntryGeometry} {unix nonUnixUserInteraction} { - catch {destroy .m1} +test unixMenu-18.1 {GetTearoffEntryGeometry} -constraints { + unix nonUnixUserInteraction +} -setup { + destroy .mb +} -body { menubutton .mb -text "test" -menu .mb.m menu .mb.m .mb.m add command -label test pack .mb raise . - list [catch {tk::MbPost .mb} msg] $msg [tk::MenuUnpost .mb.m] [destroy .mb] -} {0 {} {} {}} + list [tk::MbPost .mb] [tk::MenuUnpost .mb.m] [destroy .mb] +} -result {{} {} {}} + # Don't know how to reproduce the case where the tkwin has been deleted. -test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} unix { - catch {destroy .m1} + +test unixMenu-19.1 {TkpComputeMenubarGeometry - zero entries} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} # Don't know how to generate one width windows -test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} unix { - catch {destroy .m1} +test unixMenu-19.2 {TkpComputeMenubarGeometry - one entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.3 {TkpComputeMenubarGeometry - entry with different font} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -font "Courier 24" .m1 add cascade -label File -font "Helvetica 18" . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.4 {TkpComputeMenubarGeometry - separator} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.5 {TkpComputeMenubarGeometry - First entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.6 {TkpComputeMenubarGeometry - First entry too wide} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File -font "Times 72" . configure -menu .m1 wm geometry . 10x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.7 {TkpComputeMenubarGeometry - two entries fit} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File .m1 add cascade -label Edit . configure -menu .m1 wm geometry . 200x200 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.8 {TkpComputeMenubarGeometry - two entries; 2nd don't fit} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File .m1 add cascade -label Edit -font "Times 72" . configure -menu .m1 wm geometry . 100x100 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.9 {TkpComputeMenubarGeometry - two entries; 1st dont fit} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File -font "Times 72" .m1 add cascade -label Edit . configure -menu .m1 wm geometry . 100x100 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.10 {TkpComputeMenubarGeometry - two entries; neither fit} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 -font "Times 72" .m1 add cascade -label File .m1 add cascade -label Edit . configure -menu .m1 wm geometry . 10x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} # ABC notation; capital A means first window fits, small a means it # does not. capital B menu means second window fist, etc. -test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} unix { - catch {destroy .m1} +test unixMenu-19.11 {TkpComputeMenubarGeometry - abc} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 -font "Times 72" .m1 add cascade -label "aaaaa" .m1 add cascade -label "bbbbb" .m1 add cascade -label "ccccc" . configure -menu .m1 wm geometry . 10x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.12 {TkpComputeMenubarGeometry - abC} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" .m1 add cascade -label "bbbbb" -font "Times 72" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 10x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.13 {TkpComputeMenubarGeometry - aBc} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" .m1 add cascade -label "B" .m1 add cascade -label "ccccc" -font "Times 72" . configure -menu .m1 wm geometry . 10x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.14 {TkpComputeMenubarGeometry - aBC} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "aaaaa" -font "Times 72" .m1 add cascade -label "B" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 60x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.15 {TkpComputeMenubarGeometry - Abc} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "bbbbb" -font "Times 72" .m1 add cascade -label "ccccc" -font "Times 72" . configure -menu .m1 wm geometry . 60x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.16 {TkpComputeMenubarGeometry - AbC} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "bbbbb" -font "Times 72" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 60x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.17 {TkpComputeMenubarGeometry - ABc} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "B" .m1 add cascade -label "ccccc" -font "Times 72" . configure -menu .m1 wm geometry . 60x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.18 {TkpComputeMenubarGeometry - ABC} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label "A" .m1 add cascade -label "B" .m1 add cascade -label "C" . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 @@ -484,10 +658,13 @@ test unixMenu-19.19 {TkpComputeMenubarGeometry - help menu in first position} un menu .m1.edit -tearoff 0 . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label Edit -menu .m1.edit menu .m1.edit -tearoff 0 @@ -497,10 +674,13 @@ test unixMenu-19.20 {TkpComputeMenubarGeometry - help menu in middle} unix { menu .m1.file -tearoff 0 . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 @@ -510,10 +690,13 @@ test unixMenu-19.21 {TkpComputeMenubarGeometry - help menu in first position} un menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 @@ -521,10 +704,13 @@ test unixMenu-19.22 {TkpComputeMenubarGeometry - help item fits} unix { menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label File -menu .m1.file menu .m1.file -tearoff 0 @@ -532,215 +718,283 @@ test unixMenu-19.23 {TkpComputeMenubarGeometry - help item does not fit} unix { menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} unix { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-19.24 {TkpComputeMenubarGeometry - help item only one} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label Help -menu .m1.help menu .m1.help -tearoff 0 . configure -menu .m1 wm geometry . 100x10 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} + -test unixMenu-20.1 {DrawTearoffEntry - menubar} unix { - catch {destroy .m1} +test unixMenu-20.1 {DrawTearoffEntry - menubar} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File . configure -menu .m1 - list [catch {update} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test unixMenu-20.2 {DrawTearoffEntry - non-menubar} {unix nonUnixUserInteraction} { - catch {destroy .m1} + list [update] [. configure -menu ""] [destroy .m1] +} -result {{} {} {}} +test unixMenu-20.2 {DrawTearoffEntry - non-menubar} -constraints { + unix nonUnixUserInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo .m1 post 40 40 - list [catch {update} msg] $msg [destroy .m1] -} {0 {} {}} + list [update] [destroy .m1] +} -result {{} {}} -test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} {} {} -test unixMenu-22.1 {SetHelpMenu - no menubars} unix { - catch {destroy .m1} +test unixMenu-21.1 {TkpInitializeMenuBindings - nothing to do} -constraints unix -body {} + + +test unixMenu-22.1 {SetHelpMenu - no menubars} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label test -menu .m1.test - list [catch {menu .m1.test} msg] $msg [destroy .m1] -} {0 .m1.test {}} + list [menu .m1.test] [destroy .m1] +} -result {.m1.test {}} # Don't know how to automate missing tkwins -test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} unix { - catch {destroy .m1} +test unixMenu-22.2 {SetHelpMenu - menubar but no help menu} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label .m1.file - list [catch {menu .m1.file} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 .m1.file {} {}} -test unixMenu-22.3 {SetHelpMenu - menubar with help menu} unix { - catch {destroy .m1} + list [menu .m1.file] [. configure -menu ""] [destroy .m1] +} -result {.m1.file {} {}} +test unixMenu-22.3 {SetHelpMenu - menubar with help menu} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 . configure -menu .m1 .m1 add cascade -label .m1.help - list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 .m1.help {} {}} -test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} unix { - catch {destroy .m1} - catch {destroy .t2} + list [menu .m1.help] [. configure -menu ""] [destroy .m1] +} -result {.m1.help {} {}} +test unixMenu-22.4 {SetHelpMenu - multiple menubars with same help menu} -constraints { + unix +} -setup { + destroy .m1 .t2 +} -body { toplevel .t2 wm geometry .t2 +40+40 menu .m1 -tearoff 0 . configure -menu .m1 .t2 configure -menu .m1 .m1 add cascade -label .m1.help - list [catch {menu .m1.help} msg] $msg [. configure -menu ""] [destroy .m1] [destroy .t2] -} {0 .m1.help {} {} {}} + list [menu .m1.help] [. configure -menu ""] [destroy .m1] [destroy .t2] +} -result {.m1.help {} {} {}} + -test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} unix { - catch {destroy .m1} +test unixMenu-23.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activeforeground red set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 set tk_strictMotif 1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} unix { - catch {destroy .m1} +} -result {{} {} 0} +test unixMenu-23.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -foreground red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.8 {TkpDrawMenuEntry - gc for normal} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -selectcolor orange .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.10 {TkpDrawMenuEntry - gc for indicator} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.11 {TkpDrawMenuEntry - border - custom entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activebackground green set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.12 {TkpDrawMenuEntry - border} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.12 {TkpDrawMenuEntry - border} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.13 {TkpDrawMenuEntry - active border - strict motif} -constraints { + unix +} -setup { + destroy .m1 +} -body { set tk_strictMotif 1 menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} unix { - catch {destroy .m1} +} -result {{} {} 0} +test unixMenu-23.14 {TkpDrawMenuEntry - active border - custom entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activeforeground yellow set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.15 {TkpDrawMenuEntry - active border} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.15 {TkpDrawMenuEntry - active border} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.16 {TkpDrawMenuEntry - font - custom entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.17 {TkpDrawMenuEntry - font} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.17 {TkpDrawMenuEntry - font} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.18 {TkpDrawMenuEntry - separator} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.18 {TkpDrawMenuEntry - separator} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.19 {TkpDrawMenuEntry - standard} unix { - catch {destroy .mb} +} -result {{} {}} +test unixMenu-23.19 {TkpDrawMenuEntry - standard} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File -menu .m1.file menu .m1.file @@ -748,140 +1002,192 @@ test unixMenu-23.20 {TkpDrawMenuEntry - disabled cascade item} unix { .m1 entryconfigure File -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.21 {TkpDrawMenuEntry - indicator} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.21 {TkpDrawMenuEntry - indicator} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label Foo .m1 invoke Foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-23.22 {TkpDrawMenuEntry - hide margin} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label Foo -hidemargin 1 .m1 invoke Foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test unixMenu-24.1 {GetMenuLabelGeometry - image} {testImageType unix} { - catch {destroy .m1} + +test unixMenu-24.1 {GetMenuLabelGeometry - image} -constraints { + testImageType unix +} -setup { + destroy .m1 catch {image delete image1} +} -body { menu .m1 image create test image1 .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} unix { - catch {destroy .m1} +} -result {{} {} {}} +test unixMenu-24.2 {GetMenuLabelGeometry - bitmap} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-24.3 {GetMenuLabelGeometry - no text} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-24.3 {GetMenuLabelGeometry - no text} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-24.4 {GetMenuLabelGeometry - text} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-24.4 {GetMenuLabelGeometry - text} -constraints unix -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} unix { - catch {destroy .m1} +test unixMenu-25.1 {TkpComputeStandardMenuGeometry - no entries} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.2 {TkpComputeStandardMenuGeometry - one entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.4 {TkpComputeStandardMenuGeometry - separator} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unix nonUnixUserInteraction} { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints { + unix nonUnixUserInteraction +} -setup { + destroy .mb +} -body { menubutton .mb -text "test" -menu .mb.m menu .mb.m .mb.m add command -label test pack .mb catch {tk::MbPost .mb} list [update] [tk::MenuUnpost .mb.m] [destroy .mb] -} {{} {} {}} -test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} unix { - catch {destroy .m1} +} -result {{} {} {}} +test unixMenu-25.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.13 {TkpComputeStandardMenuGeometry - indicator} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label test .m1 invoke 1 list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } {unix testImageType} { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or equal } -constraints { + unix testImageType +} -setup { + destroy .m1 catch {image delete image1} +} -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 @@ -889,10 +1195,13 @@ test unixMenu-25.14 {TkpComputeStandardMenuGeometry - second indicator less or e .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } {unix testImageType} { - catch {destroy .m1} +} -result {{} {} {}} +test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } -constraints { + unix testImageType +} -setup { + destroy .m1 catch {image delete image1} +} -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 @@ -900,30 +1209,42 @@ test unixMenu-25.15 {TkpComputeStandardMenuGeometry - second indicator larger } .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} unix { - catch {destroy .m1} +} -result {{} {} {}} +test unixMenu-25.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label one .m1 add command -label two .m1 add command -label three -columnbreak 1 list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 .m1 add command -label three list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 @@ -932,15 +1253,21 @@ test unixMenu-25.19 {TkpComputeStandardMenuGeometry - three columns} unix { .m1 add command -label five -columnbreak 1 .m1 add command -label six list [update idletasks] [destroy .m1] -} {{} {}} -test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} unix { - catch {destroy .m1} +} -result {{} {}} +test unixMenu-25.20 {TkpComputeStandardMenuGeometry - hide margin} -constraints { + unix +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add checkbutton -label one -hidemargin 1 list [update idletasks] [destroy .m1] -} {{} {}} +} -result {{} {}} + + +test unixMenu-26.1 {TkpMenuInit - nothing to do} -constraints unix -body {} + -test unixMenu-26.1 {TkpMenuInit - nothing to do} {} {} # cleanup deleteWindows diff --git a/tests/unixSelect.test b/tests/unixSelect.test index c3ed11d..53ae006 100644 --- a/tests/unixSelect.test +++ b/tests/unixSelect.test @@ -9,8 +9,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands global longValue selValue selInfo @@ -23,7 +24,7 @@ proc handler {type offset count} { lappend selInfo $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } @@ -31,18 +32,18 @@ proc handler {type offset count} { proc errIncrHandler {type offset count} { global selValue selInfo pass if {$offset == 4000} { - if {$pass == 0} { - # Just sizing the selection; don't do anything here. - set pass 1 - } else { - # Fetching the selection; wait long enough to cause a timeout. - after 6000 - } + if {$pass == 0} { + # Just sizing the selection; don't do anything here. + set pass 1 + } else { + # Fetching the selection; wait long enough to cause a timeout. + after 6000 + } } lappend selInfo $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } @@ -57,23 +58,23 @@ proc badHandler {path type offset count} { lappend selInfo $path $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } proc reallyBadHandler {path type offset count} { global selValue selInfo pass if {$offset == 4000} { - if {$pass == 0} { - set pass 1 - } else { - selection handle -type $type $path {} - } + if {$pass == 0} { + set pass 1 + } else { + selection handle -type $type $path {} + } } lappend selInfo $path $type $offset $count set numBytes [expr {[string length $selValue] - $offset}] if {$numBytes <= 0} { - return "" + return "" } string range $selValue $offset [expr $numBytes+$offset] } @@ -89,10 +90,10 @@ after 1500 proc setup {{path .f1} {display {}}} { catch {destroy $path} if {$display == {}} { - frame $path + frame $path } else { - toplevel $path -screen $display - wm geom $path +0+0 + toplevel $path -screen $display + wm geom $path +0+0 } selection own $path } @@ -104,255 +105,332 @@ foreach i {a b c d e f g j h i j k l m o p q r s t u v w x y z} { append longValue A$j B$j C$j D$j E$j F$j G$j H$j I$j K$j L$j M$j N$j } -test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} unix { +# ---------------------------------------------------------------------- + +test unixSelect-1.1 {TkSelGetSelection procedure: simple i18n text} -constraints { + unix +} -setup { + destroy .e setupbg - entry .e - pack .e +} -body { + pack [entry .e] update - .e insert 0 [encoding convertfrom identity \u00fcber] + .e insert 0 \u00fcber .e selection range 0 end - set result [dobg {string bytelength [selection get]}] + dobg {string length [selection get]} +} -cleanup { cleanupbg destroy .e - set result -} {5} -test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} unix { +} -result {4} + +test unixSelect-1.2 {TkSelGetSelection procedure: simple i18n text, iso8859-1} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc\u0444 - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc\u0444 + .e selection range 0 end } - set x [selection get] + selection get +} -cleanup { cleanupbg - list [string equal \u00fc? $x] \ - [string length $x] [string bytelength $x] -} {1 2 3} -test unixSelect-1.4 {TkSelGetSelection procedure: simple i18n text, iso2022} unix { +} -result \u00fc? + +test unixSelect-1.3 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { + unix +} -setup { setupbg setup +} -body { selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ - {handler COMPOUND_TEXT} + {handler COMPOUND_TEXT} selection own . set selValue \u00fc\u0444 set selInfo {} set result [dobg { - set x [selection get -type COMPOUND_TEXT] - list [string equal \u00fc\u0444 $x] \ - [string length $x] [string bytelength $x] + set x [selection get -type COMPOUND_TEXT] + list [string equal \u00fc\u0444 $x] [string length $x] }] - cleanupbg lappend result $selInfo -} {1 2 4 {COMPOUND_TEXT 0 4000}} -test unixSelect-1.5 {TkSelGetSelection procedure: INCR i18n text, iso2022} unix { +} -cleanup { + cleanupbg +} -result {1 2 {COMPOUND_TEXT 0 4000}} +test unixSelect-1.4 {TkSelGetSelection procedure: INCR i18n text, iso2022} -constraints { + unix +} -setup { + setupbg + setup +} -body { # This test is subtle. The selection ends up getting fetched twice by # Tk: once to compute the length, and again to actually send the data. # The first time through, we don't convert the data to ISO2022, so the # buffer boundaries end up being different in the two passes. - - setupbg - setup selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ - {handler COMPOUND_TEXT} + {handler COMPOUND_TEXT} selection own . set selValue [string repeat x 3999]\u00fc\u0444[string repeat x 3999] set selInfo {} set result [dobg { - set x [selection get -type COMPOUND_TEXT] - list [string equal \ - [string repeat x 3999]\u00fc\u0444[string repeat x 3999] $x] \ - [string length $x] [string bytelength $x] + set x [selection get -type COMPOUND_TEXT] + list [string equal \ + [string repeat x 3999]\u00fc\u0444[string repeat x 3999] $x] \ + [string length $x] }] - cleanupbg lappend result $selInfo -} {1 8000 8002 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} -test unixSelect-1.6 {TkSelGetSelection procedure: simple i18n text, iso2022} unix { +} -cleanup { + cleanupbg +} -result {1 8000 {COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3999 COMPOUND_TEXT 7998 4000 COMPOUND_TEXT 0 4000 COMPOUND_TEXT 4000 3998 COMPOUND_TEXT 7997 4000}} + +test unixSelect-1.5 {TkSelGetSelection procedure: simple i18n text, iso2022} -constraints { + unix +} -setup { setupbg setup +} -body { selection handle -type COMPOUND_TEXT -format COMPOUND_TEXT . \ - {handler COMPOUND_TEXT} + {handler COMPOUND_TEXT} selection own . set selValue \u00fc\u0444 set selInfo {} set result [dobg { - set x [selection get -type COMPOUND_TEXT] - list [string equal \u00fc\u0444 $x] \ - [string length $x] [string bytelength $x] + set x [selection get -type COMPOUND_TEXT] + list [string equal \u00fc\u0444 $x] [string length $x] }] - cleanupbg lappend result $selInfo -} {1 2 4 {COMPOUND_TEXT 0 4000}} -test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} unix { +} -cleanup { + cleanupbg +} -result {1 2 {COMPOUND_TEXT 0 4000}} + +test unixSelect-1.6 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg - dobg "entry .e; pack .e; update - .e insert 0 \[encoding convertfrom identity \\u00fcber\]$longValue - .e selection range 0 end" - set result [string bytelength [selection get]] +} -body { + dobg [subst -nobackslashes {entry .e; pack .e; update + .e insert 0 \u00fcber$longValue + .e selection range 0 end}] + string length [selection get] +} -cleanup { cleanupbg - set result -} [expr {5 + [string bytelength $longValue]}] -test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} unix { +} -result [expr {4 + [string length $longValue]}] + +test unixSelect-1.7 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc + .e selection range 0 end } - set x [selection get] + selection get +} -cleanup { cleanupbg - list [string equal [string repeat x 3999]\u00fc $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} unix { +} -result [string repeat x 3999]\u00fc + +test unixSelect-1.8 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc[string repeat x 3999] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc[string repeat x 3999] + .e selection range 0 end } - set x [selection get] + selection get +} -cleanup { cleanupbg - list [string equal \u00fc[string repeat x 3999] $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text} unix { +} -result \u00fc[string repeat x 3999] + +test unixSelect-1.9 {TkSelGetSelection procedure: INCR i18n text} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e selection range 0 end } - set x [selection get] + selection get +} -cleanup { cleanupbg - list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \ - [string length $x] [string bytelength $x] -} {1 8000 8001} +} -result [string repeat x 3999]\u00fc[string repeat x 4000] # Now some tests to make sure that the right thing is done when # transferring UTF8 selections, to prevent [Bug 614650] and its ilk # from rearing its ugly head again. -test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { + +test unixSelect-1.10 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc + .e selection range 0 end } - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal [string repeat x 3999]\u00fc $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { +} -result [string repeat x 3999]\u00fc + +test unixSelect-1.11 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc[string repeat x 3999] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc[string repeat x 3999] + .e selection range 0 end } - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal \u00fc[string repeat x 3999] $x] \ - [string length $x] [string bytelength $x] -} {1 4000 4001} -test unixSelect-1.13 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { +} -result \u00fc[string repeat x 3999] + +test unixSelect-1.12 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat x 3999]\u00fc[string repeat x 4000] + .e selection range 0 end } - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal [string repeat x 3999]\u00fc[string repeat x 4000] $x] \ - [string length $x] [string bytelength $x] -} {1 8000 8001} -test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} unix { +} -result [string repeat x 3999]\u00fc[string repeat x 4000] + +test unixSelect-1.13 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { + unix +} -setup { + destroy .e setupbg - entry .e - pack .e +} -body { + pack [entry .e] update - .e insert 0 [encoding convertfrom identity \u00fcber\u0444] + .e insert 0 \u00fcber\u0444 .e selection range 0 end - set result [dobg {string bytelength [selection get -type UTF8_STRING]}] - cleanupbg + dobg {string length [selection get -type UTF8_STRING]} +} -cleanup { destroy .e - set result -} {5} -test unixSelect-1.15 {TkSelGetSelection procedure: simple i18n text, utf-8} unix { + cleanupbg +} -result {5} + +test unixSelect-1.14 {TkSelGetSelection procedure: simple i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 \u00fc\u0444 - .e selection range 0 end + pack [entry .e] + update + .e insert 0 \u00fc\u0444 + .e selection range 0 end } - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal \u00fc\u0444 $x] \ - [string length $x] [string bytelength $x] -} {1 2 4} -test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { +} -result \u00fc\u0444 + +test unixSelect-1.15 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] + .e selection range 0 end } - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal [string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2121 4221} -test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { +} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21] + +test unixSelect-1.16 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - entry .e; pack .e; update - .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] - .e selection range 0 end + pack [entry .e] + update + .e insert 0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + .e selection range 0 end } - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal i[string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2122 4222} -test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { +} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + +test unixSelect-1.17 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - text .t; pack .t; update - .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] - # Has to be selected in a separate stage - .t tag add sel 1.0 21.end+1c + pack [text .t] + update + .t insert 1.0 [string repeat [string repeat \u00c4\u00e4 50]\n 21] + # Has to be selected in a separate stage + .t tag add sel 1.0 21.end+1c } after 10 - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal [string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2121 4221} -test unixSelect-1.19 {TkSelGetSelection procedure: INCR i18n text, utf-8} unix { +} -result [string repeat [string repeat \u00c4\u00e4 50]\n 21] + +test unixSelect-1.18 {TkSelGetSelection procedure: INCR i18n text, utf-8} -constraints { + unix +} -setup { setupbg +} -body { dobg { - text .t; pack .t; update - .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] - # Has to be selected in a separate stage - .t tag add sel 1.0 21.end+1c + pack [text .t] + update + .t insert 1.0 i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + # Has to be selected in a separate stage + .t tag add sel 1.0 21.end+1c } after 10 - set x [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { cleanupbg - list [string equal i[string repeat [string repeat \u00c4\u00e4 50]\n 21] $x] \ - [string length $x] [string bytelength $x] -} {1 2122 4222} -test unixSelect-1.20 {Automatic UTF8_STRING support for selection handle} unix { +} -result i[string repeat [string repeat \u00c4\u00e4 50]\n 21] + +test unixSelect-1.19 {Automatic UTF8_STRING support for selection handle} -constraints { + unix +} -setup { + destroy .l +} -body { # See Bug #666346 "Selection handling crashes under KDE 3.0" - label .l + label .l selection handle .l [list handler STRING] set selValue "This is the selection value" selection own .l - set result [selection get -type UTF8_STRING] + selection get -type UTF8_STRING +} -cleanup { destroy .l - set result -} "This is the selection value" +} -result {This is the selection value} # cleanup cleanupTests diff --git a/tests/util.test b/tests/util.test index 86271c5..c1ec6a5 100644 --- a/tests/util.test +++ b/tests/util.test @@ -6,61 +6,63 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test listbox .l -width 20 -height 5 -relief sunken -bd 2 pack .l .l insert 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 update -test util-1.1 {Tk_GetScrollInfo procedure} { - list [catch {.l yview moveto a b} msg] $msg -} {1 {wrong # args: should be ".l yview moveto fraction"}} -test util-1.2 {Tk_GetScrollInfo procedure} { - list [catch {.l yview moveto xyz} msg] $msg -} {1 {expected floating-point number but got "xyz"}} -test util-1.3 {Tk_GetScrollInfo procedure} { +test util-1.1 {Tk_GetScrollInfo procedure} -body { + .l yview moveto a b +} -returnCodes error -result {wrong # args: should be ".l yview moveto fraction"} +test util-1.2 {Tk_GetScrollInfo procedure} -body { + .l yview moveto xyz +} -returnCodes error -result {expected floating-point number but got "xyz"} +test util-1.3 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview moveto .5 .l yview -} {0.5 0.75} -test util-1.4 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll a} msg] $msg -} {1 {wrong # args: should be ".l yview scroll number units|pages"}} -test util-1.5 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll a b c} msg] $msg -} {1 {wrong # args: should be ".l yview scroll number units|pages"}} -test util-1.6 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll xyz units} msg] $msg -} {1 {expected integer but got "xyz"}} -test util-1.7 {Tk_GetScrollInfo procedure} { +} -result {0.5 0.75} +test util-1.4 {Tk_GetScrollInfo procedure} -body { + .l yview scroll a +} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +test util-1.5 {Tk_GetScrollInfo procedure} -body { + .l yview scroll a b c +} -returnCodes error -result {wrong # args: should be ".l yview scroll number units|pages"} +test util-1.6 {Tk_GetScrollInfo procedure} -body { + .l yview scroll xyz units +} -returnCodes error -result {expected integer but got "xyz"} +test util-1.7 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 pages .l nearest 0 -} {6} -test util-1.8 {Tk_GetScrollInfo procedure} { +} -result {6} +test util-1.8 {Tk_GetScrollInfo procedure} -body { .l yview 15 .l yview scroll -2 pages .l nearest 0 -} {9} -test util-1.9 {Tk_GetScrollInfo procedure} { +} -result {9} +test util-1.9 {Tk_GetScrollInfo procedure} -body { .l yview 0 .l yview scroll 2 units .l nearest 0 -} {2} -test util-1.10 {Tk_GetScrollInfo procedure} { +} -result {2} +test util-1.10 {Tk_GetScrollInfo procedure} -body { .l yview 15 .l yview scroll -2 units .l nearest 0 -} {13} -test util-1.11 {Tk_GetScrollInfo procedure} { - list [catch {.l yview scroll 3 zips} msg] $msg -} {1 {bad argument "zips": must be units or pages}} -test util-1.12 {Tk_GetScrollInfo procedure} { - list [catch {.l yview dropdead 3 times} msg] $msg -} {1 {unknown option "dropdead": must be moveto or scroll}} +} -result {13} +test util-1.11 {Tk_GetScrollInfo procedure} -body { + .l yview scroll 3 zips +} -returnCodes error -result {bad argument "zips": must be units or pages} +test util-1.12 {Tk_GetScrollInfo procedure} -body { + .l yview dropdead 3 times +} -returnCodes error -result {unknown option "dropdead": must be moveto or scroll} # cleanup cleanupTests return + diff --git a/tests/visual.test b/tests/visual.test index 1006e18..2f5c34a 100644 --- a/tests/visual.test +++ b/tests/visual.test @@ -7,8 +7,9 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands update @@ -18,7 +19,7 @@ update # use up all the slots in the colormap. # # Arguments: -# w - Name of toplevel window to create. +# w - Name of toplevel window to create. proc eatColors {w} { catch {destroy $w} @@ -27,12 +28,12 @@ proc eatColors {w} { canvas $w.c -width 400 -height 200 -bd 0 pack $w.c for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ - -fill $color - } + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } } update } @@ -43,14 +44,14 @@ proc eatColors {w} { # 0 otherwise. # # Arguments: -# w - Name of window in which to check. -# red, green, blue - Intensities to use in a trial color allocation -# to see if there are colormap entries free. +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. proc colorsFree {w {red 31} {green 245} {blue 192}} { set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ - && ([lindex $vals 2]/256 == $blue) + && ([lindex $vals 2]/256 == $blue) } # If more than one visual type is available for the screen, pick one @@ -61,233 +62,500 @@ set avail [winfo visualsavailable .] set other {} if {[llength $avail] > 1} { foreach visual $avail { - if {$visual != $default} { - set other $visual - break - } + if {$visual != $default} { + set other $visual + break + } } } testConstraint haveOtherVisual [expr {$other ne ""}] testConstraint havePseudocolorVisual [string match *pseudocolor* $avail] testConstraint haveMultipleVisuals [expr {[llength $avail] > 1}] -test visual-1.1 {Tk_GetVisual, copying from other window} { - list [catch {toplevel .t -visual .foo.bar} msg] $msg -} {1 {bad window path name ".foo.bar"}} -test visual-1.2 {Tk_GetVisual, copying from other window} {haveOtherVisual nonPortable} { - catch {destroy .t1} - catch {destroy .t2} +# ---------------------------------------------------------------------- + +test visual-1.1 {Tk_GetVisual, copying from other window} -body { + toplevel .t -visual .foo.bar +} -returnCodes error -result {bad window path name ".foo.bar"} +test visual-1.2 {Tk_GetVisual, copying from other window} -constraints { + haveOtherVisual nonPortable +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 toplevel .t2 -width 200 -height 80 -visual .t1 wm geom .t2 +5+5 concat "[winfo visual .t2] [winfo depth .t2]" -} $other -test visual-1.3 {Tk_GetVisual, copying from other window} haveOtherVisual { - catch {destroy .t1} - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result $other +test visual-1.3 {Tk_GetVisual, copying from other window} -constraints { + haveOtherVisual +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 toplevel .t2 -width 200 -height 80 -visual . wm geom .t2 +5+5 concat "[winfo visual .t2] [winfo depth .t2]" -} $default +} -cleanup { + deleteWindows +} -result $default # Make sure reference count is incremented when copying visual (the # following test will cause the colormap to be freed prematurely if # the reference count isn't incremented). -test visual-1.4 {Tk_GetVisual, colormap reference count} haveOtherVisual { - catch {destroy .t1} - catch {destroy .t2} +test visual-1.4 {Tk_GetVisual, colormap reference count} -constraints { + haveOtherVisual +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 - set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg] + set result [toplevel .t2 -gorp 80 -visual .t1] update - set result -} {1 {unknown option "-gorp"}} -test visual-1.5 {Tk_GetVisual, default colormap} { - catch {destroy .t1} + return $result +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown option "-gorp"} +test visual-1.5 {Tk_GetVisual, default colormap} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual default wm geometry .t1 +0+0 update concat "[winfo visual .t1] [winfo depth .t1]" -} $default +} -cleanup { + deleteWindows +} -result $default + + +test visual-2.1 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.2 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.3 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.4 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.5 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.6 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.7 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.8 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 24} +test visual-2.9 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.10 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.11 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.12 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.13 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.14 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.15 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.16 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {directcolor 24} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {directcolor 24} +test visual-2.17 {Tk_GetVisual, different visual types} -constraints { + nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual {truecolor 32} + wm geometry .t1 +0+0 + update + concat "[winfo visual .t1] [winfo depth .t1]" +} -cleanup { + deleteWindows +} -result {truecolor 32} -set i 1 -foreach visual $avail { - test visual-2.$i {Tk_GetVisual, different visual types} {nonPortable} { - catch {destroy .t1} - toplevel .t1 -width 250 -height 100 -visual $visual - wm geometry .t1 +0+0 - update - concat "[winfo visual .t1] [winfo depth .t1]" - } $visual - incr i -} -test visual-3.1 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} +test visual-3.1 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 \ - -visual "[winfo visual .][winfo depth .]" + -visual "[winfo visual .][winfo depth .]" wm geometry .t1 +0+0 update concat "[winfo visual .t1] [winfo depth .t1]" -} $default -test visual-3.2 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual goop20 - wm geometry .t1 +0+0 - } msg] $msg -} {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test visual-3.3 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual d - wm geometry .t1 +0+0 - } msg] $msg -} {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test visual-3.4 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual static - wm geometry .t1 +0+0 - } msg] $msg -} {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}} -test visual-3.5 {Tk_GetVisual, parsing visual string} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x" - wm geometry .t1 +0+0 - } msg] $msg -} {1 {expected integer but got "48x"}} +} -cleanup { + deleteWindows +} -result $default +test visual-3.2 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual goop20 + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test visual-3.3 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual d + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test visual-3.4 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual static + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} +test visual-3.5 {Tk_GetVisual, parsing visual string} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x" + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {expected integer but got "48x"} -test visual-4.1 {Tk_GetVisual, numerical visual id} -setup { - catch {destroy .t1} - catch {destroy .t2} - catch {destroy .t3} + +test visual-4.1 {Tk_GetVisual, numerical visual id} -constraints { + haveOtherVisual nonPortable +} -setup { + deleteWindows toplevel .t1 -width 250 -height 100 -visual $other wm geom .t1 +0+0 toplevel .t2 -width 200 -height 80 -visual [winfo visual .] wm geom .t2 +5+5 toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1] wm geom .t3 +10+10 -} -constraints {haveOtherVisual nonPortable} -body { +} -body { set v1 [list [winfo visualid .t2] [winfo visualid .t3]] set v2 [list [winfo visualid .] [winfo visualid .t1]] expr {$v1 eq $v2 ? "OK" : "[list $v1] ne [list $v2]"} -} -result OK -cleanup { - destroy .t1 .t2 .t3 -} -test visual-4.2 {Tk_GetVisual, numerical visual id} { - catch {destroy .t1} - list [catch {toplevel .t1 -visual 12xyz} msg] $msg -} {1 {bad X identifier for visual: "12xyz"}} -test visual-4.3 {Tk_GetVisual, numerical visual id} { - catch {destroy .t1} - list [catch {toplevel .t1 -visual 1291673} msg] $msg -} {1 {couldn't find an appropriate visual}} +} -cleanup { + deleteWindows +} -result OK +test visual-4.2 {Tk_GetVisual, numerical visual id} -setup { + deleteWindows +} -body { + toplevel .t1 -visual 12xyz +} -cleanup { + deleteWindows +} -returnCodes error -result {bad X identifier for visual: "12xyz"} +test visual-4.3 {Tk_GetVisual, numerical visual id} -setup { + deleteWindows +} -body { + toplevel .t1 -visual 1291673 +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't find an appropriate visual} + -test visual-5.1 {Tk_GetVisual, no matching visual} !havePseudocolorVisual { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8" - wm geometry .t1 +0+0 - } msg] $msg -} {1 {couldn't find an appropriate visual}} +test visual-5.1 {Tk_GetVisual, no matching visual} -constraints { + !havePseudocolorVisual +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8" + wm geometry .t1 +0+0 +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't find an appropriate visual} -test visual-6.1 {Tk_GetVisual, no matching visual} {havePseudocolorVisual haveMultipleVisuals nonPortable} { - catch {destroy .t1} + +test visual-6.1 {Tk_GetVisual, no matching visual} -constraints { + havePseudocolorVisual haveMultipleVisuals nonPortable +} -setup { + deleteWindows +} -body { toplevel .t1 -width 250 -height 100 -visual "best" wm geometry .t1 +0+0 update winfo visual .t1 -} {pseudocolor} +} -cleanup { + deleteWindows +} -result {pseudocolor} + # These tests are non-portable due to variations in how many colors # are already in use on the screen. - -if {[testConstraint defaultPseudocolor8]} { +test visual-7.1 {Tk_GetColormap, "new"} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { eatColors .t1 -} -test visual-7.1 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} { toplevel .t2 -width 30 -height 20 wm geom .t2 +0+0 update colorsFree .t2 -} {0} -test visual-7.2 {Tk_GetColormap, "new"} {defaultPseudocolor8 nonPortable} { - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {0} +test visual-7.2 {Tk_GetColormap, "new"} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + eatColors .t1 toplevel .t2 -width 30 -height 20 -colormap new wm geom .t2 +0+0 update colorsFree .t2 -} {1} -test visual-7.3 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {1} +test visual-7.3 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + eatColors .t1 toplevel .t3 -width 400 -height 50 -colormap new wm geom .t3 +0+0 - catch {destroy .t2} toplevel .t2 -width 30 -height 20 -colormap .t3 wm geom .t2 +0+0 update destroy .t3 colorsFree .t2 -} {1} -test visual-7.4 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {1} +test visual-7.4 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + eatColors .t1 toplevel .t3 -width 400 -height 50 -colormap new wm geom .t3 +0+0 - catch {destroy .t2} toplevel .t2 -width 30 -height 20 -colormap . wm geom .t2 +0+0 update destroy .t3 colorsFree .t2 -} {0} -test visual-7.5 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 nonPortable} { - catch {destroy .t1} - list [catch { - toplevel .t1 -width 400 -height 50 -colormap .choke.lots - } msg] $msg -} {1 {bad window path name ".choke.lots"}} -test visual-7.6 {Tk_GetColormap, copy from other window} {defaultPseudocolor8 haveOtherVisual nonPortable} { - catch {destroy .t1} - catch {destroy .t2} +} -cleanup { + deleteWindows +} -result {0} +test visual-7.5 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + toplevel .t1 -width 400 -height 50 -colormap .choke.lots +} -cleanup { + deleteWindows +} -returnCodes error -result {bad window path name ".choke.lots"} +test visual-7.6 {Tk_GetColormap, copy from other window} -constraints { + defaultPseudocolor8 haveOtherVisual nonPortable +} -setup { + deleteWindows +} -body { toplevel .t1 -width 300 -height 150 -visual $other wm geometry .t1 +0+0 - list [catch {toplevel .t2 -width 400 -height 50 -colormap .t1} msg] $msg -} {1 {can't use colormap for .t1: incompatible visuals}} -if {[testConstraint defaultPseudocolor8]} { - catch {destroy .t1} - catch {destroy .t2} -} + toplevel .t2 -width 400 -height 50 -colormap .t1 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't use colormap for .t1: incompatible visuals} + -test visual-8.1 {Tk_FreeColormap procedure} { +test visual-8.1 {Tk_FreeColormap procedure} -setup { deleteWindows +} -body { toplevel .t1 -width 300 -height 180 -colormap new wm geometry .t1 +0+0 foreach i {.t2 .t3 .t4} { - toplevel $i -width 250 -height 150 -colormap .t1 - wm geometry $i +0+0 + toplevel $i -width 250 -height 150 -colormap .t1 + wm geometry $i +0+0 } destroy .t1 destroy .t3 destroy .t4 update -} {} -test visual-8.2 {Tk_FreeColormap procedure} haveOtherVisual { +} -cleanup { deleteWindows +} -result {} +test visual-8.2 {Tk_FreeColormap procedure} -constraints haveOtherVisual -setup { + deleteWindows +} -body { toplevel .t1 -width 300 -height 180 -visual $other wm geometry .t1 +0+0 foreach i {.t2 .t3 .t4} { - toplevel $i -width 250 -height 150 -visual $other - wm geometry $i +0+0 + toplevel $i -width 250 -height 150 -visual $other + wm geometry $i +0+0 } destroy .t2 destroy .t3 destroy .t4 update -} {} +} -cleanup { + deleteWindows +} -result {} + deleteWindows rename eatColors {} @@ -296,3 +564,7 @@ rename colorsFree {} # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/visual_bb.test b/tests/visual_bb.test index 6b10f76..2b06d05 100644 --- a/tests/visual_bb.test +++ b/tests/visual_bb.test @@ -6,10 +6,12 @@ # at the window to make sure it appears as expected. Individual tests # are kept in separate ".tcl" files in this directory. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands + set auto_path ". $auto_path" wm title . "Visual Tests for Tk" @@ -21,8 +23,8 @@ proc runTest {file} { global testNum test "2.$testNum" "testing $file" {userInteraction} { - uplevel \#0 source [file join [testsDirectory] $file] - concat "" + uplevel \#0 source [file join [testsDirectory] $file] + concat "" } {} incr testNum } @@ -38,7 +40,9 @@ proc end {} { set ::EndOfVisualTests 1 } -test 1.1 "running visual tests" {userInteraction} { +# ---------------------------------------------------------------------- + +test 1.1 {running visual tests} -constraints userInteraction -body { #------------------------------------------------------- # The code below create the main window, consisting of a # menu bar and a message explaining the basic operation @@ -47,8 +51,8 @@ test 1.1 "running visual tests" {userInteraction} { frame .menu -relief raised -borderwidth 1 message .msg -font {Times 18} -relief raised -width 4i \ - -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." - + -borderwidth 1 -text "This application provides a collection of visual tests for the Tk toolkit. Each menu entry invokes a test, which displays information on the screen. You can then verify visually that the information is being displayed in the correct way. The tests under the \"Postscript\" menu exercise the Postscript-generation capabilities of canvas widgets." + pack .menu -side top -fill x pack .msg -side bottom -expand yes -fill both @@ -60,40 +64,40 @@ test 1.1 "running visual tests" {userInteraction} { menubutton .menu.file -text "File" -menu .menu.file.m menu .menu.file.m .menu.file.m add command -label "Quit" -command end - + menubutton .menu.group1 -text "Group 1" -menu .menu.group1.m menu .menu.group1.m .menu.group1.m add command -label "Canvas arcs" -command {runTest arc.tcl} .menu.group1.m add command -label "Beveled borders in text widgets" \ - -command {runTest bevel.tcl} + -command {runTest bevel.tcl} .menu.group1.m add command -label "Colormap management" \ - -command {runTest cmap.tcl} + -command {runTest cmap.tcl} .menu.group1.m add command -label "Label/button geometry" \ - -command {runTest butGeom.tcl} + -command {runTest butGeom.tcl} .menu.group1.m add command -label "Label/button colors" \ - -command {runTest butGeom2.tcl} - + -command {runTest butGeom2.tcl} + menubutton .menu.ps -text "Canvas Postscript" -menu .menu.ps.m menu .menu.ps.m .menu.ps.m add command -label "Rectangles and other graphics" \ - -command {runTest canvPsGrph.tcl} + -command {runTest canvPsGrph.tcl} .menu.ps.m add command -label "Text" \ - -command {runTest canvPsText.tcl} + -command {runTest canvPsText.tcl} .menu.ps.m add command -label "Bitmaps" \ - -command {runTest canvPsBmap.tcl} + -command {runTest canvPsBmap.tcl} .menu.ps.m add command -label "Images" \ - -command {runTest canvPsImg.tcl} + -command {runTest canvPsImg.tcl} .menu.ps.m add command -label "Arcs" \ - -command {runTest canvPsArc.tcl} - + -command {runTest canvPsArc.tcl} + pack .menu.file .menu.group1 .menu.ps -side left -padx 1m - + # Set up for keyboard-based menu traversal - + bind . <Any-FocusIn> { - if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { - focus .menu - } + if {("%d" == "NotifyVirtual") && ("%m" == "NotifyNormal")} { + focus .menu + } } tk_menuBar .menu .menu.file .menu.group1 .menu.ps @@ -103,7 +107,7 @@ test 1.1 "running visual tests" {userInteraction} { bind Canvas <1> {%W delete [%W find closest %x %y]} concat "" -} {} +} -result {} if {![testConstraint userInteraction]} { cleanupTests diff --git a/tests/winButton.test b/tests/winButton.test index 5bf6867..8bf1d01 100644 --- a/tests/winButton.test +++ b/tests/winButton.test @@ -8,77 +8,91 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands +imageInit proc bogusTrace args { error "trace aborted" } -catch {unset value} -catch {unset value2} option clear -eval image delete [image names] -if {[testConstraint testImageType]} { - image create test image1 -} -label .l -text Label -button .b -text Button -checkbutton .c -text Checkbutton -radiobutton .r -text Radiobutton -pack .l .b .c .r -update -test winbutton-1.1 {TkpComputeButtonGeometry procedure} {testImageType win} { +# ---------------------------------------------------------------------- + +test winbutton-1.1 {TkpComputeButtonGeometry procedure} -constraints { + testImageType win +} -setup { deleteWindows +} -body { image create test image1 image1 changed 0 0 0 0 60 40 label .b1 -image image1 -bd 4 -padx 0 -pady 2 button .b2 -image image1 -bd 4 -padx 0 -pady 2 - checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 -font {{MS Sans Serif} 8} - radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 -font {{MS Sans Serif} 8} + checkbutton .b3 -image image1 -bd 4 -padx 1 -pady 1 \ + -font {{MS Sans Serif} 8} + radiobutton .b4 -image image1 -bd 4 -padx 2 -pady 0 \ + -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {68 48 70 50 88 50 88 50} list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {68 48 70 50 90 52 90 52} -test winbutton-1.2 {TkpComputeButtonGeometry procedure} win { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows + image delete image1 +} -result {68 48 70 50 90 52 90 52} + +test winbutton-1.2 {TkpComputeButtonGeometry procedure} -constraints win -setup { + deleteWindows +} -body { label .b1 -bitmap question -bd 3 -padx 0 -pady 2 button .b2 -bitmap question -bd 3 -padx 0 -pady 2 - checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 -font {{MS Sans Serif} 8} - radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 -font {{MS Sans Serif} 8} + checkbutton .b3 -bitmap question -bd 3 -padx 1 -pady 1 \ + -font {{MS Sans Serif} 8} + radiobutton .b4 -bitmap question -bd 3 -padx 2 -pady 0 \ + -font {{MS Sans Serif} 8} pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {23 33 25 35 43 35 43 35} list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {23 33 25 35 45 37 45 37} -test winbutton-1.3 {TkpComputeButtonGeometry procedure} win { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {23 33 25 35 45 37 45 37} + +test winbutton-1.3 {TkpComputeButtonGeometry procedure} -constraints win -setup { + deleteWindows +} -body { label .b1 -bitmap question -bd 3 -highlightthickness 4 button .b2 -bitmap question -bd 3 -highlightthickness 0 checkbutton .b3 -bitmap question -bd 3 -highlightthickness 1 \ - -indicatoron 0 + -indicatoron 0 radiobutton .b4 -bitmap question -bd 3 -indicatoron false pack .b1 .b2 .b3 .b4 update # with patch 463234 with native L&F enabled, this returns: # {31 41 23 33 25 35 25 35} list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {31 41 23 33 27 37 27 37} -test winbutton-1.4 {TkpComputeButtonGeometry procedure} {win nonPortable} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {31 41 23 33 27 37 27 37} + +test winbutton-1.4 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -font {{MS Sans Serif} 8} checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -font {{MS Sans Serif} 8} @@ -86,26 +100,46 @@ test winbutton-1.4 {TkpComputeButtonGeometry procedure} {win nonPortable} { pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {58 24 67 33 88 30 90 28} -test winbutton-1.5 {TkpComputeButtonGeometry procedure} {win nonPortable} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {58 24 67 33 88 30 90 28} + +test winbutton-1.5 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows - label .l1 -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." -wraplength 1.5i -padx 0 -pady 0 +} -body { + label .l1 -wraplength 1.5i -padx 0 -pady 0 \ + -text "This is a long string that will wrap around on several lines.\n\nIt also has a blank line (above)." pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {178 84} -test winbutton-1.6 {TkpComputeButtonGeometry procedure} {win nonPortable} { +} -cleanup { deleteWindows - label .l1 -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." -padx 0 -pady 0 +} -result {178 84} + +test winbutton-1.6 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { + deleteWindows +} -body { + label .l1 -padx 0 -pady 0 \ + -text "This is a long string without wrapping.\n\nIt also has a blank line (above)." pack .l1 update list [winfo reqwidth .l1] [winfo reqheight .l1] -} {222 52} -test winbutton-1.7 {TkpComputeButtonGeometry procedure} {win nonPortable} { +} -cleanup { + deleteWindows +} -result {222 52} + +test winbutton-1.7 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 -width 10 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 -height 5 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 -width 20 -height 2 @@ -113,33 +147,51 @@ test winbutton-1.7 {TkpComputeButtonGeometry procedure} {win nonPortable} { pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {74 24 67 97 174 46 64 28} -test winbutton-1.8 {TkpComputeButtonGeometry procedure} {win nonPortable} { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { + deleteWindows +} -result {74 24 67 97 174 46 64 28} + +test winbutton-1.8 {TkpComputeButtonGeometry procedure} -constraints { + win nonPortable +} -setup { deleteWindows +} -body { label .b1 -text Xagqpim -bd 2 -padx 0 -pady 2 \ - -highlightthickness 4 + -highlightthickness 4 button .b2 -text Xagqpim -bd 2 -padx 0 -pady 2 \ - -highlightthickness 0 + -highlightthickness 0 checkbutton .b3 -text Xagqpim -bd 2 -padx 1 -pady 1 \ - -highlightthickness 1 -indicatoron no + -highlightthickness 1 -indicatoron no radiobutton .b4 -text Xagqpim -bd 2 -padx 2 -pady 0 -indicatoron 0 pack .b1 .b2 .b3 .b4 update list [winfo reqwidth .b1] [winfo reqheight .b1] \ - [winfo reqwidth .b2] [winfo reqheight .b2] \ - [winfo reqwidth .b3] [winfo reqheight .b3] \ - [winfo reqwidth .b4] [winfo reqheight .b4] -} {66 32 65 31 69 31 71 29} -test winbutton-1.9 {TkpComputeButtonGeometry procedure} win { + [winfo reqwidth .b2] [winfo reqheight .b2] \ + [winfo reqwidth .b3] [winfo reqheight .b3] \ + [winfo reqwidth .b4] [winfo reqheight .b4] +} -cleanup { deleteWindows +} -result {66 32 65 31 69 31 71 29} + +test winbutton-1.9 {TkpComputeButtonGeometry procedure} -constraints win -setup { + deleteWindows +} -body { button .b2 -bitmap question -default normal list [winfo reqwidth .b2] [winfo reqheight .b2] -} {23 33} +} -cleanup { + deleteWindows +} -result {23 33} # cleanup +imageFinish deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winClipboard.test b/tests/winClipboard.test index ec84362..2a7ad73 100644 --- a/tests/winClipboard.test +++ b/tests/winClipboard.test @@ -10,67 +10,113 @@ # Copyright (c) 1998-2000 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 +package require tcltest 2.2 eval tcltest::configure $argv tcltest::loadTestedCommands +namespace import -force tcltest::test # Note that these tests may fail if another application is grabbing the # clipboard (e.g. an X server) -test winClipboard-1.1 {TkSelGetSelection} win { +test winClipboard-1.1 {TkSelGetSelection} -constraints win -setup { clipboard clear - catch {selection get -selection CLIPBOARD} msg - set msg -} {CLIPBOARD selection doesn't exist or form "STRING" not defined} -test winClipboard-1.2 {TkSelGetSelection} {win testclipboard} { +} -body { + selection get -selection CLIPBOARD +} -cleanup { clipboard clear +} -returnCodes error -result {CLIPBOARD selection doesn't exist or form "STRING" not defined} + +test winClipboard-1.2 {TkSelGetSelection} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { clipboard append {} - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} {{} {}} -test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { + clipboard clear +} -result {{} {}} + +test winClipboard-1.3 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { clipboard clear +} -body { clipboard append abcd update - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} {abcd abcd} -test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { clipboard clear +} -result {abcd abcd} + +test winClipboard-1.4 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { + set map [list "\r" "\\r" "\n" "\\n"] clipboard append "line 1\nline 2" - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} [list "line 1\nline 2" "line 1\r\nline 2"] -test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} {win testclipboard} { + list [string map $map [selection get -selection CLIPBOARD]]\ + [string map $map [testclipboard]] +} -cleanup { + clipboard clear +} -result [list "line 1\\nline 2" "line 1\\nline 2"] + +test winClipboard-1.5 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { clipboard clear +} -body { + set map [list "\r" "\\r" "\n" "\\n"] clipboard append "line 1\u00c7\nline 2" - catch {selection get -selection CLIPBOARD} r1 - catch {testclipboard} r2 - list $r1 $r2 -} [list "line 1\u00c7\nline 2" [bytestring "line 1\u00c7\r\nline 2"]] + list [string map $map [selection get -selection CLIPBOARD]]\ + [string map $map [testclipboard]] +} -cleanup { + clipboard clear +} -result [list "line 1\u00c7\\nline 2" "line 1\u00c7\\nline 2"] + +test winClipboard-1.6 {TkSelGetSelection & TkWinClipboardRender} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { + clipboard append "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444" + list [selection get -selection CLIPBOARD] [testclipboard] +} -cleanup { + clipboard clear +} -result [list "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"\ + "\u043f\u0440\u0438\u0432\u0435\u0442 \u043c\u0438\u0444"] -test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} {win testclipboard} { +test winClipboard-2.1 {TkSelUpdateClipboard reentrancy problem} -constraints { + win testclipboard +} -setup { clipboard clear +} -body { clipboard append -type OUR_ACTION "action data" clipboard append "string data" update - catch {selection get -selection CLIPBOARD -type OUR_ACTION} r1 - catch {testclipboard} r2 - list $r1 $r2 -} [list "action data" "string data"] -test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} {win testclipboard} { + list [selection get -selection CLIPBOARD -type OUR_ACTION] [testclipboard] +} -cleanup { clipboard clear +} -result {{action data} {string data}} + +test winClipboard-2.2 {TkSelUpdateClipboard reentrancy problem} -constraints { + win testclipboard +} -setup { + clipboard clear +} -body { clipboard append -type OUR_ACTION "new data" clipboard append "more data in string" update - catch {testclipboard} r1 - catch {selection get -selection CLIPBOARD -type OUR_ACTION} r2 - list $r1 $r2 -} [list "more data in string" "new data"] + list [testclipboard] [selection get -selection CLIPBOARD -type OUR_ACTION] +} -cleanup { + clipboard clear +} -result {{more data in string} {new data}} # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/winDialog.test b/tests/winDialog.test index d340aee..c092e76 100644 --- a/tests/winDialog.test +++ b/tests/winDialog.test @@ -7,8 +7,9 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 1998-1999 ActiveState Corporation. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands if {[testConstraint testwinevent]} { @@ -31,6 +32,7 @@ proc start {arg} { proc then {cmd} { set ::command $cmd set ::dialogresult {} + set ::testfont {} afterbody vwait ::dialogresult @@ -39,12 +41,12 @@ proc then {cmd} { proc afterbody {} { if {$::tk_dialog == 0} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" - return - } - after 150 {afterbody} - return + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting on tk_dialog" + return + } + after 150 {afterbody} + return } uplevel #0 {set dialogresult [eval $command]} } @@ -70,7 +72,13 @@ proc SetText {id text} { return [testwinevent $::tk_dialog $id WM_SETTEXT $text] } -test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { +proc ApplyFont {font} { + set ::testfont $font +} + +# ---------------------------------------------------------------------- + +test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {tk_chooseColor} @@ -78,7 +86,7 @@ test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { Click cancel } } -result {0} -test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { +test winDialog-1.2 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} @@ -87,7 +95,7 @@ test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { } list $x $clr } -result {0 {}} -test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { +test winDialog-1.3 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { start {set clr [tk_chooseColor -initialcolor "#ff9933"]} @@ -96,9 +104,11 @@ test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { } list $x $clr } -result [list 0 "#ff9933"] -test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { +test winDialog-1.4 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent -} -setup {unset -nocomplain a x} -body { +} -setup { + catch {unset a x} +} -body { set x {} start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} then { @@ -110,9 +120,11 @@ test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { } lappend x $clr } -result [list Hello 0 "#ff9933"] -test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { +test winDialog-1.5 {Tk_ChooseColorObjCmd: -title} -constraints { testwinevent -} -setup {unset -nocomplain a x} -body { +} -setup { + catch {unset a x} +} -body { set x {} start { set clr [tk_chooseColor -initialcolor "#ff9933" \ @@ -127,9 +139,11 @@ test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { } lappend x $clr } -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] -test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { +test winDialog-1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent -} -setup {unset -nocomplain a x} -body { +} -setup { + catch {unset a x} +} -body { start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} set x {} then { @@ -143,292 +157,478 @@ test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { } list $x $clr } -result [list 1 "#ff9933"] -test winDialog-1.1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { +test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints { testwinevent } -body { tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12 } -returnCodes error -match glob -result {bad window path name*} -test winDialog-2.1 {ColorDlgHookProc} {emptyTest nt} { -} {} -test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent english} { +test winDialog-2.1 {ColorDlgHookProc} -constraints {emptyTest nt} -body {} + +test winDialog-3.1 {Tk_GetOpenFileObjCmd} -constraints { + nt testwinevent english +} -body { start {tk_getOpenFile} then { - set x [GetText cancel] - Click cancel + set x [GetText cancel] + Click cancel } - set x -} {Cancel} + return $x +} -result {Cancel} + -test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent english} { +test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints { + nt testwinevent english +} -body { start {tk_getSaveFile} then { - set x [GetText cancel] - Click cancel + set x [GetText cancel] + Click cancel } - set x -} {Cancel} + return $x +} -result {Cancel} -test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} { +test winDialog-5.1 {GetFileName: no arguments} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile -title Open} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.2 {GetFileName: one argument} {nt} { - list [catch {tk_getOpenFile -foo} msg] $msg -} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} -test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} { +} -result {0} +test winDialog-5.2 {GetFileName: one argument} -constraints { + nt +} -body { + tk_getOpenFile -foo +} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} +test winDialog-5.3 {GetFileName: many arguments} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} { - list [catch {tk_getOpenFile -foo bar -abc} msg] $msg -} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} -test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { +} -result {0} +test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { + nt +} -body { + tk_getOpenFile -foo bar -abc +} -returnCodes error -result {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} +test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { + nt testwinevent +} -body { start {tk_getOpenFile -title bar} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.7 {GetFileName: valid option, but missing value} {nt} { - list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg -} {1 {value for "-title" missing}} -test winDialog-5.8 {GetFileName: extension begins with .} {nt testwinevent} { +} -result {0} +test winDialog-5.6 {GetFileName: valid option, but missing value} -constraints { + nt +} -body { + tk_getOpenFile -initialdir bar -title +} -returnCodes error -result {value for "-title" missing} +test winDialog-5.7 {GetFileName: extension begins with .} -constraints { + nt testwinevent +} -body { # if (string[0] == '.') { -# string++; +# string++; # } start {set x [tk_getSaveFile -defaultextension .foo -title Save]} then { - SetText 0x480 bar - Click ok + SetText 0x480 bar + Click ok } string totitle $x -} [string totitle [file join [pwd] bar.foo]] -test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwinevent} { +} -result [string totitle [file join [pwd] bar.foo]] +test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { + nt testwinevent +} -body { start {set x [tk_getSaveFile -defaultextension foo -title Save]} then { - SetText 0x480 bar - Click ok + SetText 0x480 bar + Click ok } string totitle $x -} [string totitle [file join [pwd] bar.foo]] -test winDialog-5.10 {GetFileName: file types} {nt testwinevent} { -# case FILE_TYPES: +} -result [string totitle [file join [pwd] bar.foo]] +test winDialog-5.9 {GetFileName: file types} -constraints { + nt testwinevent +} -body { +# case FILE_TYPES: start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} then { - set x [GetText 0x470] - Click cancel + set x [GetText 0x470] + Click cancel } - set x -} {foo files (*.foo)} -test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} { -# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) + return $x +} -result {foo files (*.foo)} +test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { + nt +} -body { +# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) - list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg -} {1 {bad Macintosh file type "FOO"}} + tk_getSaveFile -filetypes {{"foo" .foo FOO}} +} -returnCodes error -result {bad Macintosh file type "FOO"} if {[info exists ::env(TEMP)]} { -test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} { -# case FILE_INITDIR: +test winDialog-5.11 {GetFileName: initial directory} -constraints { + nt testwinevent +} -body { +# case FILE_INITDIR: start {set x [tk_getSaveFile \ -initialdir [file normalize $::env(TEMP)] \ -initialfile "12x 455" -title Foo]} then { - Click ok + Click ok } - set x -} [file join [file normalize $::env(TEMP)] "12x 455"] + return $x +} -result [file join [file normalize $::env(TEMP)] "12x 455"] } -test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \ - {nt} { -# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) - - list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg -} {1 {user "12x" doesn't exist}} -test winDialog-5.14 {GetFileName: initial file} {nt testwinevent} { -# case FILE_INITFILE: +test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints { + nt +} -body { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + + tk_getOpenFile -initialdir ~12x/455 +} -returnCodes error -result {user "12x" doesn't exist} +test winDialog-5.13 {GetFileName: initial file} -constraints { + nt testwinevent +} -body { +# case FILE_INITFILE: start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} then { - Click ok + Click ok } string totitle $x -} [string totitle [file join [pwd] "12x 456"]] -test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} { -# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) - list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg -} {1 {user "12x" doesn't exist}} -test winDialog-5.16 {GetFileName: initial file: long name} {nt testwinevent} { +} -result [string totitle [file join [pwd] "12x 456"]] +test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints { + nt +} -body { +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) + tk_getOpenFile -initialfile ~12x/455 +} -returnCodes error -result {user "12x" doesn't exist} +test winDialog-5.15 {GetFileName: initial file: long name} -constraints { + nt testwinevent +} -body { start { set dialogresult [catch { tk_getSaveFile -initialfile [string repeat a 1024] -title Long } x] } then { - Click ok + Click ok } list $dialogresult [string match "invalid filename *" $x] -} {1 1} -test winDialog-5.17 {GetFileName: parent} {nt} { -# case FILE_PARENT: +} -result {1 1} +test winDialog-5.16 {GetFileName: parent} -constraints { + nt +} -body { +# case FILE_PARENT: toplevel .t set x 0 start {tk_getOpenFile -parent .t -title Parent; set x 1} then { - destroy .t + destroy .t } - set x -} {1} -test winDialog-5.18 {GetFileName: title} {nt testwinevent} { -# case FILE_TITLE: - + return $x +} -result {1} +test winDialog-5.17 {GetFileName: title} -constraints { + nt testwinevent +} -body { +# case FILE_TITLE: + start {tk_getOpenFile -title Narf} then { - Click cancel + Click cancel } -} {0} -test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} { -# if (ofn.lpstrFilter == NULL) +} -result {0} +test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent +} -body { +# if (ofn.lpstrFilter == NULL) - start {tk_getOpenFile -title Filter} + start {tk_getOpenFile -title Filter} then { - set x [GetText 0x470] - Click cancel + set x [GetText 0x470] + Click cancel } - set x -} {All Files (*.*)} -test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} {nt} { -# if (Tk_WindowId(parent) == None) + return $x +} -result {All Files (*.*)} +test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { + nt +} -setup { + destroy .t +} -body { +# if (Tk_WindowId(parent) == None) toplevel .t start {tk_getOpenFile -parent .t -title Open} then { - destroy .t + destroy .t } -} {} -test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} { +} -result {} +test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints { + nt +} -setup { + destroy .t +} -body { toplevel .t update start {tk_getOpenFile -parent .t -title Open} then { - destroy .t + destroy .t } -} {} -test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent english} { -# winCode = GetOpenFileName(&ofn); - +} -result {} +test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints { + nt testwinevent english +} -body { +# winCode = GetOpenFileName(&ofn); + start {tk_getOpenFile -title Open} then { - set x [GetText ok] - Click cancel + set x [GetText ok] + Click cancel } - set x -} {&Open} -test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent english} { -# winCode = GetSaveFileName(&ofn); + return $x +} -result {&Open} +test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints { + nt testwinevent english +} -body { +# winCode = GetSaveFileName(&ofn); start {tk_getSaveFile -title Save} then { - set x [GetText ok] - Click cancel + set x [GetText ok] + Click cancel } - set x -} {&Save} + return $x +} -result {&Save} if {[info exists ::env(TEMP)]} { -test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent} { +test winDialog-5.23 {GetFileName: convert \ to /} -constraints { + nt testwinevent +} -body { start {set x [tk_getSaveFile -title Back]} then { - SetText 0x480 [file nativename \ + SetText 0x480 [file nativename \ [file join [file normalize $::env(TEMP)] "12x 457"]] - Click ok + Click ok } - set x -} [file join [file normalize $::env(TEMP)] "12x 457"] + return $x +} -result [file join [file normalize $::env(TEMP)] "12x 457"] } -test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} { +test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { + nt +} -body { # MacOS type that is correct, but has embedded nulls. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} then { - Click cancel + Click cancel } - set x -} {0} -test winDialog-5.26 {GetFileName: file types: MakeFilter() succeeds} {nt} { + return $x +} -result {0} +test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraints { + nt +} -body { # MacOS type that is correct, but has embedded high-bit chars. start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} then { - Click cancel + Click cancel } - set x -} {0} + return $x +} -result {0} + + +test winDialog-6.1 {MakeFilter} -constraints {emptyTest nt} -body {} + + +test winDialog-7.1 {Tk_MessageBoxObjCmd} -constraints {emptyTest nt} -body {} -test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {} -test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {} +test winDialog-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {} -test winDialog-8.1 {OFNHookProc} {emptyTest nt} {} {} ## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows ## because somehow the GetOpenFileName ends up a noop in the static ## build. ## -test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} {nt testwinevent} { +test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { + nt testwinevent +} -body { start {tk_chooseDirectory} then { - Click cancel + Click cancel } -} {0} -test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} {nt} { - list [catch {tk_chooseDirectory -foo} msg] $msg -} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} -test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} {nt testwinevent} { +} -result {0} +test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { + nt +} -body { + tk_chooseDirectory -foo +} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} +test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} -constraints { + nt testwinevent +} -body { start { - tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test + tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test } then { - Click cancel + Click cancel } -} {0} -test winDialog-9.4 {Tk_ChooseDirectoryObjCmd:\ - Tcl_GetIndexFromObj() != TCL_OK} {nt} { - list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg -} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} -test winDialog-9.5 {Tk_ChooseDirectoryObjCmd:\ - Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { +} -result {0} +test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints { + nt +} -body { + tk_chooseDirectory -foo bar -abc +} -returnCodes error -result {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title} +test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} -constraints { + nt testwinevent +} -body { start {tk_chooseDirectory -title bar} then { - Click cancel + Click cancel } -} {0} -test winDialog-9.6 {Tk_ChooseDirectoryObjCmd:\ - valid option, but missing value} {nt} { - list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg -} {1 {value for "-title" missing}} -test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt testwinevent} { -# case DIR_INITIAL: +} -result {0} +test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints { + nt +} -body { + tk_chooseDirectory -initialdir bar -title +} -returnCodes error -result {value for "-title" missing} +test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints { + nt testwinevent +} -body { +# case DIR_INITIAL: start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} then { - Click ok + Click ok } string tolower [set x] -} {c:/} -test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\ - initial directory: Tcl_TranslateFilename()} {nt} { -# if (Tcl_TranslateFileName(interp, string, -# &utfDirString) == NULL) - - list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg -} {1 {user "12x" doesn't exist}} +} -result {c:/} +test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints { + nt +} -body { +# if (Tcl_TranslateFileName(interp, string, +# &utfDirString) == NULL) + + tk_chooseDirectory -initialdir ~12x/455 +} -returnCodes error -result {user "12x" doesn't exist} + + +test winDialog-10.1 {Tk_FontchooserObjCmd: no arguments} -constraints { + nt testwinevent +} -body { + start {tk fontchooser show} + list [then { + Click cancel + }] $::testfont +} -result {0 {}} +test winDialog-10.2 {Tk_FontchooserObjCmd: -initialfont} -constraints { + nt testwinevent +} -body { + start { + tk fontchooser configure -command ApplyFont -font system + tk fontchooser show + } + list [then { + Click cancel + }] $::testfont +} -result {0 {}} +test winDialog-10.3 {Tk_FontchooserObjCmd: -initialfont} -constraints { + nt testwinevent +} -body { + start { + tk fontchooser configure -command ApplyFont -font system + tk fontchooser show + } + list [then { + Click 1 + }] [expr {[llength $::testfont] ne {}}] +} -result {0 1} +test winDialog-10.4 {Tk_FontchooserObjCmd: -title} -constraints { + nt testwinevent +} -body { + start { + tk fontchooser configure -command ApplyFont -title "tk test" + tk fontchooser show + } + list [then { + Click cancel + }] $::testfont +} -result {0 {}} +test winDialog-10.5 {Tk_FontchooserObjCmd: -parent} -constraints { + nt testwinevent +} -setup { + array set a {parent {}} +} -body { + start { + tk fontchooser configure -command ApplyFont -parent . + tk fontchooser show + } + then { + array set a [testgetwindowinfo $::tk_dialog] + Click cancel + } + list [expr {$a(parent) == [wm frame .]}] $::testfont +} -result {1 {}} +test winDialog-10.6 {Tk_FontchooserObjCmd: -apply} -constraints { + nt testwinevent +} -body { + start { + tk fontchooser configure -command FooBarBaz + tk fontchooser show + } + then { + Click cancel + } +} -result 0 +test winDialog-10.7 {Tk_FontchooserObjCmd: -apply} -constraints { + nt testwinevent +} -body { + start { + tk fontchooser configure -command ApplyFont -parent . + tk fontchooser show + } + list [then { + Click [expr {0x0402}] ;# value from XP + Click cancel + }] [expr {[llength $::testfont] > 0}] +} -result {0 1} +test winDialog-10.8 {Tk_FontchooserObjCmd: -title} -constraints { + nt testwinevent +} -setup { + array set a {text failed} +} -body { + start { + tk fontchooser configure -command ApplyFont -title "Hello" + tk fontchooser show + } + then { + array set a [testgetwindowinfo $::tk_dialog] + Click cancel + } + set a(text) +} -result "Hello" +test winDialog-10.9 {Tk_FontchooserObjCmd: -title} -constraints { + nt testwinevent +} -setup { + array set a {text failed} +} -body { + start { + tk fontchooser configure -command ApplyFont \ + -title "\u041f\u0440\u0438\u0432\u0435\u0442" + tk fontchooser show + } + then { + array set a [testgetwindowinfo $::tk_dialog] + Click cancel + } + set a(text) +} -result "\u041f\u0440\u0438\u0432\u0435\u0442" if {[testConstraint testwinevent]} { catch {testwinevent debug 0} @@ -437,3 +637,8 @@ if {[testConstraint testwinevent]} { # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winFont.test b/tests/winFont.test index c61d124..8039426 100644 --- a/tests/winFont.test +++ b/tests/winFont.test @@ -1,48 +1,28 @@ -# This file is a Tcl script to test out the procedures in tkWinFont.c. +# This file is a Tcl script to test out the procedures in tkWinFont.c. # It is organized in the standard fashion for Tcl tests. # # Many of these tests are visually oriented and cannot be checked # programmatically (such as "does an underlined font appear to be # underlined?"); these tests attempt to exercise the code in question, -# but there are no results that can be checked. +# but there are no results that can be checked. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -catch {destroy .b} -catch {font delete xyz} -toplevel .b -wm geometry .b +0+0 -update idletasks - -set courier {Courier 14} -set cx [font measure $courier 0] - -label .b.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed -pack .b.l -canvas .b.c -closeenough 0 - -set t [.b.c create text 0 0 -anchor nw -just left -font $courier] -pack .b.c -update - -set ax [winfo reqwidth .b.l] -set ay [winfo reqheight .b.l] -proc getsize {} { - update - return "[winfo reqwidth .b.l] [winfo reqheight .b.l]" -} - -test winfont-1.1 {TkpGetNativeFont procedure: not native} win { - list [catch {font measure {} xyz} msg] $msg -} {1 {font "" doesn't exist}} -test winfont-1.2 {TkpGetNativeFont procedure: native} win { +test winfont-1.1 {TkpGetNativeFont procedure: not native} -constraints { + win +} -body { + catch {font delete xyz} + font measure {} xyz +} -returnCodes error -result {font "" doesn't exist} +test winfont-1.2 {TkpGetNativeFont procedure: native} -constraints win -body { font measure ansifixed 0 font measure ansi 0 font measure device 0 @@ -50,135 +30,363 @@ test winfont-1.2 {TkpGetNativeFont procedure: native} win { font measure systemfixed 0 font measure system 0 set x {} -} {} - -test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} win { - expr [font actual {-size -10} -size]>0 -} {1} -test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} win { - expr [font actual {-family Arial} -size]>0 -} {1} -test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} win { +} -result {} + + +test winfont-2.1 {TkpGetFontFromAttributes procedure: pointsize} -constraints { + win +} -body { + expr {[font actual {-size -10} -size] > 0} +} -result {1} +test winfont-2.2 {TkpGetFontFromAttributes procedure: pointsize} -constraints { + win +} -body { + expr {[font actual {-family Arial} -size] > 0} +} -result {1} +test winfont-2.3 {TkpGetFontFromAttributes procedure: normal weight} -constraints { + win +} -body { font actual {-weight normal} -weight -} {normal} -test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} win { +} -result {normal} +test winfont-2.4 {TkpGetFontFromAttributes procedure: bold weight} -constraints { + win +} -body { font actual {-weight bold} -weight -} {bold} -test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} win { +} -result {bold} +test winfont-2.5 {TkpGetFontFromAttributes procedure: no family} -constraints { + win +} -body { catch {expr {[font actual {-size 10} -size]}} -} 0 -test winfont-2.6 {TkpGetFontFromAttributes procedure: family} win { +} -result 0 +test winfont-2.6 {TkpGetFontFromAttributes procedure: family} -constraints { + win +} -body { font actual {-family Arial} -family -} {Arial} -test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} win { +} -result {Arial} +test winfont-2.7 {TkpGetFontFromAttributes procedure: Times fonts} -constraints { + win +} -setup { set x {} +} -body { lappend x [font actual {-family "Times"} -family] lappend x [font actual {-family "New York"} -family] lappend x [font actual {-family "Times New Roman"} -family] -} {{Times New Roman} {Times New Roman} {Times New Roman}} -test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} win { +} -result {{Times New Roman} {Times New Roman} {Times New Roman}} +test winfont-2.8 {TkpGetFontFromAttributes procedure: Courier fonts} -constraints { + win +} -setup { set x {} +} -body { lappend x [font actual {-family "Courier"} -family] lappend x [font actual {-family "Monaco"} -family] lappend x [font actual {-family "Courier New"} -family] -} {{Courier New} {Courier New} {Courier New}} -test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} win { +} -result {{Courier New} {Courier New} {Courier New}} +test winfont-2.9 {TkpGetFontFromAttributes procedure: Helvetica fonts} -constraints { + win +} -setup { set x {} +} -body { lappend x [font actual {-family "Helvetica"} -family] lappend x [font actual {-family "Geneva"} -family] lappend x [font actual {-family "Arial"} -family] -} {Arial Arial Arial} -test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} win { +} -result {Arial Arial Arial} +test winfont-2.10 {TkpGetFontFromAttributes procedure: fallback} -constraints { + win +} -body { # No way to get it to fail! Any font name is acceptable. -} {} +} -result {} -test winfont-3.1 {TkpDeleteFont procedure} win { + +test winfont-3.1 {TkpDeleteFont procedure} -constraints win -body { + catch {font delete xyz} font actual {-family xyz} set x {} -} {} +} -result {} + -test winfont-4.1 {TkpGetFontFamilies procedure} win { +test winfont-4.1 {TkpGetFontFamilies procedure} -constraints win -body { font families set x {} -} {} - -test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} win { - .b.l config -wrap 0 -text "000000" - getsize -} "[expr $ax*6] $ay" -test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} win { - .b.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" - getsize -} "[expr $ax*256] $ay" -test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} win { - .b.l config -wrap [expr $ax*10] -text "00000000" - getsize -} "[expr $ax*8] $ay" -test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} win { - .b.l config -wrap [expr $ax*6] -text "00000000" - getsize -} "[expr $ax*6] [expr $ay*2]" -test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} win { - .b.c dchars $t 0 end - .b.c insert $t 0 "0000" - .b.c index $t @[expr int($cx*2.5)],1 -} {2} -test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} win { - .b.l config -text "000000" -wrap 1 - getsize -} "$ax [expr $ay*6]" -test winfont-5.7 {Tk_MeasureChars procedure: whole words} win { - .b.l config -wrap [expr $ax*8] -text "000000 0000" - getsize -} "[expr $ax*6] [expr $ay*2]" -test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} win { - .b.l config -wrap [expr $ax*12] -text "000000 0000000" - getsize -} "[expr $ax*7] [expr $ay*2]" -test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} win { - .b.l config -wrap [expr $ax*12] -text "000 00 00000" - getsize -} "[expr $ax*7] [expr $ay*2]" -test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} win { - .b.l config -wrap [expr $ax*12] -text "0000000000000000" - getsize -} "[expr $ax*12] [expr $ay*2]" -test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} \ - {win nonPortable} { - set font [.b.l cget -font] - .b.l config -font {{MS Sans Serif} 8} -text "W" - set width [winfo reqwidth .b.l] - .b.l config -text "XaYoYaKaWx" +} -result {} + +destroy .t +toplevel .t +wm geometry .t +0+0 +update idletasks +label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left -text "0" -font systemfixed +pack .t.l +canvas .t.c -closeenough 0 + +set courier {Courier 14} +set cx [font measure $courier 0] +set t [.t.c create text 0 0 -anchor nw -just left -font $courier] +pack .t.c +update + +set ax [winfo reqwidth .t.l] +set ay [winfo reqheight .t.l] +proc getsize {} { + update + return "[winfo reqwidth .t.l] [winfo reqheight .t.l]" +} + +test winfont-5.1 {Tk_MeasureChars procedure: unbounded right margin} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap 0 -text "000000" + list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.2 {Tk_MeasureChars procedure: static width buffer exceeded} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap 100000 -text "0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000" + list [expr {[winfo reqwidth .t.l] eq 256*$ax}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.3 {Tk_MeasureChars procedure: all chars did fit} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*10] -text "00000000" + list [expr {[winfo reqwidth .t.l] eq 8*$ax}] \ + [expr {[winfo reqheight .t.l] eq $ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.4 {Tk_MeasureChars procedure: not all chars fit} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*6] -text "00000000" + list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.5 {Tk_MeasureChars procedure: include last partial char} -constraints { + win +} -setup { + destroy .t.c +} -body { + canvas .t.c -closeenough 0 + set t [.t.c create text 0 0 -anchor nw -just left -font $courier] + pack .t.c + update + + .t.c dchars $t 0 end + .t.c insert $t 0 "0000" + .t.c index $t @[expr int($cx*2.5)],1 +} -cleanup { + destroy .t.c +} -result {2} + +test winfont-5.6 {Tk_MeasureChars procedure: at least one char on line} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -text "000000" -wrap 1 + list [expr {[winfo reqwidth .t.l] eq $ax}] \ + [expr {[winfo reqheight .t.l] eq 6*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.7 {Tk_MeasureChars procedure: whole words} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*8] -text "000000 0000" + list [expr {[winfo reqwidth .t.l] eq 6*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.8 {Tk_MeasureChars procedure: already saw space in line} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*12] -text "000000 0000000" + list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.9 {Tk_MeasureChars procedure: internal spaces significant} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*12] -text "000 00 00000" + list [expr {[winfo reqwidth .t.l] eq 7*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.10 {Tk_MeasureChars procedure: make first part of word fit} -constraints { + win +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + set ax [winfo reqwidth .t.l] + set ay [winfo reqheight .t.l] + + .t.l config -wrap [expr $ax*12] -text "0000000000000000" + list [expr {[winfo reqwidth .t.l] eq 12*$ax}] \ + [expr {[winfo reqheight .t.l] eq 2*$ay}] +} -cleanup { + destroy .t.l +} -result {1 1} + +test winfont-5.11 {Tk_MeasureChars procedure: check for kerning} -constraints { + win nonPortable +} -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + + set font [.t.l cget -font] + .t.l config -font {{MS Sans Serif} 8} -text "W" + set width [winfo reqwidth .t.l] + .t.l config -text "XaYoYaKaWx" set x [lindex [getsize] 0] - .b.l config -font $font + .t.l config -font $font expr $x < ($width*10) -} 1 +} -cleanup { + destroy .t.l +} -result {1} -test winfont-6.1 {Tk_DrawChars procedure: loop test} win { - .b.l config -text "a" + +test winfont-6.1 {Tk_DrawChars procedure: loop test} -constraints win -setup { + destroy .t.l +} -body { + label .t.l -padx 0 -pady 0 -bd 0 -highlightthickness 0 -justify left \ + -text "0" -font systemfixed + pack .t.l + update + .t.l config -text "a" update -} {} +} -cleanup { + destroy .t.l +} -result {} + -test winfont-7.1 {AllocFont procedure: use old font} win { +test winfont-7.1 {AllocFont procedure: use old font} -constraints win -setup { + destroy .c +} -setup { + catch {font delete xyz} +} -body { font create xyz - catch {destroy .c} button .c -font xyz font configure xyz -family times update destroy .c font delete xyz -} {} -test winfont-7.2 {AllocFont procedure: extract info from logfont} win { +} -result {} +test winfont-7.2 {AllocFont procedure: extract info from logfont} -constraints { + win +} -body { font actual {arial 10 bold italic underline overstrike} -} {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1} -test winfont-7.3 {AllocFont procedure: extract info from textmetric} win { +} -result {-family Arial -size 10 -weight bold -slant italic -underline 1 -overstrike 1} +test winfont-7.3 {AllocFont procedure: extract info from textmetric} -constraints { + win +} -body { font metric {arial 10 bold italic underline overstrike} -fixed -} {0} -test winfont-7.4 {AllocFont procedure: extract info from textmetric} win { +} -result {0} +test winfont-7.4 {AllocFont procedure: extract info from textmetric} -constraints { + win +} -body { font metric systemfixed -fixed -} {1} +} -result {1} # cleanup -destroy .b cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winMenu.test b/tests/winMenu.test index 7240bf5..ce2069f 100644 --- a/tests/winMenu.test +++ b/tests/winMenu.test @@ -7,140 +7,183 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -test winMenu-1.1 {GetNewID} win { - catch {destroy .m1} - list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} +test winMenu-1.1 {GetNewID} -constraints win -setup { + destroy .m1 +} -body { + menu .m1 +} -cleanup { + destroy .m1 +} -returnCodes ok -result {.m1} +test winMenu-1.2 {GetNewID} -constraints win -setup { + destroy .m1 +} -body { + menu .m1 + destroy .m1 +} -result {} + + # Basically impossible to test menu IDs wrapping. -test winMenu-2.1 {FreeID} win { - catch {destroy .m1} +test winMenu-2.1 {FreeID} -constraints win -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} + destroy .m1 +} -returnCodes ok -test winMenu-3.1 {TkpNewMenu} win { - catch {destroy .m1} + +test winMenu-3.1 {TkpNewMenu} -constraints win -setup { + destroy .m1 +} -body { list [catch {menu .m1} msg] $msg [catch {destroy .m1} msg2] $msg2 -} {0 .m1 0 {}} -test winMenu-3.2 {TkpNewMenu} win { - catch {destroy .m1} +} -result {0 .m1 0 {}} +test winMenu-3.2 {TkpNewMenu} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label "foo" list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 -} {0 {} {} 0 {}} +} -result {0 {} {} 0 {}} + -test winMenu-4.1 {TkpDestroyMenu} win { - catch {destroy .m1} +test winMenu-4.1 {TkpDestroyMenu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 - list [catch {destroy .m1} msg] $msg -} {0 {}} -test winMenu-4.2 {TkpDestroyMenu - help menu} win { - catch {destroy .m1} + destroy .m1 +} -returnCodes ok +test winMenu-4.2 {TkpDestroyMenu - help menu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -menu .m1.system . configure -menu .m1 list [catch {destroy .m1.system} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} +} -result {0 {} {} {}} + -test winMenu-5.1 {TkpDestroyMenuEntry} win { - catch {destroy .m1} +test winMenu-5.1 {TkpDestroyMenuEntry} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label "test" update idletasks list [catch {.m1 delete 1} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-6.1 {GetEntryText} win { - catch {destroy .m1} + +test winMenu-6.1 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { list [catch {menu .m1} msg] $msg [destroy .m1] -} {0 .m1 {}} -test winMenu-6.2 {GetEntryText} {testImageType win} { - catch {destroy .m1} +} -result {0 .m1 {}} +test winMenu-6.2 {GetEntryText} -constraints { + testImageType win +} -setup { + destroy .m1 +} -body { catch {image delete image1} menu .m1 image create test image1 list [catch {.m1 add command -image image1} msg] $msg [destroy .m1] [image delete image1] -} {0 {} {} {}} -test winMenu-6.3 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-6.3 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -bitmap questhead} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.4 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.4 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.5 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.5 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "foo"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.6 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.6 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "This string has one & in it"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.7 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.7 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.8 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.8 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.9 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.9 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "foo" -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.10 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.10 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.11 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.11 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.12 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.12 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.13 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.13 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "foo" -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.14 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.14 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "This string has one & in it" -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.15 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.15 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The & should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-6.16 {GetEntryText} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-6.16 {GetEntryText} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command -label "The * should be underlined." -underline 4 -accel "&bar"} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} win { - catch {destroy .m1} +test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -menu .m1.system menu .m1.system @@ -148,103 +191,140 @@ test winMenu-7.1 {ReconfigureWindowsMenu - system menu item removal} win { update idletasks .m1.system add command -label bar list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.2 {ReconfigureWindowsMenu - menu item removal} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label Hello update idletasks .m1 add command -label foo list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.3 {ReconfigureWindowsMenu - zero items} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.3 {ReconfigureWindowsMenu - zero items} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello .m1 delete Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.4 {ReconfigureWindowsMenu - one item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.4 {ReconfigureWindowsMenu - one item} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.5 {ReconfigureWindowsMenu - two items} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.5 {ReconfigureWindowsMenu - two items} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label One .m1 add command -label Two list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.6 {ReconfigureWindowsMenu - separator item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.6 {ReconfigureWindowsMenu - separator item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add separator list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.7 {ReconfigureWindowsMenu - non-text item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.8 {ReconfigureWindowsMenu - disabled item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello -state disabled list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.9 {ReconfigureWindowsMenu - non-selected checkbutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add checkbutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.10 {ReconfigureWindowsMenu - non-selected radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add radiobutton -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.11 {ReconfigureWindowsMenu - selected checkbutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add checkbutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.12 {ReconfigureWindowsMenu - selected radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add radiobutton -label Hello .m1 invoke Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.13 {ReconfigureWindowsMenu - cascade missing} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-7.14 {ReconfigureWindowsMenu - cascade} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-7.14 {ReconfigureWindowsMenu - cascade} -constraints win -setup { + destroy .m1 +} -body { catch {destroy .m2} menu .m1 -tearoff 0 menu .m2 .m1 add cascade -menu .m2 -label Hello list [catch {update idletasks} msg] $msg [destroy .m1] [destroy .m2] -} {0 {} {} {}} -test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.15 {ReconfigureWindowsMenu - menubar without system menu} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.file menu .m1.file -tearoff 0 . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 @@ -252,17 +332,23 @@ test winMenu-7.16 {ReconfigureWindowsMenu - system menu already created} win { update idletasks .m1.system add command -label Hello list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.17 {ReconfigureWindowsMenu - system menu update pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add cascade -menu .m1.system menu .m1.system -tearoff 0 @@ -270,521 +356,717 @@ test winMenu-7.18 {ReconfigureWindowsMenu - system menu update not pending} win update idletasks . configure -menu .m1 list [catch {update idletasks} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} -test winMenu-7.19 {ReconfigureWindowsMenu - column break} win { - catch {destroy .m1} +} -result {0 {} {} {}} +test winMenu-7.19 {ReconfigureWindowsMenu - column break} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 list [catch {update idletasks} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} + #Don't know how to generate nested post menus -test winMenu-8.1 {TkpPostMenu} win { - catch {destroy .m1} + +test winMenu-8.1 {TkpPostMenu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -postcommand "blork" - list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {1 {invalid command name "blork"} {}} -test winMenu-8.2 {TkpPostMenu} win { - catch {destroy .m1} + .m1 post 40 40 +} -returnCodes error -result {invalid command name "blork"} +test winMenu-8.2 {TkpPostMenu} -constraints win -setup { + destroy .m1 +} -body { + menu .m1 -postcommand "blork" + .m1 post 40 40 + destroy .m1 +} -returnCodes error -result {invalid command name "blork"} +test winMenu-8.3 {TkpPostMenu} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -postcommand "destroy .m1" list [.m1 post 40 40] [winfo exists .m1] -} {{} 0} -test winMenu-8.3 {TkpPostMenu - popup menu} {win userInteraction} { - catch {destroy .m1} +} -result {{} 0} +test winMenu-8.4 {TkpPostMenu - popup menu} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-8.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-8.4 {TkpPostMenu - menu button} {win userInteraction} { - catch {destroy .mb} +} -result {{} {}} +test winMenu-8.5 {TkpPostMenu - menu button} -constraints { + win userInteraction +} -setup { + destroy .mb +} -body { menubutton .mb -text test -menu .mb.menu menu .mb.menu .mb.menu add command -label "winMenu-8.4 - Hit ESCAPE." pack .mb - list [tk::MbPost .mb] [destroy .m1] -} {{} {}} -test winMenu-8.5 {TkpPostMenu - update not pending} {win userInteraction} { - catch {destroy .m1} + list [tk::MbPost .mb] [destroy .mb] +} -result {{} {}} +test winMenu-8.6 {TkpPostMenu - update not pending} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-8.5 - Hit ESCAPE." update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-9.1 {TkpMenuNewEntry} win { - catch {destroy .m1} + +test winMenu-9.1 {TkpMenuNewEntry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 list [catch {.m1 add command} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} + -test winMenu-10.1 {TkwinMenuProc} {win userInteraction} { - catch {destroy .m1} +test winMenu-10.1 {TkwinMenuProc} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-10.1: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} + # Can't generate a WM_INITMENU without a Tk menu yet. -test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} {win userInteraction} { - catch {destroy .m1} + +test winMenu-11.1 {TkWinHandleMenuEvent - WM_INITMENU} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 -postcommand "set foo test" .m1 add command -label "winMenu-11.1: Hit ESCAPE." list [.m1 post 40 40] [set foo] [unset foo] [destroy .m1] -} {test test {} {}} -test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} {win userInteraction} { - catch {destroy .m1} +} -result {test test {} {}} +test winMenu-11.2 {TkWinHandleMenuEvent - WM_COMMAND} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { catch {unset foo} menu .m1 .m1 add checkbutton -variable foo -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] -} {{} {} 1 {} {}} -test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} {win userInteraction} { - catch {destroy .m1} +} -result {{} {} 1 {} {}} +test winMenu-11.3 {TkWinHandleMenuEvent - WM_COMMAND} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { catch {unset foo} proc bgerror {args} { - global foo errorInfo - set foo [list $args $errorInfo] + global foo errorInfo + set foo [list $args $errorInfo] } menu .m1 .m1 add command -command {error 1} -label "winMenu-11.2: Please select this menu item." list [.m1 post 40 40] [update] [set foo] [unset foo] [destroy .m1] -} {{} {} {1 {1 +} -result {{} {} {1 {1 while executing "error 1" (menu invoke)}} {} {}} + # Can't test WM_MENUCHAR -test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} {win userInteraction} { - catch {destroy .m1} + +test winMenu-11.4 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-11.3: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.5 {TkWinHandleMenuEvent - WM_MEASUREITEM} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label "winMenu-11.4: Hit ESCAPE" -hidemargin 1 list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.6 {TkWinHandleMenuEvent - WM_DRAWITEM} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-11.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} \ - {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.7 {TkWinHandleMenuEvent - WM_DRAWITEM - item disabled} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-11.6: Hit ESCAPE." -state disabled list [.m1 post 40 40] [destroy .m1] -} {{} {}} -test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} \ - {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-11.8 {TkWinHandleMenuEvent - WM_INITMENU - not pending} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label "winMenu-11.7: Hit ESCAPE" update idletasks list [catch {.m1 post 40 40} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} -test winMenu-12.1 {TkpSetWindowMenuBar} win { - catch {destroy .m1} + +test winMenu-12.1 {TkpSetWindowMenuBar} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label foo list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [catch {destroy .m1} msg2] $msg2 -} {0 {} {} 0 {}} -test winMenu-12.2 {TkpSetWindowMenuBar} win { - catch {destroy .m1} +} -result {0 {} {} 0 {}} +test winMenu-12.2 {TkpSetWindowMenuBar} -constraints win -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 .m1 add command -label foo . configure -menu .m1 list [catch {. configure -menu ""} msg] $msg [catch {destroy .m1} msg2] $msg2 -} {0 {} 0 {}} -test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} win { - catch {destroy .m1} +} -result {0 {} 0 {}} +test winMenu-12.3 {TkpSetWindowMenuBar - no update pending} -constraints { + win +} -setup { + destroy .m1 +} -body { . configure -menu "" menu .m1 -tearoff 0 .m1 add command -label foo update idletasks list [catch {. configure -menu .m1} msg] $msg [. configure -menu ""] [destroy .m1] -} {0 {} {} {}} +} -result {0 {} {} {}} + + +test winMenu-13.1 {TkpSetMainMenubar - nothing to do} -constraints { + emptyTest win +} -body {} -test winMenu-13.1 {TkpSetMainMenubar - nothing to do} {emptyTest win} {} {} -test winMenu-14.1 {GetMenuIndicatorGeometry} win { - catch {destroy .m1} +test winMenu-14.1 {GetMenuIndicatorGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test winMenu-14.2 {GetMenuIndicatorGeometry} win { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test winMenu-14.2 {GetMenuIndicatorGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -hidemargin 1 - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok -test winMenu-15.1 {GetMenuAccelGeometry} win { - catch {destroy .m1} + +test winMenu-15.1 {GetMenuAccelGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo -accel Ctrl+U - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test winMenu-15.2 {GetMenuAccelGeometry} win { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test winMenu-15.2 {GetMenuAccelGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} -test winMenu-15.3 {GetMenuAccelGeometry} win { - catch {destroy .m1} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok +test winMenu-15.3 {GetMenuAccelGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok + -test winMenu-16.1 {GetTearoffEntryGeometry} {win userInteraction} { - catch {destroy .m1} +test winMenu-16.1 {GetTearoffEntryGeometry} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-19.1: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-17.1 {GetMenuSeparatorGeometry} win { - catch {destroy .m1} + +test winMenu-17.1 {GetMenuSeparatorGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator - list [catch {tk::TearOffMenu .m1 40 40}] [destroy .m1] -} {0 {}} + tk::TearOffMenu .m1 40 40 + destroy .m1 +} -returnCodes ok + # Currently, the only callers to DrawWindowsSystemBitmap want things # centered vertically, and either centered or right aligned horizontally. -test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} win { - catch {destroy .m1} +test winMenu-18.1 {DrawWindowsSystemBitmap - center aligned} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-18.2 {DrawWindowsSystemBitmap - right aligned} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} \ - win { - catch {destroy .m1} +test winMenu-19.1 {DrawMenuEntryIndicator - not checkbutton or radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.2 {DrawMenuEntryIndicator - not selected} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.2 {DrawMenuEntryIndicator - not selected} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.3 {DrawMenuEntryIndicator - checkbutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.4 {DrawMenuEntryIndicator - radiobutton} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add radiobutton -label foo .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.5 {DrawMenuEntryIndicator - disabled} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.5 {DrawMenuEntryIndicator - disabled} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke foo .m1 entryconfigure foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-19.6 {DrawMenuEntryIndicator - indicator not on} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -indicatoron 0 .m1 invoke foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} win { - catch {destroy .m1} + +test winMenu-20.1 {DrawMenuEntryAccelerator - disabled} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground red .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.2 {DrawMenuEntryAccelerator - normal text} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -accel "Ctrl+U" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.3 {DrawMenuEntryAccelerator - disabled, no disabledforeground} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -accel "Ctrl+U" -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.4 {DrawMenuEntryAccelerator - cascade, drawArrow true} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} \ - {win userInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-20.5 {DrawMenuEntryAccelerator - cascade, drawArrow false} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label "winMenu-23.5: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-21.1 {DrawMenuSeparator} win { - catch {destroy .m1} +test winMenu-21.1 {DrawMenuSeparator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-22.1 {DrawMenuUnderline} win { - catch {destroy .m1} +test winMenu-22.1 {DrawMenuUnderline} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -underline 0 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-23.1 {Don't know how to test MenuKeyBindProc} \ - {win emptyTest} {} {} -test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} \ - {win emptyTest} {} {} -test winMenu-25.1 {DrawMenuEntryLabel - normal} win { - catch {destroy .m1} +test winMenu-23.1 {Don't know how to test MenuKeyBindProc} -constraints { + win emptyTest +} -body {} + + +test winMenu-24.1 {TkpInitializeMenuBindings called at boot time} -constraints { + win emptyTest +} -body {} + + +test winMenu-25.1 {DrawMenuEntryLabel - normal} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-25.2 {DrawMenuEntryLabel - disabled with fg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground red .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-25.3 {DrawMenuEntryLabel - disabled with no fg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-26.1 {TkpComputeMenubarGeometry} win { - catch {destroy .m1} +test winMenu-26.1 {TkpComputeMenubarGeometry} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File list [. configure -menu .m1] [. configure -menu ""] [destroy .m1] -} {{} {} {}} +} -result {{} {} {}} -test winMenu-27.1 {DrawTearoffEntry} {win userInteraction} { - catch {destroy .m1} + +test winMenu-27.1 {DrawTearoffEntry} -constraints { + win userInteraction +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "winMenu-24.4: Hit ESCAPE." list [.m1 post 40 40] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-28.1 {TkpConfigureMenuEntry - update pending} win { - catch {destroy .m1} +test winMenu-28.1 {TkpConfigureMenuEntry - update pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label Hello list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] -} {0 {} {}} -test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} win { - catch {destroy .m1} +} -result {0 {} {}} +test winMenu-28.2 {TkpConfigureMenuEntry - update not pending} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label One update idletasks list [catch {.m1 add command -label Two} msg] $msg [destroy .m1] -} {0 {} {}} +} -result {0 {} {}} + -test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} win { - catch {destroy .m1} +test winMenu-29.1 {TkpDrawMenuEntry - gc for active and not strict motif} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.2 {TkpDrawMenuEntry - gc for active menu item with its own gc} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activeforeground red set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.3 {TkpDrawMenuEntry - gc for active and strict motif} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 set tk_strictMotif 1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test winMenu-29.4 \ - {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} \ - win { - catch {destroy .m1} +} -result {{} {} 0} +test winMenu-29.4 {TkpDrawMenuEntry - gc for disabled with disabledfg and custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled -background red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.5 {TkpDrawMenuEntry - gc for disabled with disabledFg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground blue .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.6 {TkpDrawMenuEntry - gc for disabled - no disabledFg} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -disabledforeground "" .m1 add command -label foo -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.7 {TkpDrawMenuEntry - gc for normal - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -foreground red set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.8 {TkpDrawMenuEntry - gc for normal} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.9 {TkpDrawMenuEntry - gc for indicator - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo -selectcolor orange .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.10 {TkpDrawMenuEntry - gc for indicator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label foo .m1 invoke 1 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.11 {TkpDrawMenuEntry - border - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activebackground green set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.12 {TkpDrawMenuEntry - border} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.12 {TkpDrawMenuEntry - border} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.13 {TkpDrawMenuEntry - active border - strict motif} -constraints { + win +} -setup { + destroy .m1 +} -body { set tk_strictMotif 1 menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] [set tk_strictMotif 0] -} {{} {} 0} -test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} win { - catch {destroy .m1} +} -result {{} {} 0} +test winMenu-29.14 {TkpDrawMenuEntry - active border - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -activeforeground yellow set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.15 {TkpDrawMenuEntry - active border} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.15 {TkpDrawMenuEntry - active border} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] .m1 entryconfigure 1 -state active list [update] [destroy .m1] -} {{} {}} -test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.16 {TkpDrawMenuEntry - font - custom entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo -font "Helvectica 72" set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.17 {TkpDrawMenuEntry - font} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.17 {TkpDrawMenuEntry - font} -constraints win -setup { + destroy .m1 +} -body { menu .m1 -font "Courier 72" .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.18 {TkpDrawMenuEntry - separator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.18 {TkpDrawMenuEntry - separator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.19 {TkpDrawMenuEntry - standard} win { - catch {destroy .mb} +} -result {{} {}} +test winMenu-29.19 {TkpDrawMenuEntry - standard} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add cascade -label File -menu .m1.file menu .m1.file @@ -792,160 +1074,211 @@ test winMenu-29.20 {TkpDrawMenuEntry - disabled cascade item} win { .m1 entryconfigure File -state disabled set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.21 {TkpDrawMenuEntry - indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.21 {TkpDrawMenuEntry - indicator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label winMenu-31.20 .m1 invoke winMenu-31.20 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-29.22 {TkpDrawMenuEntry - indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-29.22 {TkpDrawMenuEntry - indicator} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label winMenu-31.21 -hidemargin 1 .m1 invoke winMenu-31.21 set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-30.1 {GetMenuLabelGeometry - image} {testImageType win} { - catch {destroy .m1} + +test winMenu-30.1 {GetMenuLabelGeometry - image} -constraints { + testImageType win +} -setup { + destroy .m1 catch {image delete image1} +} -body { menu .m1 image create test image1 .m1 add command -image image1 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test winMenu-30.2 {GetMenuLabelGeometry - bitmap} win { - catch {destroy .m1} +} -result {{} {} {}} +test winMenu-30.2 {GetMenuLabelGeometry - bitmap} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -bitmap questhead list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-30.3 {GetMenuLabelGeometry - no text} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-30.3 {GetMenuLabelGeometry - no text} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-30.4 {GetMenuLabelGeometry - text} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-30.4 {GetMenuLabelGeometry - text} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "This is a test." list [update idletasks] [destroy .m1] -} {{} {}} +} -result {{} {}} + -test winMenu-31.1 {DrawMenuEntryBackground} win { - catch {destroy .m1} +test winMenu-31.1 {DrawMenuEntryBackground} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] list [update] [destroy .m1] -} {{} {}} -test winMenu-31.2 {DrawMenuEntryBackground} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-31.2 {DrawMenuEntryBackground} -constraints win -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label foo set tearoff [tk::TearOffMenu .m1 40 40] $tearoff activate 0 list [update] [destroy .m1] -} {{} {}} +} -result {{} {}} -test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} win { - catch {destroy .m1} + +test winMenu-32.1 {TkpComputeStandardMenuGeometry - no entries} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.2 {TkpComputeStandardMenuGeometry - one entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.3 {TkpComputeStandardMenuGeometry - more than one entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "one" .m1 add command -label "two" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.4 {TkpComputeStandardMenuGeometry - separator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add separator list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} {unix nonUnixUserInteraction} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.5 {TkpComputeStandardMenuGeometry - tearoff entry} -constraints { + unix nonUnixUserInteraction +} -setup { + destroy .mb +} -body { menubutton .mb -text "test" -menu .mb.m menu .mb.m .mb.m add command -label test pack .mb catch {tk::MbPost .mb} list [update] [destroy .mb] -} {{} {}} -test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} \ - win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.6 {TkpComputeStandardMenuGeometry - standard label geometry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} \ - win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.7 {TkpComputeStandardMenuGeometry - different font for entry} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -font "Helvetica 12" .m1 add command -label "test" -font "Courier 12" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.8 {TkpComputeStandardMenuGeometry - second entry larger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" .m1 add command -label "test test" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.9 {TkpComputeStandardMenuGeometry - first entry larger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test test" .m1 add command -label "test" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.10 {TkpComputeStandardMenuGeometry - accelerator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "Ctrl+S" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.11 {TkpComputeStandardMenuGeometry - second accel larger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "1" .m1 add command -label "test" -accel "1 1" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.12 {TkpComputeStandardMenuGeometry - second accel smaller} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label "test" -accel "1 1" .m1 add command -label "test" -accel "1" list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.13 {TkpComputeStandardMenuGeometry - indicator} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add checkbutton -label test .m1 invoke 1 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.14 \ - {TkpComputeStandardMenuGeometry - second indicator less or equal} \ - {testImageType win} { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.14 {TkpComputeStandardMenuGeometry - second indicator less or equal} -constraints { + testImageType win +} -setup { + destroy .m1 catch {image delete image1} +} -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 @@ -953,11 +1286,13 @@ test winMenu-32.14 \ .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ - {testImageType unix} { - catch {destroy .m1} +} -result {{} {} {}} +test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} -constraints { + testImageType unix +} -setup { + destroy .m1 catch {image delete image1} +} -body { image create test image1 menu .m1 .m1 add checkbutton -image image1 @@ -965,31 +1300,42 @@ test winMenu-32.15 {TkpComputeStandardMenuGeometry - second indicator larger} \ .m1 add checkbutton -label test .m1 invoke 2 list [update idletasks] [destroy .m1] [image delete image1] -} {{} {} {}} -test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} win { - catch {destroy .m1} +} -result {{} {} {}} +test winMenu-32.16 {TkpComputeStandardMenuGeometry - zero sized menus} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.17 {TkpComputeStandardMenuGeometry - first column bigger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 .m1 add command -label one .m1 add command -label two .m1 add command -label three -columnbreak 1 list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} \ - win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.18 {TkpComputeStandardMenuGeometry - second column bigger} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 .m1 add command -label three list [update idletasks] [destroy .m1] -} {{} {}} -test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} win { - catch {destroy .m1} +} -result {{} {}} +test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} -constraints { + win +} -setup { + destroy .m1 +} -body { menu .m1 -tearoff 0 .m1 add command -label one .m1 add command -label two -columnbreak 1 @@ -997,19 +1343,22 @@ test winMenu-32.19 {TkpComputeStandardMenuGeometry - three columns} win { .m1 add command -label four .m1 add command -label five -columnbreak 1 .m1 add command -label six - list [update idletasks] [destroy .m1] -} {{} {}} + list [update idletasks] [destroy .m1] +} -result {{} {}} + -test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} win { - catch {destroy .t2} - catch {destroy .m1} +test winMenu-33.1 {TkpNotifyTopLevelCreate - no menu yet} -constraints { + win +} -setup { + destroy .m1 .t2 +} -body { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [update idletasks] [destroy .t2] -} {{} {}} -test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} win { - catch {destroy .t2} - catch {destroy .m1} +} -result {{} {}} +test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} -constraints win -setup { + destroy .m1 .t2 +} -body { menu .m1 menu .m1.system .m1 add cascade -menu .m1.system @@ -1018,11 +1367,19 @@ test winMenu-33.2 {TkpNotifyTopLevelCreate - menu} win { toplevel .t2 -menu .m1 wm geometry .t2 +0+0 list [update idletasks] [destroy .m1] [destroy .t2] -} {{} {} {}} +} -result {{} {} {}} + -test winMenu-34.1 {TkpMenuInit called at boot time} {emptyTest win} {} {} +test winMenu-34.1 {TkpMenuInit called at boot time} -constraints { + emptyTest win +} -body {} # cleanup deleteWindows cleanupTests return + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/winMsgbox.test b/tests/winMsgbox.test index f467896..0181103 100644 --- a/tests/winMsgbox.test +++ b/tests/winMsgbox.test @@ -2,8 +2,9 @@ # # Copyright (c) 2007 Pat Thoyts <patthoyts@users.sourceforge.net> -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands testConstraint getwindowinfo [expr {[llength [info command ::testgetwindowinfo]] > 0}] @@ -38,7 +39,7 @@ proc GetWindowInfo {title button} { # ------------------------------------------------------------------------- -test winMsgbox-1.0 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.1 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -49,7 +50,7 @@ test winMsgbox-1.0 {tk_messageBox ok} -constraints {win getwindowinfo} -setup { wm deiconify . } -result {ok} -test winMsgbox-1.1 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -60,7 +61,7 @@ test winMsgbox-1.1 {tk_messageBox okcancel} -constraints {win getwindowinfo} -se wm deiconify . } -result {ok} -test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.3 {tk_messageBox okcancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -71,7 +72,7 @@ test winMsgbox-1.2 {tk_messageBox okcancel} -constraints {win getwindowinfo} -se wm deiconify . } -result {cancel} -test winMsgbox-1.3 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -82,7 +83,7 @@ test winMsgbox-1.3 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup wm deiconify . } -result {yes} -test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.5 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -93,7 +94,7 @@ test winMsgbox-1.4 {tk_messageBox yesno} -constraints {win getwindowinfo} -setup wm deiconify . } -result {no} -test winMsgbox-1.5 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -104,7 +105,7 @@ test winMsgbox-1.5 {tk_messageBox abortretryignore} -constraints {win getwindowi wm deiconify . } -result {abort} -test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -115,7 +116,7 @@ test winMsgbox-1.6 {tk_messageBox abortretryignore} -constraints {win getwindowi wm deiconify . } -result {retry} -test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.8 {tk_messageBox abortretryignore} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -126,7 +127,7 @@ test winMsgbox-1.7 {tk_messageBox abortretryignore} -constraints {win getwindowi wm deiconify . } -result {ignore} -test winMsgbox-1.8 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -137,7 +138,7 @@ test winMsgbox-1.8 {tk_messageBox retrycancel} -constraints {win getwindowinfo} wm deiconify . } -result {retry} -test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.10 {tk_messageBox retrycancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -148,7 +149,7 @@ test winMsgbox-1.9 {tk_messageBox retrycancel} -constraints {win getwindowinfo} wm deiconify . } -result {cancel} -test winMsgbox-1.10 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -159,7 +160,7 @@ test winMsgbox-1.10 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} wm deiconify . } -result {yes} -test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -170,7 +171,7 @@ test winMsgbox-1.11 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} wm deiconify . } -result {no} -test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { +test winMsgbox-1.13 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} -setup { wm iconify . } -body { global windowInfo @@ -183,7 +184,7 @@ test winMsgbox-1.12 {tk_messageBox yesnocancel} -constraints {win getwindowinfo} # ------------------------------------------------------------------------- -test winMsgbox-2.0 {tk_messageBox message} -constraints {win getwindowinfo} -setup { +test winMsgbox-2.1 {tk_messageBox message} -constraints {win getwindowinfo} -setup { wm iconify . unset -nocomplain info } -body { @@ -198,7 +199,7 @@ test winMsgbox-2.0 {tk_messageBox message} -constraints {win getwindowinfo} -set wm deiconify . } -result [list ok "message"] -test winMsgbox-2.1 {tk_messageBox message (long)} -constraints { +test winMsgbox-2.2 {tk_messageBox message (long)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -215,7 +216,7 @@ test winMsgbox-2.1 {tk_messageBox message (long)} -constraints { wm deiconify . } -result [list ok [string repeat Ab 80]] -test winMsgbox-2.2 {tk_messageBox message (unicode)} -constraints { +test winMsgbox-2.3 {tk_messageBox message (unicode)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -232,7 +233,7 @@ test winMsgbox-2.2 {tk_messageBox message (unicode)} -constraints { wm deiconify . } -result [list ok "\u041f\u043e\u0438\u0441\u043a\u0020\u0441\u0442\u0440\u0430\u043d\u0438\u0446"] -test winMsgbox-2.3 {tk_messageBox message (empty)} -constraints { +test winMsgbox-2.4 {tk_messageBox message (empty)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -248,7 +249,9 @@ test winMsgbox-2.3 {tk_messageBox message (empty)} -constraints { wm deiconify . } -result [list ok ""] -test winMsgbox-3.0 {tk_messageBox detail (sourceforge bug #1692927)} -constraints { +# ------------------------------------------------------------------------- + +test winMsgbox-3.1 {tk_messageBox detail (sourceforge bug #1692927)} -constraints { win getwindowinfo } -setup { wm iconify . @@ -265,7 +268,7 @@ test winMsgbox-3.0 {tk_messageBox detail (sourceforge bug #1692927)} -constraint wm deiconify . } -result [list ok "Hello\n\nPleased to meet you"] -test winMsgbox-3.1 {tk_messageBox detail (unicode)} -constraints { +test winMsgbox-3.2 {tk_messageBox detail (unicode)} -constraints { win getwindowinfo } -setup { wm iconify . diff --git a/tests/winSend.test b/tests/winSend.test index cd130fb..0f3baf8 100644 --- a/tests/winSend.test +++ b/tests/winSend.test @@ -96,7 +96,7 @@ test winSend-1.6 {Tk_SetAppName - safe interps} winSend { test winSend-2.1 {Tk_SendObjCmd - # of args} winSend { list [catch {send tktest} msg] $msg -} {1 {wrong # args: should be "send ?options? interpName arg ?arg ...?"}} +} {1 {wrong # args: should be "send ?-option value ...? interpName arg ?arg ...?"}} test winSend-2.1a {Tk_SendObjCmd: arguments} winSend { list [catch {send -bogus tktest} msg] $msg } {1 {bad option "-bogus": must be -async, -displayof, or --}} diff --git a/tests/winWm.test b/tests/winWm.test index 2864418..a4d2669 100644 --- a/tests/winWm.test +++ b/tests/winWm.test @@ -9,37 +9,26 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands -# Measure the height of a single menu line - -toplevel .t -frame .t.f -width 100 -height 50 -pack .t.f -menu .t.m -.t.m add command -label "thisisreallylong" -.t configure -menu .t.m -wm geometry .t -0-0 -update -set menuheight [winfo y .t] -.t.m add command -label "thisisreallylong" -wm geometry .t -0-0 -update -set menuheight [expr {$menuheight - [winfo y .t]}] -destroy .t -test winWm-1.1 {TkWmMapWindow} win { +test winWm-1.1 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm override .t 1 wm geometry .t +0+0 update - set result [list [winfo rootx .t] [winfo rooty .t]] + list [winfo rootx .t] [winfo rooty .t] +} -cleanup { destroy .t - set result -} {0 0} -test winWm-1.2 {TkWmMapWindow} win { +} -result {0 0} +test winWm-1.2 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm transient .t . update @@ -47,40 +36,47 @@ test winWm-1.2 {TkWmMapWindow} win { update wm deiconify . update - catch {wm iconify .t} msg + wm iconify .t +} -cleanup { destroy .t - set msg -} {can't iconify ".t": it is a transient} -test winWm-1.3 {TkWmMapWindow} win { +} -returnCodes error -result {can't iconify ".t": it is a transient} +test winWm-1.3 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t update toplevel .t2 update - set result [expr {[winfo x .t] != [winfo x .t2]}] + expr {[winfo x .t] != [winfo x .t2]} +} -cleanup { destroy .t .t2 - set result -} 1 -test winWm-1.4 {TkWmMapWindow} win { +} -result 1 +test winWm-1.4 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm geometry .t +10+10 update toplevel .t2 wm geometry .t2 +40+10 update - set result [list [winfo x .t] [winfo x .t2]] + list [winfo x .t] [winfo x .t2] +} -cleanup { destroy .t .t2 - set result -} {10 40} -test winWm-1.5 {TkWmMapWindow} win { +} -result {10 40} +test winWm-1.5 {TkWmMapWindow} -constraints win -setup { + destroy .t +} -body { toplevel .t wm iconify .t update - set result [wm state .t] - destroy .t - set result -} iconic + wm state .t +} -result {iconic} + -test winWm-2.1 {TkpWmSetState} win { +test winWm-2.1 {TkpWmSetState} -constraints win -setup { + destroy .t +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -91,10 +87,12 @@ test winWm-2.1 {TkpWmSetState} win { wm deiconify .t update lappend result [wm state .t] +} -cleanup { + destroy .t +} -result {normal iconic normal} +test winWm-2.2 {TkpWmSetState} -constraints win -setup { destroy .t - set result -} {normal iconic normal} -test winWm-2.2 {TkpWmSetState} win { +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -106,12 +104,14 @@ test winWm-2.2 {TkpWmSetState} win { update lappend result [wm state .t] wm deiconify .t - update + update lappend result [wm state .t] +} -cleanup { + destroy .t +} -result {normal withdrawn iconic normal} +test winWm-2.3 {TkpWmSetState} -constraints win -setup { destroy .t - set result -} {normal withdrawn iconic normal} -test winWm-2.3 {TkpWmSetState} win { +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -123,13 +123,15 @@ test winWm-2.3 {TkpWmSetState} win { update lappend result [wm state .t] wm state .t normal - update + update lappend result [wm state .t] +} -cleanup { + destroy .t +} -result {normal withdrawn iconic normal} +test winWm-2.4 {TkpWmSetState} -constraints win -setup { destroy .t - set result -} {normal withdrawn iconic normal} -test winWm-2.4 {TkpWmSetState} win { set result {} +} -body { toplevel .t wm geometry .t 150x50+10+10 update @@ -143,11 +145,16 @@ test winWm-2.4 {TkpWmSetState} win { wm deiconify .t update lappend result [list [wm state .t] [wm geometry .t]] +} -cleanup { destroy .t - set result -} {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} +} -result {{normal 150x50+10+10} {iconic 150x50+10+10} {iconic 150x50+10+10} {normal 200x50+10+10}} + -test winWm-3.1 {ConfigureTopLevel: window geometry propagation} win { +test winWm-3.1 {ConfigureTopLevel: window geometry propagation} -constraints { + win +} -setup { + destroy .t +} -body { toplevel .t wm geometry .t +0+0 button .t.b @@ -161,13 +168,30 @@ test winWm-3.1 {ConfigureTopLevel: window geometry propagation} win { update pack .t.b update - set x [expr {$x == [winfo x .t.b]}] + expr {$x == [winfo x .t.b]} +} -cleanup { + destroy .t +} -result 1 + + +test winWm-4.1 {ConfigureTopLevel: menu resizing} -constraints win -setup { + destroy .t +} -body { + toplevel .t + frame .t.f -width 100 -height 50 + pack .t.f + menu .t.m + .t.m add command -label "thisisreallylong" + .t configure -menu .t.m + wm geometry .t -0-0 + update + set menuheight [winfo y .t] + .t.m add command -label "thisisreallylong" + wm geometry .t -0-0 + update + set menuheight [expr {$menuheight - [winfo y .t]}] destroy .t - set x -} 1 -test winWm-4.1 {ConfigureTopLevel: menu resizing} win { - set result {} toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f @@ -178,18 +202,21 @@ test winWm-4.1 {ConfigureTopLevel: menu resizing} win { .t.m add command -label foo .t configure -menu .t.m update - set result [expr {$y - [winfo y .t]}] + expr {$y - [winfo y .t] eq $menuheight + 1} +} -cleanup { destroy .t - set result -} [expr {$menuheight + 1}] +} -result 1 + # This test works on 8.0p2 but has not worked on anything since 8.2. # It would be very strange to have a windows application increase the size # of the clientarea when a menu wraps so I believe this test to be wrong. # Original result was {50 50 50} new result may depend on the default menu # font -test winWm-5.1 {UpdateGeometryInfo: menu resizing} win { +test winWm-5.1 {UpdateGeometryInfo: menu resizing} -constraints win -setup { + destroy .t set result {} +} -body { toplevel .t frame .t.f -width 150 -height 50 -background red pack .t.f @@ -204,11 +231,12 @@ test winWm-5.1 {UpdateGeometryInfo: menu resizing} win { .t.m add command -label "thisisreallylong" update lappend result [winfo height .t] +} -cleanup { + destroy .t +} -result {50 50 31} +test winWm-5.2 {UpdateGeometryInfo: menu resizing} -constraints win -setup { destroy .t - - set result -} {50 50 31} -test winWm-5.2 {UpdateGeometryInfo: menu resizing} win { +} -body { set result {} toplevel .t frame .t.f -width 150 -height 50 -background red @@ -226,29 +254,41 @@ test winWm-5.2 {UpdateGeometryInfo: menu resizing} win { lappend result [winfo height .t] lappend result [expr {$y - [winfo rooty .t]}] destroy .t - set result -} {50 50 0} + return $result +} -cleanup { + destroy .t +} -result {50 50 0} -test winWm-6.1 {wm attributes} win { +test winWm-6.1 {wm attributes} -constraints win -setup { destroy .t +} -body { toplevel .t wm attributes .t -} {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0} -test winWm-6.2 {wm attributes} win { +} -cleanup { destroy .t +} -result {-alpha 1.0 -transparentcolor {} -disabled 0 -fullscreen 0 -toolwindow 0 -topmost 0} +test winWm-6.2 {wm attributes} -constraints win -setup { + destroy .t +} -body { toplevel .t wm attributes .t -disabled -} {0} -test winWm-6.3 {wm attributes} win { - # This isn't quite the correct error message yet, but it works. +} -cleanup { destroy .t +} -result {0} +test winWm-6.3 {wm attributes} -constraints win -setup { + destroy .t +} -body { + # This isn't quite the correct error message yet, but it works. toplevel .t - list [catch {wm attributes .t -foo} msg] $msg -} {1 {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"}} + wm attributes .t -foo +} -cleanup { + destroy .t +} -returnCodes error -result {wrong # args: should be "wm attributes window ?-alpha ?double?? ?-transparentcolor ?color?? ?-disabled ?bool?? ?-fullscreen ?bool?? ?-toolwindow ?bool?? ?-topmost ?bool??"} -test winWm-6.4 {wm attributes -alpha} win { - # Expect this to return all 1.0 {} on pre-2K/XP +test winWm-6.4 {wm attributes -alpha} -constraints win -setup { destroy .t +} -body { + # Expect this to return all 1.0 {} on pre-2K/XP toplevel .t set res [wm attributes .t -alpha] # we don't return on set yet @@ -258,72 +298,94 @@ test winWm-6.4 {wm attributes -alpha} win { lappend res [wm attributes .t -alpha] lappend res [wm attributes .t -alpha 100] lappend res [wm attributes .t -alpha] - set res -} {1.0 {} 0.5 {} 0.0 {} 1.0} + return $res +} -cleanup { + destroy .t +} -result {1.0 {} 0.5 {} 0.0 {} 1.0} -test winWm-6.5 {wm attributes -alpha} win { +test winWm-6.5 {wm attributes -alpha} -constraints win -setup { destroy .t +} -body { toplevel .t - list [catch {wm attributes .t -alpha foo} msg] $msg -} {1 {expected floating-point number but got "foo"}} + wm attributes .t -alpha foo +} -cleanup { + destroy .t +} -returnCodes error -result {expected floating-point number but got "foo"} -test winWm-6.6 {wm attributes -alpha} win { - # This test is just to show off -alpha +test winWm-6.6 {wm attributes -alpha} -constraints win -setup { destroy .t +} -body { + # This test is just to show off -alpha toplevel .t wm attributes .t -alpha 0.2 pack [label .t.l -text "Alpha Toplevel" -font "Helvetica 18 bold"] tk::PlaceWindow .t center update if {$::tcl_platform(osVersion) >= 5.0} { - for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} { - wm attributes .t -alpha $i - update idle - after 20 - } - for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} { - wm attributes .t -alpha $i - update idle - after 20 - } + for {set i 0.2} {$i < 0.99} {set i [expr {$i+0.02}]} { + wm attributes .t -alpha $i + update idle + after 20 + } + for {set i 0.99} {$i > 0.2} {set i [expr {$i-0.02}]} { + wm attributes .t -alpha $i + update idle + after 20 } -} {} + } +} -cleanup { + destroy .t +} -result {} -test winWm-6.7 {wm attributes -transparentcolor} win { - # Expect this to return all "" on pre-2K/XP +test winWm-6.7 {wm attributes -transparentcolor} -constraints win -setup { destroy .t - toplevel .t set res {} +} -body { + # Expect this to return all "" on pre-2K/XP + toplevel .t lappend res [wm attributes .t -transparentcolor] # we don't return on set yet lappend res [wm attributes .t -trans black] lappend res [wm attributes .t -trans] lappend res [wm attributes .t -trans "#FFFFFF"] lappend res [wm attributes .t -trans] +} -cleanup { destroy .t - set res -} [list {} {} black {} "#FFFFFF"] +} -result [list {} {} black {} "#FFFFFF"] -test winWm-6.8 {wm attributes -transparentcolor} win { +test winWm-6.8 {wm attributes -transparentcolor} -constraints win -setup { + destroy .t +} -body { destroy .t toplevel .t - list [catch {wm attributes .t -tr foo} msg] $msg -} {1 {unknown color name "foo"}} + wm attributes .t -tr foo +} -cleanup { + destroy .t +} -returnCodes error -result {unknown color name "foo"} -test winWm-7.1 {deiconify on an unmapped toplevel\ - will raise the window and set the focus} win { + +test winWm-7.1 {deiconify on an unmapped toplevel will raise \ + the window and set the focus} -constraints { + win +} -setup { destroy .t +} -body { toplevel .t lower .t focus -force . wm deiconify .t update list [wm stackorder .t isabove .] [focus] -} {1 .t} +} -cleanup { + destroy .t +} -result {1 .t} test winWm-7.2 {deiconify on an already mapped toplevel\ - will raise the window and set the focus} win { + will raise the window and set the focus} -constraints { + win +} -setup { destroy .t +} -body { toplevel .t lower .t update @@ -331,9 +393,13 @@ test winWm-7.2 {deiconify on an already mapped toplevel\ wm deiconify .t update list [wm stackorder .t isabove .] [focus] -} {1 .t} +} -cleanup { + destroy .t +} -result {1 .t} -test winWm-7.3 {UpdateWrapper must maintain Z order} win { +test winWm-7.3 {UpdateWrapper must maintain Z order} -constraints win -setup { + destroy .t +} -body { destroy .t toplevel .t lower .t @@ -342,10 +408,13 @@ test winWm-7.3 {UpdateWrapper must maintain Z order} win { wm resizable .t 0 0 update list $res [wm stackorder .t isbelow .] -} {1 1} +} -cleanup { + destroy .t +} -result {1 1} -test winWm-7.4 {UpdateWrapper must maintain focus} win { +test winWm-7.4 {UpdateWrapper must maintain focus} -constraints win -setup { destroy .t +} -body { toplevel .t focus -force .t update @@ -353,20 +422,26 @@ test winWm-7.4 {UpdateWrapper must maintain focus} win { wm resizable .t 0 0 update list $res [focus] -} {.t .t} +} -cleanup { + destroy .t +} -result {.t .t} -test winWm-8.1 {Tk_WmCmd procedure, "iconphoto" option} win { - list [catch {wm iconph .} msg] $msg -} {1 {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"}} -test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} win { + +test winWm-8.1 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -body { + wm iconph . +} -returnCodes error -result {wrong # args: should be "wm iconphoto window ?-default? image1 ?image2 ...?"} +test winWm-8.2 {Tk_WmCmd procedure, "iconphoto" option} -constraints win -setup { destroy .t +} -body { toplevel .t image create photo blank16 -width 16 -height 16 image create photo blank32 -width 32 -height 32 # This should just make blank icons for the window wm iconphoto .t blank16 blank32 image delete blank16 blank32 -} {} +} -cleanup { + destroy .t +} -result {} test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constraints win -setup { proc winwm90click {w} { @@ -396,7 +471,6 @@ test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constrai pack [button $w.b -text "Do dialog" -command [list winwm90proc2 $w]] bind $w.b <Map> {bind %W <Map> {}; after idle {winwm90click %W}} } - destroy .t global winwm90done set winwm90done wait toplevel .t @@ -411,7 +485,7 @@ test winWm-9.0 "Bug #2799589 - delayed activation of destroyed window" -constrai rename winwm90$cmd {} } destroy .tx .t .sd -} -result {ok} +} -result {ok} test winWm-9.1 "delayed activation of grabbed destroyed window" -constraints win -setup { proc winwm91click {w} { @@ -497,3 +571,4 @@ return # Local variables: # mode: tcl # End: + diff --git a/tests/window.test b/tests/window.test index 2c8f19d..876ba81 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,42 +5,51 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands testConstraint unthreaded [expr { (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded)) }] -namespace import -force ::tk::test::loadTkCommand +namespace import ::tk::test::loadTkCommand update # XXX This file is woefully incomplete. Right now it only tests # a few parts of a few procedures in tkWindow.c -test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} { +# ---------------------------------------------------------------------- + +test window-1.1 {Tk_CreateWindowFromPath procedure, parent dead} -setup { + destroy .t +} -body { proc bgerror msg { - global x errorInfo - set x [list $msg $errorInfo] + global x errorInfo + set x [list $msg $errorInfo] } + set x unchanged - catch {destroy .t} frame .t -width 100 -height 50 place .t -x 10 -y 10 bind .t <Destroy> {button .t.b -text hello; pack .t.b} update destroy .t update - rename bgerror {} set x -} {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed +} -cleanup { + rename bgerror {} +} -result {{can't create window: parent has been destroyed} {can't create window: parent has been destroyed while executing "button .t.b -text hello" (command bound to event)}} + # Most of the tests below don't produce meaningful results; they # will simply dump core if there are bugs. -test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} { +test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 frame .t.f -width 200 -height 200 -relief raised -bd 2 @@ -50,8 +59,10 @@ test window-2.1 {Tk_DestroyWindow procedure, destroy handler deletes parent} { bind .t.f <Destroy> {destroy .t} update destroy .t.f -} {} -test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} { +} -result {} +test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 frame .t.f -width 200 -height 200 -relief raised -bd 2 @@ -61,8 +72,10 @@ test window-2.2 {Tk_DestroyWindow procedure, destroy handler deletes parent} { bind .t.f.f <Destroy> {destroy .t} update destroy .t.f -} {} -test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { +} -result {} +test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} -setup { + destroy .f +} -body { frame .f -width 80 -height 120 -relief raised -bd 2 place .f -relx 0.5 -rely 0.5 -anchor center toplevel .f.t -width 300 -height 200 @@ -73,10 +86,11 @@ test window-2.3 {Tk_DestroyWindow procedure, destroy handler deletes parent} { place .f.t.f.f -relx 1 -rely 1 -anchor se update destroy .f -} {} +} -result {} -test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ - unixOrWin { +test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { update @@ -85,16 +99,17 @@ test window-2.4 {Tk_DestroyWindow, cleanup half dead window at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t @@ -104,16 +119,17 @@ test window-2.5 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t @@ -123,16 +139,17 @@ test window-2.6 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t @@ -143,16 +160,17 @@ test window-2.7 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} -test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ - unixOrWin { +test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -166,17 +184,18 @@ test window-2.8 {Tk_DestroyWindow, cleanup half dead windows at exit} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {}} +} -result {0 {}} # window-2.9 deadlocks threaded Tk [Bug 1715716] -test window-2.9 {Tk_DestroyWindow, Destroy bindings - evaluated after exit} {unixOrWin unthreaded} { +test window-2.9 {Tk_DestroyWindow, Destroy bindings evaluated after exit} -constraints { + unixOrWin unthreaded +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -188,17 +207,18 @@ test window-2.9 {Tk_DestroyWindow, Destroy bindings } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {Destroy .t2 +} -result {0 {Destroy .t2 Destroy .t1}} -test window-2.10 {Tk_DestroyWindow, Destroy binding - evaluated once} unixOrWin { +test window-2.10 {Tk_DestroyWindow, Destroy binding evaluated once} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { update @@ -211,16 +231,17 @@ test window-2.10 {Tk_DestroyWindow, Destroy binding } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 {Destroy .}} +} -result {0 {Destroy .}} -test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ - unixOrWin { +test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} -constraints { + unixOrWin +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -238,17 +259,20 @@ test window-2.11 {Tk_DestroyWindow, don't reanimate a half-dead window} \ } set script [makeFile $code script] if {[catch {exec [interpreter] $script -geometry 10x10+0+0} msg]} { - set error 1 + set error 1 } else { - set error 0 + set error 0 } removeFile script list $error $msg -} {0 YES} +} -result {0 YES} -test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unix testmenubar} { - catch {destroy .t} + +test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { + unix testmenubar +} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] @@ -256,10 +280,14 @@ test window-3.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ testmenubar window .t .t.f update # If stacking order isn't handle properly, generates an X error. -} {} -test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unix testmenubar} { - catch {destroy .t} +} -cleanup { + destroy .t +} -result {} +test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { + unix testmenubar +} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] @@ -270,23 +298,39 @@ test window-3.2 {Tk_MakeWindowExist procedure, stacking order and menubars} \ testmenubar window .t .t.f update # If stacking order isn't handled properly, generates an X error. -} {} +} -cleanup { + destroy .t +} -result {} + -test window-4.1 {Tk_NameToWindow procedure} {testmenubar} { - catch {destroy .t} - list [catch {winfo geometry .t} msg] $msg -} {1 {bad window path name ".t"}} -test window-4.2 {Tk_NameToWindow procedure} {testmenubar} { - catch {destroy .t} +test window-4.1 {Tk_NameToWindow procedure} -constraints { + testmenubar +} -setup { + destroy .t +} -body { + winfo geometry .t +} -cleanup { + destroy .t +} -returnCodes error -result {bad window path name ".t"} +test window-4.2 {Tk_NameToWindow procedure} -constraints { + testmenubar +} -setup { + destroy .t +} -body { frame .t -width 100 -height 50 place .t -x 10 -y 10 update - list [catch {winfo geometry .t} msg] $msg -} {0 100x50+10+10} + winfo geometry .t +} -cleanup { + destroy .t +} -returnCodes ok -result {100x50+10+10} + -test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ - {unix testmenubar} { - catch {destroy .t} +test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} -constraints { + unix testmenubar +} -setup { + destroy .t +} -body { toplevel .t -width 300 -height 200 wm geometry .t +0+0 pack [entry .t.e] @@ -297,8 +341,15 @@ test window-5.1 {Tk_MakeWindowExist procedure, stacking order and menubars} \ lower .t.e2 .t.f update # If stacking order isn't handled properly, generates an X error. -} {} +} -cleanup { + destroy .t +} -result {} + # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/winfo.test b/tests/winfo.test index 4ce87eb..14c2838 100644 --- a/tests/winfo.test +++ b/tests/winfo.test @@ -6,8 +6,9 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands # eatColors -- @@ -15,22 +16,22 @@ tcltest::loadTestedCommands # use up all the slots in the colormap. # # Arguments: -# w - Name of toplevel window to create. -# options - Options for w, such as "-colormap new". +# w - Name of toplevel window to create. +# options - Options for w, such as "-colormap new". proc eatColors {w {options ""}} { - catch {destroy $w} + destroy $w eval toplevel $w $options wm geom $w +0+0 canvas $w.c -width 400 -height 200 -bd 0 pack $w.c for {set y 0} {$y < 8} {incr y} { - for {set x 0} {$x < 40} {incr x} { - set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] - $w.c create rectangle [expr 10*$x] [expr 20*$y] \ - [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ - -fill $color - } + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } } update } @@ -38,57 +39,69 @@ proc eatColors {w {options ""}} { # XXX - This test file is woefully incomplete. At present, only a # few of the winfo options are tested. -test winfo-1.1 {"winfo atom" command} { - list [catch {winfo atom} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-1.2 {"winfo atom" command} { - list [catch {winfo atom a b} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-1.3 {"winfo atom" command} { - list [catch {winfo atom a b c d} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-1.4 {"winfo atom" command} { - list [catch {winfo atom -displayof geek foo} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-1.5 {"winfo atom" command} { +# ---------------------------------------------------------------------- + +test winfo-1.1 {"winfo atom" command} -body { + winfo atom +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-1.2 {"winfo atom" command} -body { + winfo atom a b +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-1.3 {"winfo atom" command} -body { + winfo atom a b c d +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-1.4 {"winfo atom" command} -body { + winfo atom -displayof geek foo +} -returnCodes error -result {bad window path name "geek"} +test winfo-1.5 {"winfo atom" command} -body { winfo atom PRIMARY -} 1 -test winfo-1.6 {"winfo atom" command} { +} -result 1 +test winfo-1.6 {"winfo atom" command} -body { winfo atom -displayof . PRIMARY -} 1 - -test winfo-2.1 {"winfo atomname" command} { - list [catch {winfo atomname} msg] $msg -} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} -test winfo-2.2 {"winfo atomname" command} { - list [catch {winfo atomname a b} msg] $msg -} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} -test winfo-2.3 {"winfo atomname" command} { - list [catch {winfo atomname a b c d} msg] $msg -} {1 {wrong # args: should be "winfo atomname ?-displayof window? id"}} -test winfo-2.4 {"winfo atomname" command} { - list [catch {winfo atomname -displayof geek foo} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-2.5 {"winfo atomname" command} { - list [catch {winfo atomname 44215} msg] $msg -} {1 {no atom exists with id "44215"}} -test winfo-2.6 {"winfo atomname" command} { +} -result 1 + + +test winfo-2.1 {"winfo atomname" command} -body { + winfo atomname +} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} +test winfo-2.2 {"winfo atomname" command} -body { + winfo atomname a b +} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} +test winfo-2.3 {"winfo atomname" command} -body { + winfo atomname a b c d +} -returnCodes error -result {wrong # args: should be "winfo atomname ?-displayof window? id"} +test winfo-2.4 {"winfo atomname" command} -body { + winfo atomname -displayof geek foo +} -returnCodes error -result {bad window path name "geek"} +test winfo-2.5 {"winfo atomname" command} -body { + winfo atomname 44215 +} -returnCodes error -result {no atom exists with id "44215"} +test winfo-2.6 {"winfo atomname" command} -body { winfo atomname 2 -} SECONDARY -test winfo-2.7 {"winfo atom" command} { +} -result SECONDARY +test winfo-2.7 {"winfo atom" command} -body { winfo atomname -displayof . 2 -} SECONDARY - -test winfo-3.1 {"winfo colormapfull" command} defaultPseudocolor8 { - list [catch {winfo colormapfull} msg] $msg -} {1 {wrong # args: should be "winfo colormapfull window"}} -test winfo-3.2 {"winfo colormapfull" command} defaultPseudocolor8 { - list [catch {winfo colormapfull a b} msg] $msg -} {1 {wrong # args: should be "winfo colormapfull window"}} -test winfo-3.3 {"winfo colormapfull" command} defaultPseudocolor8 { - list [catch {winfo colormapfull foo} msg] $msg -} {1 {bad window path name "foo"}} -test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} { +} -result SECONDARY + + +test winfo-3.1 {"winfo colormapfull" command} -constraints { + defaultPseudocolor8 +} -body { + winfo colormapfull +} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"} +test winfo-3.2 {"winfo colormapfull" command} -constraints { + defaultPseudocolor8 +} -body { + winfo colormapfull a b +} -returnCodes error -result {wrong # args: should be "winfo colormapfull window"} +test winfo-3.3 {"winfo colormapfull" command} -constraints { + defaultPseudocolor8 +} -body { + winfo colormapfull foo +} -returnCodes error -result {bad window path name "foo"} +test winfo-3.4 {"winfo colormapfull" command} -constraints { + unix defaultPseudocolor8 +} -body { eatColors .t {-colormap new} set result [list [winfo colormapfull .] [winfo colormapfull .t]] .t.c delete 34 @@ -99,69 +112,103 @@ test winfo-3.4 {"winfo colormapfull" command} {unix defaultPseudocolor8} { lappend result [winfo colormapfull .t] destroy .t.c lappend result [winfo colormapfull .t] -} {0 1 0 0 1 0} -catch {destroy .t} - -toplevel .t -width 550 -height 400 -frame .t.f -width 80 -height 60 -bd 2 -relief raised -place .t.f -x 50 -y 50 -wm geom .t +0+0 -update -test winfo-4.1 {"winfo containing" command} { - list [catch {winfo containing 22} msg] $msg -} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} -test winfo-4.2 {"winfo containing" command} { - list [catch {winfo containing a b c} msg] $msg -} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} -test winfo-4.3 {"winfo containing" command} { - list [catch {winfo containing a b c d e} msg] $msg -} {1 {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"}} -test winfo-4.4 {"winfo containing" command} { - list [catch {winfo containing -displayof geek 25 30} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-4.5 {"winfo containing" command} { +} -cleanup { + destroy .t +} -result {0 1 0 0 1 0} + + + +test winfo-4.1 {"winfo containing" command} -body { + winfo containing 22 +} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} +test winfo-4.2 {"winfo containing" command} -body { + winfo containing a b c +} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} +test winfo-4.3 {"winfo containing" command} -body { + winfo containing a b c d e +} -returnCodes error -result {wrong # args: should be "winfo containing ?-displayof window? rootX rootY"} +test winfo-4.4 {"winfo containing" command} -body { + winfo containing -displayof geek 25 30 +} -returnCodes error -result {bad window path name "geek"} +test winfo-4.5 {"winfo containing" command} -body { +} -setup { + destroy .t +} -body { + toplevel .t -width 550 -height 400 + frame .t.f -width 80 -height 60 -bd 2 -relief raised + place .t.f -x 50 -y 50 + wm geom .t +0+0 + update + raise .t winfo containing [winfo rootx .t.f] [winfo rooty .t.f] -} .t.f -test winfo-4.6 {"winfo containing" command} {nonPortable} { +} -cleanup { + destroy .t +} -result .t.f +test winfo-4.6 {"winfo containing" command} -constraints { + nonPortable +} -setup { + destroy .t +} -body { + toplevel .t -width 550 -height 400 + frame .t.f -width 80 -height 60 -bd 2 -relief raised + place .t.f -x 50 -y 50 + wm geom .t +0+0 + update + winfo containing [expr [winfo rootx .t.f]-1] [expr [winfo rooty .t.f]-1] -} .t -test winfo-4.7 {"winfo containing" command} { +} -cleanup { + destroy .t +} -result .t +test winfo-4.7 {"winfo containing" command} -setup { + destroy .t +} -body { + toplevel .t -width 550 -height 400 + frame .t.f -width 80 -height 60 -bd 2 -relief raised + place .t.f -x 50 -y 50 + wm geom .t +0+0 + update + set x [winfo containing -display .t.f [expr [winfo rootx .t]+600] \ - [expr [winfo rooty .t.f]+450]] + [expr [winfo rooty .t.f]+450]] expr {($x == ".") || ($x == "")} -} {1} -destroy .t - -test winfo-5.1 {"winfo interps" command} { - list [catch {winfo interps a} msg] $msg -} {1 {wrong # args: should be "winfo interps ?-displayof window?"}} -test winfo-5.2 {"winfo interps" command} { - list [catch {winfo interps a b c} msg] $msg -} {1 {wrong # args: should be "winfo interps ?-displayof window?"}} -test winfo-5.3 {"winfo interps" command} { - list [catch {winfo interps -displayof geek} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-5.4 {"winfo interps" command} unix { - expr [lsearch -exact [winfo interps] [tk appname]] >= 0 -} {1} -test winfo-5.5 {"winfo interps" command} unix { - expr [lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0 -} {1} - -test winfo-6.1 {"winfo exists" command} { - list [catch {winfo exists} msg] $msg -} {1 {wrong # args: should be "winfo exists window"}} -test winfo-6.2 {"winfo exists" command} { - list [catch {winfo exists a b} msg] $msg -} {1 {wrong # args: should be "winfo exists window"}} -test winfo-6.3 {"winfo exists" command} { +} -cleanup { + destroy .t +} -result {1} + + +test winfo-5.1 {"winfo interps" command} -body { + winfo interps a +} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"} +test winfo-5.2 {"winfo interps" command} -body { + winfo interps a b c +} -returnCodes error -result {wrong # args: should be "winfo interps ?-displayof window?"} +test winfo-5.3 {"winfo interps" command} -body { + winfo interps -displayof geek +} -returnCodes error -result {bad window path name "geek"} +test winfo-5.4 {"winfo interps" command} -constraints unix -body { + expr {[lsearch -exact [winfo interps] [tk appname]] >= 0} +} -result {1} +test winfo-5.5 {"winfo interps" command} -constraints unix -body { + expr {[lsearch -exact [winfo interps -displayof .] [tk appname]] >= 0} +} -result {1} + + +test winfo-6.1 {"winfo exists" command} -body { + winfo exists +} -returnCodes error -result {wrong # args: should be "winfo exists window"} +test winfo-6.2 {"winfo exists" command} -body { + winfo exists a b +} -returnCodes error -result {wrong # args: should be "winfo exists window"} +test winfo-6.3 {"winfo exists" command} -body { winfo exists gorp -} {0} -test winfo-6.4 {"winfo exists" command} { +} -result {0} +test winfo-6.4 {"winfo exists" command} -body { winfo exists . -} {1} -test winfo-6.5 {"winfo exists" command} { +} -result {1} +test winfo-6.5 {"winfo exists" command} -setup { + destroy .b +} -body { button .b -text "Test button" set x [winfo exists .b] pack .b @@ -169,78 +216,113 @@ test winfo-6.5 {"winfo exists" command} { bind .b <Destroy> {lappend x [winfo exists .x]} destroy .b lappend x [winfo exists .x] -} {1 0 0} - -catch {destroy .b} -button .b -text "Help" -update -test winfo-7.1 {"winfo pathname" command} { - list [catch {winfo pathname} msg] $msg -} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} -test winfo-7.2 {"winfo pathname" command} { - list [catch {winfo pathname a b} msg] $msg -} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} -test winfo-7.3 {"winfo pathname" command} { - list [catch {winfo pathname a b c d} msg] $msg -} {1 {wrong # args: should be "winfo pathname ?-displayof window? id"}} -test winfo-7.4 {"winfo pathname" command} { - list [catch {winfo pathname -displayof geek 25} msg] $msg -} {1 {bad window path name "geek"}} -test winfo-7.5 {"winfo pathname" command} { - list [catch {winfo pathname xyz} msg] $msg -} {1 {expected integer but got "xyz"}} -test winfo-7.6 {"winfo pathname" command} { - list [catch {winfo pathname 224} msg] $msg -} {1 {window id "224" doesn't exist in this application}} -test winfo-7.7 {"winfo pathname" command} { +} -result {1 0 0} + + +test winfo-7.1 {"winfo pathname" command} -body { + winfo pathname +} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} +test winfo-7.2 {"winfo pathname" command} -body { + winfo pathname a b +} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} +test winfo-7.3 {"winfo pathname" command} -body { + winfo pathname a b c d +} -returnCodes error -result {wrong # args: should be "winfo pathname ?-displayof window? id"} +test winfo-7.4 {"winfo pathname" command} -body { + winfo pathname -displayof geek 25 +} -returnCodes error -result {bad window path name "geek"} +test winfo-7.5 {"winfo pathname" command} -body { + winfo pathname xyz +} -returnCodes error -result {expected integer but got "xyz"} +test winfo-7.6 {"winfo pathname" command} -body { + winfo pathname 224 +} -returnCodes error -result {window id "224" doesn't exist in this application} +test winfo-7.7 {"winfo pathname" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { winfo pathname -displayof .b [winfo id .] -} {.} -test winfo-7.8 {"winfo pathname" command} {unix testwrapper} { +} -cleanup { + destroy .b +} -result {.} +test winfo-7.8 {"winfo pathname" command} -constraints { + unix testwrapper +} -body { winfo pathname [testwrapper .] -} {} +} -result {} -test winfo-8.1 {"winfo pointerx" command} { + +test winfo-8.1 {"winfo pointerx" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { + catch [winfo pointerx .b] +} -body { catch [winfo pointerx .b] -} 1 -test winfo-8.2 {"winfo pointery" command} { +} -result 1 +test winfo-8.2 {"winfo pointery" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { catch [winfo pointery .b] -} 1 -test winfo-8.3 {"winfo pointerxy" command} { +} -body { + catch [winfo pointerx .b] +} -result 1 +test winfo-8.3 {"winfo pointerxy" command} -setup { + destroy .b + button .b -text "Help" + update +} -body { catch [winfo pointerxy .b] -} 1 - -test winfo-9.1 {"winfo viewable" command} { - list [catch {winfo viewable} msg] $msg -} {1 {wrong # args: should be "winfo viewable window"}} -test winfo-9.2 {"winfo viewable" command} { - list [catch {winfo viewable foo} msg] $msg -} {1 {bad window path name "foo"}} -test winfo-9.3 {"winfo viewable" command} { +} -body { + catch [winfo pointerx .b] +} -result 1 + + +test winfo-9.1 {"winfo viewable" command} -body { + winfo viewable +} -returnCodes error -result {wrong # args: should be "winfo viewable window"} +test winfo-9.2 {"winfo viewable" command} -body { + winfo viewable foo +} -returnCodes error -result {bad window path name "foo"} +test winfo-9.3 {"winfo viewable" command} -body { winfo viewable . -} {1} -test winfo-9.4 {"winfo viewable" command} { +} -result {1} +test winfo-9.4 {"winfo viewable" command} -body { wm iconify . winfo viewable . -} {0} -wm deiconify . -test winfo-9.5 {"winfo viewable" command} { +} -cleanup { + wm deiconify . +} -result {0} +test winfo-9.5 {"winfo viewable" command} -setup { + deleteWindows +} -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update list [winfo viewable .f1] [winfo viewable .f1.f2] -} {1 1} -test winfo-9.6 {"winfo viewable" command} { +} -cleanup { + deleteWindows +} -result {1 1} +test winfo-9.6 {"winfo viewable" command} -setup { deleteWindows +} -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 place .f1.f2 -x 0 -y 0 update list [winfo viewable .f1] [winfo viewable .f1.f2] -} {0 0} -test winfo-9.7 {"winfo viewable" command} { +} -cleanup { + deleteWindows +} -result {0 0} +test winfo-9.7 {"winfo viewable" command} -setup { deleteWindows +} -body { frame .f1 -width 100 -height 100 -relief raised -bd 2 place .f1 -x 0 -y 0 frame .f1.f2 -width 50 -height 50 -relief raised -bd 2 @@ -248,121 +330,156 @@ test winfo-9.7 {"winfo viewable" command} { update wm iconify . list [winfo viewable .f1] [winfo viewable .f1.f2] -} {0 0} -wm deiconify . -deleteWindows +} -cleanup { + wm deiconify . + deleteWindows +} -result {0 0} -test winfo-10.1 {"winfo visualid" command} { - list [catch {winfo visualid} msg] $msg -} {1 {wrong # args: should be "winfo visualid window"}} -test winfo-10.2 {"winfo visualid" command} { - list [catch {winfo visualid gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test winfo-10.3 {"winfo visualid" command} { - expr 2+[winfo visualid .]-[winfo visualid .] -} {2} - -test winfo-11.1 {"winfo visualid" command} { - list [catch {winfo visualsavailable} msg] $msg -} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}} -test winfo-11.2 {"winfo visualid" command} { - list [catch {winfo visualsavailable gorp} msg] $msg -} {1 {bad window path name "gorp"}} -test winfo-11.3 {"winfo visualid" command} { - list [catch {winfo visualsavailable . includeids foo} msg] $msg -} {1 {wrong # args: should be "winfo visualsavailable window ?includeids?"}} -test winfo-11.4 {"winfo visualid" command} { + +test winfo-10.1 {"winfo visualid" command} -body { + winfo visualid +} -returnCodes error -result {wrong # args: should be "winfo visualid window"} +test winfo-10.2 {"winfo visualid" command} -body { + winfo visualid gorp +} -returnCodes error -result {bad window path name "gorp"} +test winfo-10.3 {"winfo visualid" command} -body { + expr {2 + [winfo visualid .] - [winfo visualid .]} +} -result {2} + + +test winfo-11.1 {"winfo visualid" command} -body { + winfo visualsavailable +} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} +test winfo-11.2 {"winfo visualid" command} -body { + winfo visualsavailable gorp +} -returnCodes error -result {bad window path name "gorp"} +test winfo-11.3 {"winfo visualid" command} -body { + winfo visualsavailable . includeids foo +} -returnCodes error -result {wrong # args: should be "winfo visualsavailable window ?includeids?"} +test winfo-11.4 {"winfo visualid" command} -body { llength [lindex [winfo visualsa .] 0] -} {2} -test winfo-11.5 {"winfo visualid" command} { +} -result {2} +test winfo-11.5 {"winfo visualid" command} -body { llength [lindex [winfo visualsa . includeids] 0] -} {3} -test winfo-11.6 {"winfo visualid" command} { +} -result {3} +test winfo-11.6 {"winfo visualid" command} -body { set x [lindex [lindex [winfo visualsa . includeids] 0] 2] expr $x + 2 - $x -} {2} +} -result {2} + + +test winfo-12.1 {GetDisplayOf procedure} -body { + winfo atom - foo x +} -returnCodes error -result {wrong # args: should be "winfo atom ?-displayof window? name"} +test winfo-12.2 {GetDisplayOf procedure} -body { + winfo atom -d bad_window x +} -returnCodes error -result {bad window path name "bad_window"} -test winfo-12.1 {GetDisplayOf procedure} { - list [catch {winfo atom - foo x} msg] $msg -} {1 {wrong # args: should be "winfo atom ?-displayof window? name"}} -test winfo-12.2 {GetDisplayOf procedure} { - list [catch {winfo atom -d bad_window x} msg] $msg -} {1 {bad window path name "bad_window"}} # Some embedding tests -# +# +test winfo-13.1 {root coordinates of embedded toplevel} -setup { + deleteWindows +} -body { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update + + list rootx [expr {[winfo rootx .emb] == [winfo rootx .con]}] \ + rooty [expr {[winfo rooty .emb] == [winfo rooty .con]}] +} -cleanup { + deleteWindows +} -result {rootx 1 rooty 1} -proc MakeEmbed {} { +test winfo-13.2 {destroying embedded toplevel} -setup { + deleteWindows +} -body { frame .con -container 1 pack .con -expand yes -fill both toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 button .emb.b pack .emb.b -expand yes -fill both update -} -test winfo-13.1 {root coordinates of embedded toplevel} { - MakeEmbed - set z [expr [winfo rootx .emb] == [winfo rootx .con] && \ - [winfo rooty .emb] == [winfo rooty .con]] - destroy .emb - destroy .con - set z -} {1} -test winfo-13.2 {destroying embedded toplevel} { + destroy .emb update - expr [winfo exists .emb.b] || [winfo exists .con] -} 0 + list embedded [winfo exists .emb.b] container [winfo exists .con] +} -cleanup { + deleteWindows +} -result {embedded 0 container 1} -deleteWindows +test winfo-13.3 {destroying container window} -setup { + deleteWindows +} -body { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update -test winfo-13.3 {destroying container window} { - MakeEmbed destroy .con update - set z [expr [winfo exists .emb.b] || [winfo exists .emb]] - catch {destroy .emb} - catch {destroy .con} - set z -} 0 + list child [winfo exists .emb.b] parent [winfo exists .emb] +} -cleanup { + deleteWindows +} -result {child 0 parent 0} -deleteWindows +test winfo-13.4 {[winfo containing] with embedded windows} -setup { + deleteWindows +} -body { + frame .con -container 1 + pack .con -expand yes -fill both + toplevel .emb -use [winfo id .con] -bd 0 -highlightthickness 0 + button .emb.b + pack .emb.b -expand yes -fill both + update -test winfo-13.4 {[winfo containing] with embedded windows} { - MakeEmbed button .b pack .b -expand yes -fill both update + string compare .emb.b \ + [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] +} -cleanup { + deleteWindows +} -result 0 - set z [string compare \ - [winfo containing [winfo rootx .emb.b] [winfo rooty .emb.b]] .emb.b] - catch {destroy .con} - catch {destroy .emb} - set z -} 0 -test winfo-14.1 {usage} { - list [catch {winfo ismapped} msg] $msg -} {1 {wrong # args: should be "winfo ismapped window"}} +test winfo-14.1 {usage} -body { + winfo ismapped +} -returnCodes error -result {wrong # args: should be "winfo ismapped window"} -test winfo-14.2 {usage} { - list [catch {winfo ismapped . .} msg] $msg -} {1 {wrong # args: should be "winfo ismapped window"}} +test winfo-14.2 {usage} -body { + winfo ismapped . . +} -returnCodes error -result {wrong # args: should be "winfo ismapped window"} -test winfo-14.3 {initially unmapped} { - catch {destroy .t} +test winfo-14.3 {initially unmapped} -setup { + destroy .t +} -body { toplevel .t winfo ismapped .t -} 0 +} -cleanup { + destroy .t +} -result 0 -test winfo-14.4 {mapped at idle time} { - catch {destroy .t} +test winfo-14.4 {mapped at idle time} -setup { + destroy .t +} -body { toplevel .t update idletasks winfo ismapped .t -} 1 +} -cleanup { + destroy .t +} -result 1 deleteWindows # cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: diff --git a/tests/wm.test b/tests/wm.test index 15526e7..1aa0779 100644 --- a/tests/wm.test +++ b/tests/wm.test @@ -641,16 +641,16 @@ test wm-geometry-1.3 {usage} -returnCodes error -body { wm geometry . bogus } -result {bad geometry specifier "bogus"} -test wm-geometry-2.1 {setting values} -setup { - set result {} -} -body { +test wm-geometry-2.1 {setting values} -body { wm geometry .t 150x150+50+50 update - lappend result [wm geometry .t] + set result [wm geometry .t] wm geometry .t {} update - lappend result [string equal [wm geometry .t] "150x150+50+50"] -} -result [list 150x150+50+50 0] + return [list $result [string equal [wm geometry .t] $result]] +} -cleanup { + unset result +} -match glob -result [list 150x150+*+* 0] ### wm grid ### @@ -1354,6 +1354,7 @@ test wm-stackorder-2.3 {stacking order} -body { toplevel .t ; update toplevel .t2 ; update raise . + raiseDelay raise .t2 raiseDelay wm stackorder . @@ -1704,6 +1705,7 @@ test wm-transient-4.1 {transient toplevel is withdrawn test wm-transient-4.2 {already mapped transient toplevel is withdrawn if master is iconic} -body { toplevel .master + raiseDelay wm iconify .master update toplevel .subject diff --git a/tests/xmfbox.test b/tests/xmfbox.test index b60bf48..f50329c 100644 --- a/tests/xmfbox.test +++ b/tests/xmfbox.test @@ -1,4 +1,4 @@ -# xmfbox.test -- +# xmfbox.test -- # # This file is a Tcl script to test the file dialog that's used # when the tk_strictMotif flag is set. Because the file dialog @@ -10,89 +10,104 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. -package require tcltest 2.1 -eval tcltest::configure $argv +package require tcltest 2.2 +namespace import ::tcltest::* +tcltest::configure {*}$argv tcltest::loadTestedCommands set testPWD [pwd] -catch {unset foo} - catch {unset data foo} proc cleanup {} { global testPWD set err0 [catch { - cd $testPWD + cd $testPWD } msg0] set err1 [catch { - if [file exists ./~nosuchuser1] { - file delete ./~nosuchuser1 - } + if [file exists ./~nosuchuser1] { + file delete ./~nosuchuser1 + } } msg1] set err2 [catch { - if [file exists ./~nosuchuser2] { - file delete ./~nosuchuser2 - } + if [file exists ./~nosuchuser2] { + file delete ./~nosuchuser2 + } } msg2] set err3 [catch { - if [file exists ./~nosuchuser3] { - file delete ./~nosuchuser3 - } + if [file exists ./~nosuchuser3] { + file delete ./~nosuchuser3 + } } msg3] set err4 [catch { - if [file exists ./~nosuchuser4] { - file delete ./~nosuchuser4 - } + if [file exists ./~nosuchuser4] { + file delete ./~nosuchuser4 + } } msg4] if {$err0 || $err1 || $err2 || $err3 || $err4} { - error [list $msg0 $msg1 $msg2 $msg3 $msg4] + error [list $msg0 $msg1 $msg2 $msg3 $msg4] } catch {unset foo} - catch {destroy .foo} + destroy .foo } -test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} unix { +# ---------------------------------------------------------------------- + +test xmfbox-1.1 {tk::MotifFDialog_Create, -parent switch} -constraints { + unix +} -setup { catch {unset foo} +} -body { set x [tk::MotifFDialog_Create foo open {-parent .}] - catch {destroy $x} - set x -} .foo +} -cleanup { + destroy $x +} -result {.foo} -test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} unix { +test xmfbox-1.2 {tk::MotifFDialog_Create, -parent switch} -constraints { + unix +} -setup { catch {unset foo} + deleteWindows +} -body { toplevel .bar wm geometry .bar +0+0 set x [tk::MotifFDialog_Create foo open {-parent .bar}] - catch {destroy $x} - catch {destroy .bar} - set x -} .bar.foo +} -cleanup { + destroy $x + destroy .bar +} -result {.bar.foo} -test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} unix { + +test xmfbox-2.1 {tk::MotifFDialog_InterpFilter, ~ in dir names} -constraints { + unix +} -body { cleanup file mkdir ./~nosuchuser1 set x [tk::MotifFDialog_Create foo open {}] $::tk::dialog::file::foo(fEnt) delete 0 end $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 set kk [tk::MotifFDialog_InterpFilter $x] -} [list $testPWD/~nosuchuser1 *] +} -result "$testPWD/~nosuchuser1 *" -test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} unix { +test xmfbox-2.2 {tk::MotifFDialog_InterpFilter, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] $::tk::dialog::file::foo(fEnt) delete 0 end $::tk::dialog::file::foo(fEnt) insert 0 [pwd]/~nosuchuser1 set kk [tk::MotifFDialog_InterpFilter $x] -} [list $testPWD ./~nosuchuser1] +} -result "$testPWD ./~nosuchuser1" -test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix { +test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -101,17 +116,21 @@ test xmfbox-2.3 {tk::MotifFDialog_Update, ~ in file names} unix { tk::MotifFDialog_InterpFilter $x tk::MotifFDialog_Update $x $::tk::dialog::file::foo(fList) get end -} ~nosuchuser1 +} -result {~nosuchuser1} -test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} unix { +test xmfbox-2.4 {tk::MotifFDialog_LoadFile, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] set i [lsearch [$::tk::dialog::file::foo(fList) get 0 end] ~nosuchuser1] expr {$i >= 0} -} 1 +} -result 1 -test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix { +test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -120,9 +139,11 @@ test xmfbox-2.5 {tk::MotifFDialog_BrowseFList, ~ in file names} unix { $::tk::dialog::file::foo(fList) selection set $i tk::MotifFDialog_BrowseFList $x $::tk::dialog::file::foo(sEnt) get -} $testPWD/~nosuchuser1 +} -result "$testPWD/~nosuchuser1" -test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix { +test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} -constraints { + unix +} -body { cleanup close [open ./~nosuchuser1 {CREAT TRUNC WRONLY}] set x [tk::MotifFDialog_Create foo open {}] @@ -133,9 +154,13 @@ test xmfbox-2.6 {tk::MotifFDialog_ActivateFList, ~ in file names} unix { tk::MotifFDialog_ActivateFList $x list $::tk::dialog::file::foo(selectPath) \ $::tk::dialog::file::foo(selectFile) $tk::Priv(selectFilePath) -} [list $testPWD ~nosuchuser1 $testPWD/~nosuchuser1] +} -result "$testPWD ~nosuchuser1 $testPWD/~nosuchuser1" # cleanup cleanup cleanupTests return + +# Local variables: +# mode: tcl +# End: |