diff options
Diffstat (limited to 'tests')
94 files changed, 58255 insertions, 24986 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 3abb615..474771d 100644 --- a/tests/bind.test +++ b/tests/bind.test @@ -7,2785 +7,6092 @@ # 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 {} } -proc setup2 {} { - catch {destroy .b.e} - entry .b.e - pack .b.e - focus -force .b.e - foreach p [event info] {event delete $p} - update +foreach event [bind all] { + bind all $event {} } -setup -foreach i [bind Test] { - bind Test $i {} -} -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 {} - event gen .b.f <Button-2> + 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 {} +} -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> + event generate .t.f <Gravity> set x -} {?? ??} +} -cleanup { + destroy .t.f +} -result {?? ??} + test bind-16.45 {ExpandPercents procedure} -setup { set savedBind(Entry) [bind Entry <Key>] set savedBind(All) [bind all <Key>] - - setup2 - - bind .b.e <Key> {set x "%M"} + entry .t.e + pack .t.e + focus -force .t.e + foreach p [event info] {event delete $p} + update +} -body { + bind .t.e <Key> {set x "%M"} bind Entry <Key> {set y "%M"} bind all <Key> {set z "%M"} -} -body { set x none; set y none; set z none - event gen .b.e <Key-a> + event gen .t.e <Key-a> list $x $y $z } -cleanup { + destroy .t.e bind all <Key> $savedBind(All) bind Entry <Key> $savedBind(Entry) unset savedBind } -result {0 1 2} test bind-16.46 {ExpandPercents procedure} -setup { - set savedBind(Entry) [bind Entry <Key>] set savedBind(All) [bind all <Key>] - - setup2 - + set savedBind(Entry) [bind Entry <Key>] + entry .t.e + pack .t.e + focus -force .t.e + foreach p [event info] {event delete $p} + update +} -body { bind all <Key> {set z "%M"} bind Entry <Key> {set y "%M"} - bind .b.e <Key> {set x "%M"} -} -body { + bind .t.e <Key> {set x "%M"} set x none; set y none; set z none - event gen .b.e <Key-a> + event gen .t.e <Key-a> list $x $y $z } -cleanup { + destroy .t.e bind Entry <Key> $savedBind(Entry) bind all <Key> $savedBind(All) unset savedBind } -result {0 1 2} - -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 +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-space> - set x -} {4 space} -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> + } + proc bgerror msg { + global x errorInfo + set x [list $msg $errorInfo] } - setup - bind .b.f <Button> {error Message2} + 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..6e2573f 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,15 +78,18 @@ 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 - set x [format questhead] +test bitmap-4.1 {FreeBitmapObjProc} -constraints { + testbitmap +} -body { + set x [join questhead] button .b -bitmap $x - set y [format questhead] + set y [join questhead] .b configure -bitmap $y - set z [format questhead] + set z [join questhead] .b configure -bitmap $z set result {} lappend result [testbitmap 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..981e640 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 - set x [format purple] +test border-3.1 {FreeBorderObjProc} -constraints { + testborder +} -setup { + set result {} +} -body { + set x [join purple] button .b -bg $x -text .b1 - set y [format purple] + set y [join purple] .b configure -bg $y - set z [format purple] + set z [join 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/bugs.tcl b/tests/bugs.tcl index 83d9519..55e5f84 100644 --- a/tests/bugs.tcl +++ b/tests/bugs.tcl @@ -1,6 +1,6 @@ # This file is a Tcl script to test out various known bugs that will # cause Tk to crash. This file ends with .tcl instead of .test to make -# sure it isn't run when you type "source all". We currently are not +# sure it isn't run when you type "source all". We currently are not # shipping this file with the rest of the source release. # # Copyright (c) 1996 Sun Microsystems, Inc. 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/butGeom2.tcl b/tests/butGeom2.tcl index 96ff209..096225c 100644 --- a/tests/butGeom2.tcl +++ b/tests/butGeom2.tcl @@ -35,7 +35,7 @@ pack .t.anchorLabel .t.control.left.f -in .t.control.left -side top -anchor w foreach opt {activebackground activeforeground background disabledforeground foreground highlightbackground highlightcolor } { #button .t.color-$opt -text $opt -command "config -$opt \[tk_chooseColor]" menubutton .t.color-$opt -text $opt -menu .t.color-$opt.m -indicatoron 1 \ - -relief raised -bd 2 + -relief raised -bd 2 menu .t.color-$opt.m -tearoff 0 .t.color-$opt.m add command -label Red -command "config -$opt red" .t.color-$opt.m add command -label Green -command "config -$opt green" 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/canvPsGrph.tcl b/tests/canvPsGrph.tcl index 343979f..08ccd74 100644 --- a/tests/canvPsGrph.tcl +++ b/tests/canvPsGrph.tcl @@ -50,13 +50,13 @@ proc mkObjs c { $c create rect 380 200 420 240 -fill black $c create rect 200 330 240 370 -fill black } - + if {$what == "oval"} { $c create oval 50 10 150 80 -fill black -stipple gray25 -outline {} $c create oval 100 100 200 150 -outline {} -fill black -stipple gray50 $c create oval 250 100 400 300 -width .5c } - + if {$what == "poly"} { $c create poly 100 200 200 50 300 200 -smooth yes -stipple gray25 \ -outline black -width 4 @@ -68,7 +68,7 @@ proc mkObjs c { $c create poly 20 200 100 220 90 100 40 250 \ -fill {} -outline brown -width 3 } - + if {$what == "line"} { $c create line 20 20 120 20 -arrow both -width 5 $c create line 20 80 150 80 20 200 150 200 -smooth yes diff --git a/tests/canvPsImg.tcl b/tests/canvPsImg.tcl index c06aeaa..1f46eca 100644 --- a/tests/canvPsImg.tcl +++ b/tests/canvPsImg.tcl @@ -35,7 +35,7 @@ toplevel .t wm title .t "Postscript Tests for Canvases: Images" wm iconname .t "Postscript" -message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them. +message .t.m -text {This screen exercises the Postscript-generation abilities of Tk canvas widgets for images. Click the buttons below to select a Visual type for the canvas and colormode for the Postscript output. Then click "Print" to send the results to the default printer, or "Print to file" to put the Postscript output in a file called "/tmp/test.ps". You can also click on items in the canvas to delete them. NOTE: Some Postscript printers may not be able to handle Postscript generated in color mode.} -width 6i pack .t.m -side top -fill both 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 7eef938..ff5e4b9 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,289 +493,399 @@ 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} - -set font {Courier 12 italic} -set ax [font measure $font 0] -set ay [font metrics $font -linespace] +} -cleanup { + .c delete test +} -result {fghi} -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 "findfont " $x] end] -} "findfont [font actual $font -size] scalefont ISOEncode setfont + set result {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 "findfont " $x] end] + expr {$x eq [subst $result] ? "ok" : $x} +} -result ok -test canvText-18.1 {bug fix 2525, find enclosed on text with newlines} -body { - 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] + .c find enclosed 99 99 [expr $x2 + 1] [expr $y2 + 1] } -cleanup { + destroy .c unset -nocomplain bbox x2 y2 } -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 \ @@ -536,8 +893,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 \ @@ -545,32 +901,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..2b0da48 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}] @@ -286,7 +406,7 @@ test canvas-10.2 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {&&c} -} -returnCodes error -result {Unexpected operator in tag search expression} +} -returnCodes error -result {unexpected operator in tag search expression} test canvas-10.3 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -294,7 +414,7 @@ test canvas-10.3 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {!!c} -} -returnCodes error -result {Too many '!' in tag search expression} +} -returnCodes error -result {too many '!' in tag search expression} test canvas-10.4 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -302,7 +422,7 @@ test canvas-10.4 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {b||} -} -returnCodes error -result {Missing tag in tag search expression} +} -returnCodes error -result {missing tag in tag search expression} test canvas-10.5 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -310,7 +430,7 @@ test canvas-10.5 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {b&&(c||)} -} -returnCodes error -result {Unexpected operator in tag search expression} +} -returnCodes error -result {unexpected operator in tag search expression} test canvas-10.6 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -318,7 +438,7 @@ test canvas-10.6 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {d&&""} -} -returnCodes error -result {Null quoted tag string in tag search expression} +} -returnCodes error -result {null quoted tag string in tag search expression} test canvas-10.7 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -326,15 +446,15 @@ test canvas-10.7 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag "d&&\"tag with spaces" -} -returnCodes error -result {Missing endquote in tag search expression} +} -returnCodes error -result {missing endquote in tag search expression} test canvas-10.8 {check errors from tag expressions} -setup { catch {destroy .c} 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 @@ -342,7 +462,7 @@ test canvas-10.9 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {a&&b&c} -} -returnCodes error -result {Singleton '&' in tag search expression} +} -returnCodes error -result {singleton '&' in tag search expression} test canvas-10.10 {check errors from tag expressions} -setup { catch {destroy .c} canvas .c @@ -350,11 +470,12 @@ test canvas-10.10 {check errors from tag expressions} -setup { .c create oval 20 260 40 280 -fill bisque -tag [list d "tag with spaces"] } -body { .c find withtag {a||b|c} -} -returnCodes error -result {Singleton '|' in tag search expression} +} -returnCodes error -result {singleton '|' in tag search expression} 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..a0c1921 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. - - foreach t {alltypes chain2 chain1 configerror internal new notenoughparams - twowindows} { - while {[testobjconfig info $t] != ""} { - testobjconfig delete $t - } + deleteWindows + foreach t {alltypes chain3 chain2 chain1 configerror internal + new notenoughparams twowindows} { + 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 - testobjconfig chain2 .c - deleteWindows + 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 delete chain2 + testobjconfig chain1 .a + testobjconfig chain2 .b + testobjconfig chain3 .c + deleteWindows + testobjconfig delete chain3 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 {{3 4 -three 2 2 -one} {2 2 -one} {} {2 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 {}} +} -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 {}} - 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 + rename .foo {} +} -cleanup { + killTables +} -returnCodes ok +test config-4.4 {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 +} -cleanup { + killTables +} -returnCodes ok -result {.foo} +test config-4.5 {DoObjConfig - 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 1 + .foo cget -boolean +} -cleanup { + killTables +} -returnCodes ok -result {1} +test config-4.6 {DoObjConfig - boolean} -constraints testobjconfig -setup { catch {rename .foo {}} +} -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 {}} +} -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 bc2c09b..6402753 100644 --- a/tests/constraints.tcl +++ b/tests/constraints.tcl @@ -38,7 +38,7 @@ namespace eval tk { } namespace eval bg { - # Manage a background process. + # Manage a background process. # Replace with slave interp or thread? namespace import ::tcltest::interpreter namespace import ::tk::test::loadTkCommand @@ -126,7 +126,7 @@ namespace eval tk { eval destroy [winfo children .] } - namespace export fixfocus + namespace export fixfocus proc fixfocus {} { catch {destroy .focus} toplevel .focus @@ -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 + } + } } @@ -149,7 +185,7 @@ testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}] testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}] testConstraint userInteraction 0 testConstraint nonUnixUserInteraction [expr { - [testConstraint userInteraction] || + [testConstraint userInteraction] || ([testConstraint unix] && [testConstraint notAqua]) }] testConstraint haveDISPLAY [info exists env(DISPLAY)] @@ -171,7 +207,6 @@ testConstraint testembed [llength [info commands testembed]] testConstraint testfont [llength [info commands testfont]] testConstraint testmakeexist [llength [info commands testmakeexist]] testConstraint testmenubar [llength [info commands testmenubar]] -testConstraint testmenubar [llength [info commands testmenubar]] testConstraint testmetrics [llength [info commands testmetrics]] testConstraint testobjconfig [llength [info commands testobjconfig]] testConstraint testsend [llength [info commands testsend]] @@ -182,7 +217,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 +277,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..ab7949e 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,15 +140,16 @@ 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 - set x [format heart] +test cursor-4.1 {FreeCursorObjProc} -constraints { + testcursor +} -body { + set x [join heart] button .b -cursor $x - set y [format heart] + set y [join heart] .b configure -cursor $y - set z [format heart] + set z [join heart] .b configure -cursor $z set result {} lappend result [testcursor 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 538461b..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 fooBitmap 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 "fooBitmap" 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..1fe73ef 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 {windows 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 da3637d..9c30b00 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,269 +1551,395 @@ 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]]] -test entry-6.12 {EntryComputeGeometry procedure} {fonts} { + 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-6.12 {EntryComputeGeometry procedure} -constraints { + fonts +} -setup { catch {destroy .e} entry .e -font $fixed -bd 2 -relief raised -width 20 pack .e +} -body { .e insert end "012\t456\t" update list [.e index @81] [.e index @82] [.e index @116] [.e index @117] -} {6 7 7 8} +} -cleanup { + destroy .e +} -result {6 7 7 8} -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 + +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 @@ -814,9 +1947,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 @@ -824,9 +1961,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 @@ -834,9 +1975,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 @@ -844,70 +1989,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 @@ -916,9 +2109,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 @@ -927,9 +2125,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 @@ -938,17 +2141,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 @@ -957,17 +2171,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 @@ -976,9 +2200,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 @@ -987,124 +2216,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 @@ -1112,192 +2403,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] -} {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 + 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] +# 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 @@ -1307,353 +2878,641 @@ 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} +} -cleanup { + destroy .e +} -result {1 1 345} -test entry-22.1 {lost namespaced textvar} { +test entry-22.1 {lost namespaced textvar} -body { + namespace eval test { variable foo {a b} } + entry .e -textvariable ::test::foo + namespace delete test + 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 catch {.e insert end "more stuff"} result1 - catch {.e delete 5 end} result2 + catch {.e delete 5 end } result2 catch {set ::test::foo} result3 list [.e get] [.e cget -textvar] $result1 $result2 $result3 -} [list "a bmo" ::test::foo \ +} -cleanup { + destroy .e +} -result [list "a bmo" ::test::foo \ {can't set "::test::foo": parent namespace doesn't exist} \ {can't set "::test::foo": parent namespace doesn't exist} \ {can't read "::test::foo": no such variable}] -test entry-23.1 {error in trace proc attached to the textvariable} { +test entry-23.1 {error in trace proc attached to the textvariable} -setup { destroy .e +} -body { trace variable myvar w traceit proc traceit args {error "Intentional error here!"} entry .e -textvariable myvar catch {.e insert end mystring} result1 catch {.e delete 0} result2 list $result1 $result2 -} [list {can't set "myvar": Intentional error here!} \ +} -cleanup { + destroy .e +} -result [list {can't set "myvar": Intentional error here!} \ {can't set "myvar": Intentional error here!}] -test entry-24.1 {textvariable lives in a non-existing namespace} { +test entry-24.1 {textvariable lives in a non-existing namespace} -setup { destroy .e +} -body { catch {entry .e -textvariable thisnsdoesntexist::myvar} result1 set result1 -} {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} - -destroy .e +} -cleanup { + destroy .e +} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} +# 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 95be5f4..756dbe5 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,14 @@ 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} { - 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} -setup { + deleteWindows +} -body { set t [toplevel .t] set e [entry $t.e] pack $e @@ -765,13 +817,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 -} {4 A 4 A} + return $result +} -cleanup { + deleteWindows +} -result {4 A 4 A} # cleanup - -destroy .t - unset -nocomplain keypress_lookup rename _init_keypress_lookup {} rename _keypress_lookup {} @@ -782,3 +833,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 9ed24dc..9e44a93 100644 --- a/tests/font.test +++ b/tests/font.test @@ -6,14 +6,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 -catch {destroy .b} -toplevel .b -wm geom .b +0+0 -update idletasks set defaultfontlist [font names] @@ -34,36 +31,11 @@ proc clearnondefaultfonts {} { } } -proc setup {} { - catch {destroy .b.f} - clearnondefaultfonts - 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 +deleteWindows +# Toplevel used (in some tests) of the whole file +toplevel .t +wm geom .t +0+0 +update idletasks switch [tk windowingsystem] { x11 {set fixed "fixed"} @@ -72,195 +44,241 @@ switch [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 { + clearnondefaultfonts +} -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} { + getnondefaultfonts +} -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 { + clearnondefaultfonts +} -body { # (objc < 3) so name = NULL - setup font create - expr {"font1" in [font names]} -} {1} -test font-6.2 {font command: create: name specified} { + getnondefaultfonts +} -cleanup { + font delete font1 +} -result {font1} +test font-6.2 {font command: create: name specified} -setup { + clearnondefaultfonts +} -body { # not (objc < 3) - setup font create xyz - expr {"xyz" in [font names]} -} {1} -test font-6.3 {font command: create: name not really specified} { + getnondefaultfonts +} -cleanup { + font delete xyz +} -result {xyz} +test font-6.3 {font command: create: name not really specified} -setup { + clearnondefaultfonts +} -body { # (name[0] == '-') so name = NULL - setup font create -family xyz - expr {"font1" in [font names]} -} {1} -test font-6.4 {font command: create: generate name} { + getnondefaultfonts +} -cleanup { + font delete font1 +} -result {font1} +test font-6.4 {font command: create: generate name} -setup { +} -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 { + font delete font1 font2 font3 +} -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 { + clearnondefaultfonts +} -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 { + clearnondefaultfonts + 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 @@ -269,11 +287,14 @@ test font-7.2 {font command: delete: loop test} { lappend x [lsort [getnondefaultfonts]] font delete a e c b lappend x [lsort [getnondefaultfonts]] -} {{a b c d e} d} -test font-7.3 {font command: delete: loop test} { +} -cleanup { + getnondefaultfonts +} -result {{a b c d e} d} +test font-7.3 {font command: delete: loop test} -setup { + clearnondefaultfonts + 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 @@ -282,299 +303,440 @@ test font-7.3 {font command: delete: loop test} { lappend x [lsort [getnondefaultfonts]] catch {font delete a d q c e b} lappend x [lsort [getnondefaultfonts]] -} {{a b c d e} {b c e}} -test font-7.4 {font command: delete: non-existent} { +} -cleanup { + clearnondefaultfonts +} -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 { + clearnondefaultfonts +} -body { getnondefaultfonts -} {} -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 { + clearnondefaultfonts +} -body { font create getnondefaultfonts -} {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 { + clearnondefaultfonts +} -body { font create xyz font create abc font create def lsort [getnondefaultfonts] -} {abc def xyz} -test font-11.5 {font command: names: skip deletePending fonts} { - # (nfPtr->deletePending == 0) - setup +} -cleanup { + clearnondefaultfonts +} -result {abc def xyz} +test font-11.5 {font command: names: skip deletePending fonts} -setup { + destroy .t.f + clearnondefaultfonts + pack [label .t.f] + update set x {} +} -body { + # (nfPtr->deletePending == 0) font create xyz font create abc lappend x [lsort [getnondefaultfonts]] - .b.f config -font xyz + .t.f config -font xyz font delete xyz lappend x [getnondefaultfonts] -} {{abc xyz} abc} +} -cleanup { + clearnondefaultfonts +} -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 [getnondefaultfonts] font create xyz lappend x [getnondefaultfonts] -} {{} 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 + clearnondefaultfonts + 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}] @@ -582,61 +744,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 + clearnondefaultfonts + pack [label .t.f] + update +} -body { # (fontPtr->namedHashPtr != NULL) - setup font create xyz - .b.f config -font xyz - destroy .b.f - expr {"xyz" in [font names]} -} {1} -test font-17.5 {Tk_FreeFont procedure: named font} { + .t.f config -font xyz + destroy .t.f + getnondefaultfonts +} -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 x [format {Courier 12}] + set result {} +} -body { + set x [join {Courier 12} { }] button .b1 -font $x - set y [format {Courier 12}] + set y [join {Courier 12} { }] .b1 configure -font $y - set z [format {Courier 12}] + set z [join {Courier 12} { }] .b1 configure -font $z - set result {} lappend result [testfont counts {Courier 12}] set x red lappend result [testfont counts {Courier 12}] @@ -645,275 +829,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*8] $ay} {[expr $ax*8] [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 * 8}]}] + 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 * 8}]}] + 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 @@ -923,206 +1696,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" + .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" - .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 @-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 -} {} + .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} { + +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)] [()] [()] @@ -1157,247 +2001,366 @@ 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 - -destroy .b +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..."} test font-47.1 {Bug f214b8ad5b} -body { interp create one @@ -1413,3 +2376,7 @@ test font-47.1 {Bug f214b8ad5b} -body { # 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..c7b0ed8 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 {windows 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..c1d9d06 100644 --- a/tests/grid.test +++ b/tests/grid.test @@ -1,22 +1,23 @@ -# This file is a Tcl script to test out the *NEW* "grid" command -# of Tk. It is (almost) organized in the standard fashion for Tcl tests. +# This file is a Tcl script to test out the *NEW* "grid" command of Tk. It is +# (almost) organized in the standard fashion for Tcl tests. # # Copyright (c) 1996 Sun Microsystems, Inc. # 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 -# of one or all of the tests +# helper routine to return "." to a sane state after a test. +# The variable GRID_VERBOSE can be used to "look" at the result of one or all +# of the tests proc grid_reset {{test ?} {top .}} { global GRID_VERBOSE if {[info exists GRID_VERBOSE]} { - if {$GRID_VERBOSE=="" || $GRID_VERBOSE==$test} { + if {$GRID_VERBOSE eq "" || $GRID_VERBOSE eq $test} { puts -nonewline "grid test $test: " flush stdout gets stdin @@ -26,10 +27,10 @@ proc grid_reset {{test ?} {top .}} { update foreach {cols rows} [grid size .] {} for {set i 0} {$i <= $cols} {incr i} { - grid columnconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform "" + grid columnconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform "" } for {set i 0} {$i <= $rows} {incr i} { - grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform "" + grid rowconfigure . $i -weight 0 -minsize 0 -pad 0 -uniform "" } grid propagate . 1 grid anchor . nw @@ -38,88 +39,76 @@ proc grid_reset {{test ?} {top .}} { grid_reset 0.0 wm geometry . {} + +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 + 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} -body { + button .b + 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 + grid x .b +} -cleanup { + grid_reset 1.8 +} -returnCodes ok -result {} +test grid-1.9 {basic argument checking} -body { + button .b + grid configure x .b +} -cleanup { + grid_reset 1.9 +} -returnCodes ok -result {} -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} { - button .b - list [catch {grid .b -row 0 -column} msg] $msg -} {1 {extra option or option with no value}} -grid_reset 1.3 - -test grid-1.4 {basic argument checking} { - 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} { - button .b - list [catch {grid x .b} msg] $msg -} {0 {}} -grid_reset 1.8 - -test grid-1.9 {basic argument checking} { - button .b - list [catch {grid configure x .b} msg] $msg -} {0 {}} -grid_reset 1.9 - -test grid-2.1 {bbox} { - list [catch {grid bbox .} msg] $msg -} {0 {0 0 0 0}} - -test grid-2.2 {bbox} { - 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} { +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 + 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 @@ -130,11 +119,11 @@ test grid-2.9 {bbox} { lappend a [grid bbox . 0 0] 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 - -test grid-2.10 {bbox} { + return $a +} -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} -body { frame .1 -width 75 -height 75 -bg red frame .2 -width 90 -height 90 -bg red grid .1 -row 0 -column 0 @@ -144,98 +133,98 @@ test grid-2.10 {bbox} { lappend a [grid bbox . 10 10 0 0] 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 - -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} { + return $a +} -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} -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 - -test grid-3.3 {configure: basic argument checking} { +} -cleanup { + grid_reset 3.2 +} -result {.b} +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 - -test grid-3.4 {configure: basic argument checking} { + 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} -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 - -test grid-3.5 {configure: basic argument checking} { + 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} -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 - -test grid-3.6 {configure: basic argument checking} { + 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} -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 - -test grid-3.7 {configure: basic argument checking} { + 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} -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 - -test grid-3.8 {configure: basic argument checking} { + 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} -body { button .b grid configure x .b grid slaves . -} {.b} -grid_reset 3.8 - -test grid-3.9 {configure: basic argument checking} { +} -cleanup { + grid_reset 3.8 +} -result {.b} +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 - -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} { + 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} -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 - -test grid-4.3 {forget} { + return $a +} -cleanup { + grid_reset 4.2 +} -result {.b {}} +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 - -test grid-4.3.1 {forget} { +} -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.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 - -test grid-4.4 {forget, calling Tk_UnmaintainGeometry} { +} -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.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 +235,56 @@ test grid-4.4 {forget, calling Tk_UnmaintainGeometry} { place .f -x 30 update lappend x [winfo ismapped .f2] -} {1 0} -grid_reset 4.4 - -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} { +} -cleanup { + grid_reset 4.4 +} -result {1 0} + +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 - -test grid-5.3 {info} { + grid info .x +} -cleanup { + grid_reset 5.2 +} -returnCodes error -result {bad window path name ".x"} +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 - -test grid-5.4 {info} { + 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} -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} { - frame .f - grid location .f 10 10 -} {-1 -1} -grid_reset 6.5 - -test grid-6.6 {location (x)} { + 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 +} -cleanup { + grid_reset 6.5 +} -result {-1 -1} +test grid-6.6 {location (x)} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -311,11 +297,11 @@ test grid-6.6 {location (x)} { set got $a } } - set result -} {{-10->-1 0} {0->0 0} {201->1 0}} -grid_reset 6.6 - -test grid-6.7 {location (y)} { + return $result +} -cleanup { + grid_reset 6.6 +} -result {{-10->-1 0} {0->0 0} {201->1 0}} +test grid-6.7 {location (y)} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -328,11 +314,11 @@ test grid-6.7 {location (y)} { set got $a } } - set result -} {{-10->0 -1} {0->0 0} {101->0 1}} -grid_reset 6.7 - -test grid-6.8 {location (weights)} { + return $result +} -cleanup { + grid_reset 6.7 +} -result {{-10->0 -1} {0->0 0} {101->0 1}} +test grid-6.8 {location (weights)} -body { frame .f -width 300 -height 100 -highlightthickness 0 -bg red frame .a grid .a @@ -351,47 +337,50 @@ test grid-6.8 {location (weights)} { set got $a } } - set result -} {{-10->-1 -1} {0->0 0} {16->0 1} {201->1 1}} -grid_reset 6.8 - -test grid-6.9 {location: check updates pending} {nonPortable} { - set a "" - foreach i {0 1 2} { - frame .$i -width 120 -height 75 -bg red - lappend a [grid location . 150 90] - 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} { + return $result +} -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} -constraints { + nonPortable +} -body { + set a "" + foreach i {0 1 2} { + frame .$i -width 120 -height 75 -bg red + lappend a [grid location . 150 90] + grid .$i -row $i -column $i + } + return $a +} -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 @@ -404,37 +393,39 @@ test grid-7.6 {propagate} { grid propagate .f 1 update lappend a [winfo width .f]x[winfo height .f] - set a -} {100x100 100x100 75x85} -grid_reset 7.6 -test grid-7.7 {propagate} { + return $a +} -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 lappend res [grid propagate .] grid propagate . 0 lappend res [grid propagate .] - set res -} [list 1 0 0] -grid_reset 7.7 - -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.2 {size} { - list [catch {grid size .x} msg] $msg -} {1 {bad window path name ".x"}} -grid_reset 8.2 - -test grid-8.3 {size} { + return $res +} -cleanup { + grid_reset 7.7 +} -result [list 1 0 0] + +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} -body { + grid size .x +} -cleanup { + grid_reset 8.2 +} -returnCodes error -result {bad window path name ".x"} +test grid-8.3 {size} -body { frame .f - list [catch {grid size .f} msg] $msg -} {0 {0 0}} -grid_reset 8.3 - -test grid-8.4 {size} { + grid size .f +} -cleanup { + grid_reset 8.3 +} -result {0 0} +test grid-8.4 {size} -body { catch {unset a} scale .f grid .f -row 0 -column 0 @@ -449,11 +440,11 @@ test grid-8.4 {size} { grid .f -row 0 -column 0 update lappend a [grid size .] - set a -} {{1 1} {6 5} {664 948} {1 1}} -grid_reset 8.4 - -test grid-8.5 {size} { + return $a +} -cleanup { + grid_reset 8.4 +} -result {{1 1} {6 5} {664 948} {1 1}} +test grid-8.5 {size} -body { catch {unset a} scale .f grid .f -row 0 -column 0 @@ -469,11 +460,11 @@ test grid-8.5 {size} { grid rowconfigure . 17 -weight 0 update lappend a [grid size .] - set a -} {{1 1} {1 18} {64 18} {1 1}} -grid_reset 8.5 - -test grid-8.6 {size} { + return $a +} -cleanup { + grid_reset 8.5 +} -result {{1 1} {1 18} {64 18} {1 1}} +test grid-8.6 {size} -body { catch {unset a} scale .f grid .f -row 10 -column 50 @@ -495,56 +486,48 @@ test grid-8.6 {size} { grid columnconfigure . 15 -weight 0 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 {}} + return $a +} -cleanup { + grid_reset 8.6 +} -result {{51 11} {51 11} {31 11} {21 11} {16 1} {1 1}} -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} { - 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 - -test grid-9.11 {slaves} { +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 {-3 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 + } + grid slaves . +} -cleanup { + grid_reset 9.10 +} -result {.2 .1 .0} +test grid-9.11 {slaves} -body { catch {unset a} foreach i {0 1 2} { label .$i -text $i @@ -558,146 +541,146 @@ test grid-9.11 {slaves} { foreach col {0 1 2 3} { 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 + return $a +} -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} { - 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} { - 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} { - grid columnconfigure . 0 -pad 3 - grid columnconfigure . 0 -pad -} {3} -grid_reset 10.16 - -test grid-10.17 {column/row configure} { - frame .f - set a "" - grid columnconfigure .f 0 -weight 0 - lappend a [grid columnconfigure .f 0 -weight] - grid columnconfigure .f 0 -weight 1 - lappend a [grid columnconfigure .f 0 -weight] - grid rowconfigure .f 0 -weight 0 - lappend a [grid rowconfigure .f 0 -weight] - grid rowconfigure .f 0 -weight 1 - lappend a [grid columnconfigure .f 0 -weight] - grid columnconfigure .f 0 -weight 0 - set a -} {0 1 0 1} -grid_reset 10.17 - -test grid-10.18 {column/row configure} { - frame .f - grid columnconfigure .f {0 2} -minsize 10 -weight 1 - list [grid columnconfigure .f 0 -minsize] \ - [grid columnconfigure .f 1 -minsize] \ - [grid columnconfigure .f 2 -minsize] \ - [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 - -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.20 {column/row configure} { - grid columnconfigure . 0 -uniform foo - grid columnconfigure . 0 -uniform -} {foo} -grid_reset 10.20 - -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.22 {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 retrieving 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 +} -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 +} -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 +} -cleanup { + grid_reset 10.16 +} -result {3} +test grid-10.17 {column/row configure} -body { + frame .f + set a "" + grid columnconfigure .f 0 -weight 0 + lappend a [grid columnconfigure .f 0 -weight] + grid columnconfigure .f 0 -weight 1 + lappend a [grid columnconfigure .f 0 -weight] + grid rowconfigure .f 0 -weight 0 + lappend a [grid rowconfigure .f 0 -weight] + grid rowconfigure .f 0 -weight 1 + lappend a [grid columnconfigure .f 0 -weight] + grid columnconfigure .f 0 -weight 0 + return $a +} -cleanup { + grid_reset 10.17 +} -result {0 1 0 1} +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] \ + [grid columnconfigure .f 1 -minsize] \ + [grid columnconfigure .f 2 -minsize] \ + [grid columnconfigure .f 0 -weight] \ + [grid columnconfigure .f 1 -weight] \ + [grid columnconfigure .f 2 -weight] +} -cleanup { + grid_reset 10.18 +} -result {10 0 10 1 0 1} +test grid-10.19 {column/row configure} -body { + grid columnconfigure . {0 -1 2} -weight 1 +} -cleanup { + grid_reset 10.19 +} -returnCodes error -result {"-1" is out of range} +test grid-10.20 {column/row configure} -body { + grid columnconfigure . 0 -uniform foo + grid columnconfigure . 0 -uniform +} -cleanup { + grid_reset 10.20 +} -result {foo} +test grid-10.21 {column/row configure} -body { + grid columnconfigure . .b -weight 1 +} -cleanup { + grid_reset 10.21 +} -returnCodes error -result {illegal index ".b"} +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 - -test grid-10.23 {column/row configure} { + grid columnconfigure . .b -weight 1 +} -cleanup { + grid_reset 10.22 +} -returnCodes error -result {the window ".b" is not managed by "."} +test grid-10.23 {column/row configure} -body { button .b grid .b -column 1 -columnspan 2 grid columnconfigure . .b -weight 1 @@ -705,11 +688,11 @@ test grid-10.23 {column/row configure} { foreach i {0 1 2 3} { lappend res [grid columnconfigure . $i -weight] } - set res -} {0 1 1 0} -grid_reset 10.23 - -test grid-10.24 {column/row configure} { + return $res +} -cleanup { + grid_reset 10.23 +} -result {0 1 1 0} +test grid-10.24 {column/row configure} -body { button .b button .c button .d @@ -722,11 +705,11 @@ test grid-10.24 {column/row configure} { foreach i {0 1 2 3 4 5 6} { lappend res [grid columnconfigure . $i -weight] } - set res -} {0 1 2 2 2 1 0} -grid_reset 10.24 - -test grid-10.25 {column/row configure} { + return $res +} -cleanup { + grid_reset 10.24 +} -result {0 1 2 2 2 1 0} +test grid-10.25 {column/row configure} -body { button .b button .c button .d @@ -739,47 +722,42 @@ test grid-10.25 {column/row configure} { foreach i {0 1 2 3 4 5 6 7} { lappend res [grid rowconfigure . $i -weight] } - set res -} {0 2 1 1 2 2 0 1} -grid_reset 10.25 - -test grid-10.26 {column/row configure} { + return $res +} -cleanup { + grid_reset 10.25 +} -result {0 2 1 1 2 2 0 1} +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 - -test grid-10.30 {column/row configure - no indices} { +} -cleanup { + grid_reset 10.26 +} -result {-minsize 0 -pad 0 -uniform {} -weight 0} +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 {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 {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] @@ -790,21 +768,21 @@ test grid-10.35 {column/row configure} { append res [grid columnconfigure .f {.f.f 1} -weight 1] 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 { + return $res +} -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 retrieving 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 @@ -816,18 +794,17 @@ test grid-10.38 {column/row configure} -body { lappend res [catch {grid .f -rowspan 2 -row 9998} msg] $msg ; update lappend res [catch {grid .f -column 9998 -columnspan 2} msg] $msg ; update lappend res [catch {grid .f -row 9998 -rowspan 2} msg] $msg ; update - set res + return $res } -cleanup {destroy .f} -result [lrange { - 1 {Column out of bounds} - 1 {Row out of bounds} - 1 {Column out of bounds} - 1 {Row out of bounds} - 1 {Column out of bounds} - 1 {Row out of bounds} + 1 {column out of bounds} + 1 {row out of bounds} + 1 {column out of bounds} + 1 {row out of bounds} + 1 {column out of bounds} + 1 {row out of bounds} } 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 @@ -840,47 +817,46 @@ test grid-10.39 {column/row configure} -body { grid forget .f .g lappend res [catch {eval grid [string repeat " x " 9999] .f} msg] $msg update - set res + return $res } -cleanup {destroy .f .g} -result [lrange { - 1 {Row out of bounds} - 1 {Row out of bounds} - 1 {Column out of bounds} - 1 {Column out of bounds} + 1 {row out of bounds} + 1 {row out of bounds} + 1 {column out of bounds} + 1 {column out of bounds} } 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 - -test grid-11.2 {default widget placement} { - button .b - list [catch {grid .b ^} msg] $msg -} {1 {can't find slave to extend with "^".}} -grid_reset 11.2 - -test grid-11.3 {default widget placement} { - button .b - list [catch {grid .b - - .c} msg] $msg -} {1 {bad window path name ".c"}} -grid_reset 11.3 - -test grid-11.4 {default widget placement} { - button .b - list [catch {grid .b - - = -} msg] $msg -} {1 {invalid window shortcut, "=" should be '-', 'x', or '^'}} -grid_reset 11.4 - -test grid-11.5 {default widget placement} { - button .b - list [catch {grid .b - x -} msg] $msg -} {1 {Must specify window before shortcut '-'.}} -grid_reset 11.5 - -test grid-11.6 {default widget placement} { +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} -body { + button .b + grid .b ^ +} -cleanup { + grid_reset 11.2 +} -returnCodes error -result {can't find slave to extend with "^"} +test grid-11.3 {default widget placement} -body { + button .b + grid .b - - .c +} -cleanup { + grid_reset 11.3 +} -returnCodes error -result {bad window path name ".c"} +test grid-11.4 {default widget placement} -body { + button .b + grid .b - - = - +} -cleanup { + grid_reset 11.4 +} -returnCodes error -result {invalid window shortcut, "=" should be '-', 'x', or '^'} +test grid-11.5 {default widget placement} -body { + button .b + grid .b - x - +} -cleanup { + grid_reset 11.5 +} -returnCodes error -result {must specify window before shortcut '-'} +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 } @@ -892,34 +868,34 @@ test grid-11.6 {default widget placement} { lappend a "[winfo x .f$i],[winfo y .f$i] \ [winfo width .f$i],[winfo height .f$i]" } - set a -} {{0,50 100,50} {150,50 50,50}} -grid_reset 11.6 - -test grid-11.7 {default widget placement} { + return $a +} -cleanup { + grid_reset 11.6 +} -result {{0,50 100,50} {150,50 50,50}} +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 - -test grid-11.8 {default widget placement} { + grid .f x - +} -cleanup { + grid_reset 11.7 +} -returnCodes error -result {must specify window before shortcut '-'} +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 - -test grid-11.9 {default widget placement} { + grid .f ^ - +} -cleanup { + grid_reset 11.8 +} -returnCodes error -result {must specify window before shortcut '-'} +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 - -test grid-11.10 {default widget placement} { + 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} -body { foreach i {1 2 3} { - frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red + frame .f$i -width 100 -height 50 -highlightthickness 0 -bg red } grid .f1 .f2 -sticky nsew grid .f3 ^ -sticky nsew @@ -929,54 +905,54 @@ test grid-11.10 {default widget placement} { lappend a "[winfo x .f$i],[winfo y .f$i] \ [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 - -test grid-11.11 {default widget placement} { + return $a +} -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} -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 + frame .f$i -width 50 -height 50 -highlightthickness 1 -highlightbackground black } - grid .f1 .f2 .f3 .f4 -sticky nsew + grid .f1 .f2 .f3 .f4 -sticky nsew grid .f5 .f6 - .f7 -sticky nsew grid .f8 ^ ^ .f9 -sticky nsew - grid .f10 ^ ^ .f11 -sticky nsew - grid .f12 - - - -sticky nsew + grid .f10 ^ ^ .f11 -sticky nsew + grid .f12 - - - -sticky nsew update set a "" foreach i {5 6 7 8 9 10 11 12 } { lappend a "[winfo x .f$i],[winfo y .f$i] \ [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 - -test grid-11.12 {default widget placement} { + return $a +} -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} -body { foreach i {1 2 3 4} { - frame .f$i -width 75 -height 50 -highlightthickness 1 -highlightbackground black + frame .f$i -width 75 -height 50 -highlightthickness 1 -highlightbackground black } grid .f1 .f2 .f3 -sticky nsew grid .f4 ^ -sticky nsew update set a "" foreach i {1 2 3 4} { - lappend a "[winfo x .f$i],[winfo y .f$i] \ - [winfo width .f$i],[winfo height .f$i]" + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" } grid .f4 ^ -column 1 update foreach i {1 2 3 4} { - lappend a "[winfo x .f$i],[winfo y .f$i] \ - [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 - -test grid-11.13 {default widget placement} { + lappend a "[winfo x .f$i],[winfo y .f$i] \ + [winfo width .f$i],[winfo height .f$i]" + } + return $a +} -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} -body { foreach i {1 2 3 4 5 6 7} { - frame .f$i -width 40 -height 50 -highlightthickness 1 -highlightbackground black + frame .f$i -width 40 -height 50 -highlightthickness 1 -highlightbackground black } grid .f1 .f2 .f3 .f4 .f5 -sticky nsew grid .f6 - .f7 -sticky nsew -columnspan 2 @@ -986,11 +962,11 @@ test grid-11.13 {default widget placement} { lappend a "[winfo x .f$i],[winfo y .f$i] \ [winfo width .f$i],[winfo height .f$i]" } - set a -} {{0,50 120,50} {120,50 80,50}} -grid_reset 11.13 - -test grid-11.14 {default widget placement} { + return $a +} -cleanup { + grid_reset 11.13 +} -result {{0,50 120,50} {120,50 80,50}} +test grid-11.14 {default widget placement} -body { foreach i {1 2 3} { frame .f$i -width 60 -height 60 -highlightthickness 0 -bg red } @@ -1002,11 +978,11 @@ test grid-11.14 {default widget placement} { lappend a "[winfo x .f$i],[winfo y .f$i] \ [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 - -test grid-11.15 {^ ^ test with multiple windows} { + return $a +} -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} -body { foreach i {1 2 3 4} { frame .f$i -width 50 -height 50 -bd 1 -relief solid } @@ -1018,25 +994,25 @@ test grid-11.15 {^ ^ test with multiple windows} { lappend a "[winfo x .f$i],[winfo y .f$i]\ [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 - -test grid-11.16 {default widget placement} { + return $a +} -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} -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 - -test grid-11.17 {default widget placement} { +} -cleanup { + grid_reset 11.16 +} -result {50 100 50} +test grid-11.17 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1047,10 +1023,10 @@ 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 - -test grid-11.18 {default widget placement} { +} -cleanup { + grid_reset 11.17 +} -result {100 50 100} +test grid-11.18 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1063,10 +1039,10 @@ 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 - -test grid-11.19 {default widget placement} { +} -cleanup { + grid_reset 11.18 +} -result {100 100 100 50} +test grid-11.19 {default widget placement} -body { foreach l {a b c d e} { frame .$l -width 50 -height 50 } @@ -1074,7 +1050,6 @@ test grid-11.19 {default widget placement} { grid .c .d -sticky news grid ^ -in . -row 2 grid x ^ -in . -row 1 - grid rowconfigure . {0 1 2} -uniform a update set res "" @@ -1082,10 +1057,11 @@ 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 "" @@ -1100,8 +1076,10 @@ test grid-12.1 {-sticky} { array set data [grid info .f] append a "($data(-sticky)) [winfo x .f] [winfo y .f] [winfo width .f] [winfo height .f]\n" } - set a -} {() 25 25 200 100 + return $a +} -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 +1096,62 @@ 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 - -test grid-13.1.1 {-in} { + grid .f -in .f +} -cleanup { + grid_reset 13.1 +} -returnCodes error -result {window can't be managed in itself} +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 - -test grid-13.2 {-in} { +} -cleanup { + grid_reset 13.1.1 +} -result {{} 1 {window can't be managed in itself} {}} +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 - -test grid-13.3 {-in} { + grid .f -in .bad +} -cleanup { + grid_reset 13.2 +} -returnCodes error -result {bad window path name ".bad"} +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 - -test grid-13.4.1 {-ipadx} { + grid .f -ipadx x +} -cleanup { + grid_reset 13.4 +} -returnCodes error -result {bad ipadx value "x": must be positive screen distance} +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 - -test grid-13.5 {-ipadx} { + 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.7 {-ipadx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1182,22 +1159,22 @@ test grid-13.5 {-ipadx} { grid .f -ipadx 1 update list $a [winfo width .f] -} {200 202} -grid_reset 13.5 - -test grid-13.6 {-ipady} { +} -cleanup { + grid_reset 13.5 +} -result {200 202} +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 - -test grid-13.6.1 {-ipady} { + grid .f -ipady x +} -cleanup { + grid_reset 13.6 +} -returnCodes error -result {bad ipady value "x": must be positive screen distance} +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 - -test grid-13.7 {-ipady} { + 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.10 {-ipady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1205,22 +1182,22 @@ test grid-13.7 {-ipady} { grid .f -ipady 1 update list $a [winfo height .f] -} {100 102} -grid_reset 13.7 - -test grid-13.8 {-padx} { +} -cleanup { + grid_reset 13.7 +} -result {100 102} +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 - -test grid-13.8.1 {-padx} { + grid .f -padx x +} -cleanup { + grid_reset 13.8 +} -returnCodes error -result {bad pad value "x": must be positive screen distance} +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 - -test grid-13.9 {-padx} { + 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.13 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1228,10 +1205,10 @@ 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 - -test grid-13.9.1 {-padx} { +} -cleanup { + grid_reset 13.9 +} -result {{200 200} {200 202 1}} +test grid-13.14 {-padx} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1239,22 +1216,22 @@ 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 - -test grid-13.10 {-pady} { +} -cleanup { + grid_reset 13.9.1 +} -result {{200 200} {200 215 10}} +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 - -test grid-13.10.1 {-pady} { + grid .f -pady x +} -cleanup { + grid_reset 13.10 +} -returnCodes error -result {bad pad value "x": must be positive screen distance} +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 - -test grid-13.11 {-pady} { + 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.17 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1262,10 +1239,10 @@ 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 - -test grid-13.11.1 {-pady} { +} -cleanup { + grid_reset 13.11 +} -result {{100 100} {100 102 1}} +test grid-13.18 {-pady} -body { frame .f -width 200 -height 100 -highlightthickness 0 -bg red grid .f update @@ -1273,29 +1250,29 @@ 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 - -test grid-13.12 {-ipad x and y} { +} -cleanup { + grid_reset 13.11.1 +} -result {{100 100} {100 120 4}} +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 set a "" foreach x {0 5} { - foreach y {0 5} { + foreach y {0 5} { grid .f -ipadx $x -ipady $y update append a " $x,$y:" foreach prop {x y width height} { - append a ,[winfo $prop .f] + append a ,[winfo $prop .f] } } } - 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 - -test grid-13.13 {reparenting} { + return $a +} -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.20 {reparenting} -body { frame .1 frame .2 button .b @@ -1308,15 +1285,16 @@ test grid-13.13 {reparenting} { catch {unset info}; array set info [grid info .b] lappend a [grid slaves .1],[grid slaves .2],$info(-in) unset info - set a -} {.b,,.1 ,.b,.2} -grid_reset 13.13 + return $a +} -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] \ @@ -1325,14 +1303,14 @@ test grid-14.1 {structure notify} { update 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 - -test grid-14.2 {structure notify} { - frame .f -width 200 -height 100 - frame .f.g -width 200 -height 100 - grid .f + return $a +} -cleanup { + grid_reset 14.1 +} -result {{0,0 200,100} {5,5 200,100}} +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 +1318,10 @@ 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 - -test grid-14.3 {map notify: bug 1648} {nonPortable} { +} -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} -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 +1340,11 @@ 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,41 +1352,42 @@ test grid-15.1 {lost slave} { lappend a [grid slaves .] grid .b lappend a [grid slaves .] -} {.b {} .b} -grid_reset 15.1 - -test grid-15.2 {lost slave} { +} -cleanup { + grid_reset 15.1 +} -result {.b {} .b} +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 + frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe } grid propagate . 0 grid anchor . center . configure -width 300 -height 250 update grid bbox . -} {37 50 225 150} -grid_reset 16.1 - -test grid-16.2 {layout weights (expanding)} { +} -cleanup { + grid_reset 16.1 +} -result {37 50 225 150} +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 - grid rowconfigure . $i -weight [expr $i + 1] - grid columnconfigure . $i -weight [expr $i + 1] + frame .$i -bg gray -width 75 -height 50 -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] } grid propagate . 0 . configure -width 500 -height 300 @@ -1416,16 +1396,16 @@ test grid-16.2 {layout weights (expanding)} { foreach i {0 1 2} { lappend a [winfo width .$i]-[winfo height .$i] } - set a -} {120-75 167-100 213-125} -grid_reset 16.2 - -test grid-16.3 {layout weights (shrinking)} { + return $a +} -cleanup { + grid_reset 16.2 +} -result {120-75 167-100 213-125} +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 - grid .$i -row $i -column $i -sticky nswe - grid rowconfigure . $i -weight [expr $i + 1] - grid columnconfigure . $i -weight [expr $i + 1] + 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] } grid propagate . 0 . configure -width 200 -height 150 @@ -1434,16 +1414,16 @@ test grid-16.3 {layout weights (shrinking)} { foreach i {0 1 2} { lappend a [winfo width .$i]-[winfo height .$i] } - set a -} {84-63 66-50 50-37} -grid_reset 16.3 - -test grid-16.4 {layout weights (shrinking with minsize)} { + return $a +} -cleanup { + grid_reset 16.3 +} -result {84-63 66-50 50-37} +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 - grid rowconfigure . $i -weight [expr $i + 1] -minsize 45 - grid columnconfigure . $i -weight [expr $i + 1] -minsize 65 + 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] -minsize 45 + grid columnconfigure . $i -weight [expr $i + 1] -minsize 65 } grid propagate . 0 . configure -width 200 -height 150 @@ -1452,16 +1432,16 @@ test grid-16.4 {layout weights (shrinking with minsize)} { foreach i {0 1 2} { lappend a [winfo width .$i]-[winfo height .$i] } - set a -} {70-60 65-45 65-45} -grid_reset 16.4 - -test grid-16.5 {layout weights (shrinking at minsize)} { + return $a +} -cleanup { + grid_reset 16.4 +} -result {70-60 65-45 65-45} +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 - grid rowconfigure . $i -weight 0 -minsize 70 - grid columnconfigure . $i -weight 0 -minsize 90 + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe + grid rowconfigure . $i -weight 0 -minsize 70 + grid columnconfigure . $i -weight 0 -minsize 90 } grid propagate . 0 . configure -width 100 -height 75 @@ -1470,17 +1450,16 @@ test grid-16.5 {layout weights (shrinking at minsize)} { foreach i {0 1 2} { lappend a [winfo width .$i]-[winfo height .$i] } - set a -} {100-75 100-75 100-75} -grid_reset 16.5 - - -test grid-16.6 {layout weights (shrinking at minsize)} { + return $a +} -cleanup { + grid_reset 16.5 +} -result {100-75 100-75 100-75} +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 - grid rowconfigure . $i -weight [expr $i + 1] -minsize 52 - grid columnconfigure . $i -weight [expr $i + 1] -minsize 69 + 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] -minsize 52 + grid columnconfigure . $i -weight [expr $i + 1] -minsize 69 } grid propagate . 0 . configure -width 200 -height 150 @@ -1489,32 +1468,38 @@ test grid-16.6 {layout weights (shrinking at minsize)} { foreach i {0 1 2} { 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)} { + return $a +} -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 + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe } 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 - -test grid-16.8 {layout internal constraints} { + return $a +} -cleanup { + grid_reset 16.7 +} -result {100-75-1 1-1-0 100-75-1} +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 + frame .$i -bg gray -width 30 -height 25 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe } frame .f -bg red -width 250 -height 200 frame .g -bg green -width 200 -height 180 @@ -1525,32 +1510,32 @@ test grid-16.8 {layout internal constraints} { update set a "" foreach i {0 1 2 3 4} { - append a "[winfo x .$i] " + append a "[winfo x .$i] " } append a ", " grid remove .f update foreach i {0 1 2 3 4} { - append a "[winfo x .$i] " + append a "[winfo x .$i] " } append a ", " grid remove .g grid .f update foreach i {0 1 2 3 4} { - append a "[winfo x .$i] " + append a "[winfo x .$i] " } append a ", " grid remove .f update foreach i {0 1 2 3 4} { - append a "[winfo x .$i] " + 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 - -test grid-16.9 {layout uniform} { + return $a +} -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} -body { frame .f1 -width 75 -height 50 frame .f2 -width 60 -height 25 frame .f3 -width 95 -height 75 @@ -1564,16 +1549,15 @@ 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 - -test grid-16.10 {layout uniform} { +} -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} -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 grid [frame .f4 -width 60 -height 100] -row 3 -column 4 grid [frame .f5 -width 60 -height 40] -row 4 -column 3 - grid rowconfigure . {0 1} -uniform a grid rowconfigure . {2 4} -uniform b grid rowconfigure . {0 2} -weight 2 @@ -1585,10 +1569,10 @@ 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 - -test grid-16.11 {layout uniform (shrink)} { +} -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)} -body { frame .f1 -width 75 -height 50 frame .f2 -width 100 -height 95 grid .f1 .f2 -sticky news @@ -1601,10 +1585,10 @@ 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 - -test grid-16.12 {layout uniform (grow)} { +} -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)} -body { frame .f1 -width 40 -height 50 frame .f2 -width 50 -height 95 frame .f3 -width 60 -height 50 @@ -1619,24 +1603,21 @@ test grid-16.12 {layout uniform (grow)} { set res {} lappend res [grid bbox . 0 0] [grid bbox . 1 0] lappend res [grid bbox . 2 0] [grid bbox . 3 0] - grid propagate . 0 . configure -width 350 -height 95 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 - grid .f1 - - .f2 grid .f3 - - - - set res {} foreach w {{0 1 0 0} {0 0 1 0} {1 3 4 0} {1 2 1 2} {1 1 1 12}} { for {set c 0} {$c < 4} {incr c} { @@ -1649,21 +1630,19 @@ test grid-16.13 {layout span} { } lappend res $res2 } - set res + return $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 - grid .f1 - - .f2 grid .f3 - - - - set res {} foreach w {{0 1 0 0} {0 0 1 0} {1 3 4 0} {1 2 1 3} {1 1 1 12}} { for {set c 0} {$c < 4} {incr c} { @@ -1676,19 +1655,17 @@ 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] \ + return $res +} -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 - grid .f1 - - .f2 grid x .f3 - - - set res {} foreach w {{0 1 0 0} {0 0 1 0} {1 0 1 0} {0 0 0 0} {1 0 0 6}} { for {set c 0} {$c < 4} {incr c} { @@ -1701,23 +1678,21 @@ 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] \ + return $res +} -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 frame .f4 -width 15 -height 20 frame .f5 -width 18 -height 20 frame .f6 -width 20 -height 20 - grid .f1 - x .f2 grid .f3 - - - grid .f4 .f5 .f6 - set res {} foreach w {{1 1 5 1} {0 0 1 0} {1 3 4 0} {1 2 1 2} {1 1 1 12}} { for {set c 0} {$c < 4} {incr c} { @@ -1730,15 +1705,15 @@ 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] \ + return $res +} -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 + frame .$i -bg gray -width 100 -height 75 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe } grid propagate . 0 grid columnconfigure . {0 1} -weight 1 -minsize 0 @@ -1754,20 +1729,18 @@ test grid-16.17 {layout weights (shrinking at minsize)} { foreach i {0 1 2 3} { 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 - -test grid-16.18 {layout span} { + return $a +} -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} -body { frame .f1 -width 30 -height 20 frame .f2 -width 166 -height 20 frame .f3 -width 39 -height 20 frame .f4 -width 10 -height 20 - grid .f1 .f3 - grid .f2 - .f4 grid columnconfigure . 0 -weight 1 - set res {} foreach w {{1 0 0} {0 1 0} {0 0 1}} { for {set c 0} {$c < 3} {incr c} { @@ -1780,14 +1753,35 @@ 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 + return $res +} -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 + set res {} + update + for {set c 0} {$c <= 5} {incr c} { + lappend res [lindex [grid bbox . $c 0] 2] + } + return $res +} -cleanup { + grid_reset 16.19 +} -result [list 0 45 5 5 0 45] -test grid-17.1 {forget and pending idle handlers} { +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. - toplevel .t wm geometry .t +0+0 frame .t.f @@ -1798,16 +1792,16 @@ test grid-17.1 {forget and pending idle handlers} { grid forget .t.f.l grid forget .t.f destroy .t - toplevel .t frame .t.f label .t.f.l -text foobar 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 @@ -1823,9 +1817,9 @@ test grid-18.1 {test respect for internalborder} { update 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} { + return $res +} -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 @@ -1839,10 +1833,10 @@ test grid-18.2 {test support for minreqsize} { update lappend res [winfo geometry .pack.lf] destroy .pack - set res -} {162x127+0+0 172x112+0+0} + return $res +} -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,75 +1846,76 @@ 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 - -test grid-20.2 {recalculate size after removal (forget)} { +} -cleanup { + grid_reset 20.1 +} -result {1 1} +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 + frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge + grid .$i -row $i -column $i -sticky nswe } grid propagate . 0 . configure -width 300 -height 250 - set res {} foreach a {n ne e se s sw w nw center} { grid anchor . $a update lappend res [grid bbox .] } - set res -} [list {37 0 225 150} {75 0 225 150} {75 50 225 150} {75 100 225 150} \ + return $res +} -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. @@ -1928,15 +1923,13 @@ test grid-21.7 {anchor} { frame .f.x -width 20 -height 20 .f configure -labelwidget .f.x pack .f -fill both -expand 1 - foreach i {0 1 2} { - frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge - grid .$i -in .f -row $i -column $i -sticky nswe + frame .$i -bg gray -width 75 -height 50 -bd 2 -relief ridge + grid .$i -in .f -row $i -column $i -sticky nswe } pack propagate . 0 grid propagate .f 0 . configure -width 300 -height 250 - set res {} foreach a {n ne e se s sw w nw center} { grid anchor .f $a @@ -1944,26 +1937,25 @@ test grid-21.7 {anchor} { lappend res [grid bbox .f] } pack propagate . 1 ; wm geometry . {} - set res -} [list {37 20 225 150} {75 20 225 150} {75 60 225 150} {75 100 225 150} \ + return $res +} -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 } {1 {bad window path name "foo"}} - test grid-22.2 {remove} { button .c grid [button .b] set a [grid slaves .] grid remove .b .c lappend a [grid slaves .] - set a + return $a } {.b {}} grid_reset 22.2 - test grid-22.3 {remove} { button .c grid .c -row 2 -column 2 -rowspan 2 -columnspan 2 -padx 3 -pady 4 -sticky ns @@ -1972,7 +1964,6 @@ test grid-22.3 {remove} { grid info .c } {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx 3 -pady 4 -sticky ns} grid_reset 22.3 - test grid-22.3.1 {remove} { frame .a button .c @@ -1982,7 +1973,6 @@ test grid-22.3.1 {remove} { grid info .c } {-in .a -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} grid_reset 22.3.1 - test grid-22.4 {remove, calling Tk_UnmaintainGeometry} { frame .f -bd 2 -relief raised place .f -x 10 -y 20 -width 200 -height 100 @@ -1996,7 +1986,6 @@ test grid-22.4 {remove, calling Tk_UnmaintainGeometry} { lappend x [winfo ismapped .f2] } {1 0} grid_reset 22.4 - test grid-22.5 {remove} { frame .a button .c @@ -2009,7 +1998,11 @@ test grid-22.5 {remove} { grid info .c } {-in . -column 0 -row 0 -columnspan 2 -rowspan 2 -ipadx 0 -ipady 0 -padx {3 5} -pady {4 7} -sticky ns} grid_reset 22.5 - + # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: 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 8dec8c2..e3a738a 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,141 +22,145 @@ 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\n100000\nabcdef" - list [catch {image create photo p1 -file test.ppm} msg] $msg -} {1 {PPM image file "test.ppm" has bad maximum intensity value 100000}} -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 100000} +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} +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} test imgPPM-5.1 {StringReadPPM procedure} -setup { image create photo ppm @@ -222,7 +227,7 @@ test imgPPM-5.9 {StringReadPPM procedure} -setup { image delete ppm } -result {5 4} -eval image delete [image names] +imageFinish # cleanup catch {file delete test.ppm} 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 b4046b6..e05d574 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} +} -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} {*}[.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 +} -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 + .l2 xview moveto .4 + update + 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 +} -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 +} -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 - .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 - 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" +} -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] +} -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.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 +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 - format {%.6g %.6g} {*}[.l xview] -} {0.4 0.6} -test listbox-3.120 {ListboxWidgetCmd procedure, "xview" option} {fonts} { - .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 +} -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 - 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 +} -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 - 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 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 - format {%.6g %.6g} {*}[.l yview] -} {0.2 0.45} -test listbox-3.126 {ListboxWidgetCmd procedure, "yview" option, partial last line} { - 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}} +} -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} test listbox-30.1 {Bug 3607326} -setup { destroy .l @@ -2176,3 +3075,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 c797281..aaadc86 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,68 +1464,88 @@ 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" .m1 add command -label "3" @@ -759,160 +1553,244 @@ test menu-3.41 {MenuWidgetCmd procedure, "index" option} { .m1 add command -label "end" .m1 add command -label "3a" .m1 add command -label "final entry" - list [.m1 index "test"] [.m1 index "3"] [.m1 index "3a"] [.m1 index "end"] [destroy .m1] -} {1 3 5 6 {}} -test menu-3.42 {MenuWidgetCmd procedure, "insert" option} { - catch {destroy .m1} + list [.m1 index "test"] [.m1 index "3"] [.m1 index "3a"] [.m1 index "end"] +} -cleanup { + destroy .m1 +} -result {1 3 5 6} +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 @@ -927,12 +1805,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 @@ -940,7 +1818,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 @@ -949,126 +1827,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 @@ -1076,21 +1990,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 @@ -1098,190 +2011,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 @@ -1290,298 +2203,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 @@ -1591,13 +2573,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 @@ -1605,360 +2587,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 @@ -1966,198 +3077,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 +} -cleanup { + deleteWindows +} -result {} +test menu-20.7 {CloneMenu - hooking up bookeeping ptrs - multiple children} -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} + .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 @@ -2165,10 +3348,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 @@ -2177,105 +3363,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 @@ -2283,13 +3501,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 @@ -2298,13 +3516,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 @@ -2313,13 +3531,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 @@ -2328,128 +3546,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 @@ -2457,11 +3735,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 @@ -2469,49 +3749,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 @@ -2519,7 +3812,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 @@ -2527,55 +3819,72 @@ 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 {} -test menu-37.1 {menubar menues cannot be posted - bug 2160206} {} { +test menu-37.1 {menubar menues cannot be posted - bug 2160206} -setup { + catch {destroy .m} +} -body { # On Linux the following used to panic # It now returns an error (on all platforms) - catch {destroy .m} menu .m -type menubar list [catch ".m post 1 1" msg] $msg -} {1 {a menubar menu cannot be posted}} +} -cleanup { + destroy .m +} -result {1 {a menubar menu cannot be posted}} # 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 4668771..ea5b5d1 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,96 +294,132 @@ 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} -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 + option get . x9 color +} -result " \t\\A\n" +test option-15.8 {database files} -body { + option read $option1 widget foo +} -returnCodes error -result {wrong # args: should be "option readfile fileName ?priority?"} +test option-15.9 {database files} -body { + option add *x3 burgundy + catch {option read $option1 userDefault} + option get . x3 color +} -result burgundy +test option-15.10 {database files} -body { + set option2 [file join [testsDirectory] option.file2] + option read $option2 +} -returnCodes error -result {missing colon on line 2} set option3 [file join [testsDirectory] option.file3] - -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} {option get . x9 color} " \t\\A\n" -test option-15.8 {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.9 {database files} {option get . x3 color} burgundy -test option-15.10 {database files} { - list [catch {option read $option2} msg] $msg -} {1 {missing colon on line 2}} option read $option3 test option-15.11 {database files} {option get . {x 4} color} br\xf3wn -test option-16.1 {ReadOptionFile} { +test option-16.1 {ReadOptionFile} -body { set option4 [makeFile {} option.file3] set file [open $option4 w] fconfigure $file -translation crlf puts $file "*x7: true\n*x8: false" close $file option read $option4 userDefault - set result [list [option get . x7 color] [option get . x8 color]] + list [option get . x7 color] [option get . x8 color] +} -cleanup { removeFile $option4 - 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 b075e18..666ed9c 100644 --- a/tests/panedwindow.test +++ b/tests/panedwindow.test @@ -6,130 +6,339 @@ # 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 {-proxybackground - "#f0a0a0" "#f0a0a0" non-existent {unknown color name "non-existent"}} - panedwindow-1.10 {-proxyborderwidth - 1.3 1.3 badValue {bad screen distance "badValue"}} - panedwindow-1.11 {-proxyrelief - groove groove - 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - panedwindow-1.12 {-orient - horizontal horizontal - badValue {bad orient "badValue": must be horizontal or vertical}} - panedwindow-1.13 {-relief - groove groove - 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - panedwindow-1.14 {-sashcursor - arrow arrow badValue {bad cursor spec "badValue"}} - panedwindow-1.15 {-sashpad - 1.3 1 badValue {bad screen distance "badValue"}} - panedwindow-1.16 {-sashrelief - groove groove - 1.5 {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken}} - panedwindow-1.17 {-sashwidth - 10 10 badValue {bad screen distance "badValue"}} - panedwindow-1.18 {-showhandle - true 1 foo {expected boolean value but got "foo"}} - panedwindow-1.19 {-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: -proxybackground (good)} -body { + .p configure -proxybackground "#f0a0a0" + list [lindex [.p configure -proxybackground] 4] [.p cget -proxybackground] +} -cleanup { + .p configure -proxybackground [lindex [.p configure -proxybackground] 3] +} -result {{#f0a0a0} #f0a0a0} +test panedwindow-1.20 {configuration options: -proxybackground (bad)} -body { + .p configure -proxybackground badValue +} -returnCodes error -result {unknown color name "badValue"} +test panedwindow-1.21 {configuration options: -proxyborderwidth (good)} -body { + .p configure -proxyborderwidth 1.3 + list [lindex [.p configure -proxyborderwidth] 4] [.p cget -proxyborderwidth] +} -cleanup { + .p configure -proxyborderwidth [lindex [.p configure -proxyborderwidth] 3] +} -result {1.3 1.3} +test panedwindow-1.22 {configuration options: -proxyborderwidth (bad)} -body { + .p configure -proxyborderwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.23 {configuration options: -proxyrelief (good)} -body { + .p configure -proxyrelief groove + list [lindex [.p configure -proxyrelief] 4] [.p cget -proxyrelief] +} -cleanup { + .p configure -proxyrelief [lindex [.p configure -proxyrelief] 3] +} -result {groove groove} +test panedwindow-1.24 {configuration options: -proxyrelief (bad)} -body { + .p configure -proxyrelief 1.5 +} -returnCodes error -result {bad relief "1.5": must be flat, groove, raised, ridge, solid, or sunken} +test panedwindow-1.25 {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.26 {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.27 {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.28 {configuration options: -sashcursor (bad)} -body { + .p configure -sashcursor badValue +} -returnCodes error -result {bad cursor spec "badValue"} +test panedwindow-1.29 {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.30 {configuration options: -sashpad (bad)} -body { + .p configure -sashpad badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.31 {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.32 {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.33 {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.34 {configuration options: -sashwidth (bad)} -body { + .p configure -sashwidth badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.35 {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.36 {configuration options: -showhandle (bad)} -body { + .p configure -showhandle foo +} -returnCodes error -result {expected boolean value but got "foo"} +test panedwindow-1.37 {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.38 {configuration options: -width (bad)} -body { + .p configure -width badValue +} -returnCodes error -result {bad screen distance "badValue"} + +test panedwindow-1.39 {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.40 {configuration options: -after (bad)} -body { + .p paneconfigure .b -after badValue +} -returnCodes error -result {bad window path name "badValue"} +test panedwindow-1.41 {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.42 {configuration options: -before (bad)} -body { + .p paneconfigure .b -before badValue +} -returnCodes error -result {bad window path name "badValue"} +test panedwindow-1.43 {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.44 {configuration options: -height (bad)} -body { + .p paneconfigure .b -height badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.45 {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.46 {configuration options: -hide (bad)} -body { + .p paneconfigure .b -hide foo +} -returnCodes error -result {expected boolean value but got "foo"} +test panedwindow-1.47 {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.48 {configuration options: -minsize (bad)} -body { + .p paneconfigure .b -minsize badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.49 {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.50 {configuration options: -padx (bad)} -body { + .p paneconfigure .b -padx badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.51 {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.52 {configuration options: -pady (bad)} -body { + .p paneconfigure .b -pady badValue +} -returnCodes error -result {bad screen distance "badValue"} +test panedwindow-1.53 {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.54 {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.55 {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.56 {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.57 {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.58 {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] @@ -138,10 +347,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] @@ -150,317 +361,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 @@ -469,16 +764,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 @@ -486,11 +785,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] @@ -500,81 +799,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] @@ -582,11 +892,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] @@ -594,12 +906,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] @@ -609,36 +922,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 @@ -648,10 +970,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} { @@ -665,10 +990,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 @@ -677,10 +1005,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 @@ -689,29 +1019,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 @@ -720,10 +1056,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 @@ -732,10 +1070,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 @@ -744,20 +1084,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]} @@ -765,11 +1109,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]} @@ -779,32 +1124,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 @@ -814,56 +1161,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 @@ -876,33 +1526,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 @@ -913,17 +1561,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 @@ -934,121 +1581,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 @@ -1061,139 +1701,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 @@ -1206,35 +1839,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 @@ -1245,18 +1876,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 @@ -1267,129 +1897,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 @@ -1402,178 +2025,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} { @@ -1582,10 +2207,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} { @@ -1594,10 +2222,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} { @@ -1606,219 +2237,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] \ @@ -1826,32 +4391,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] @@ -1861,10 +4432,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] @@ -1874,10 +4447,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] @@ -1887,32 +4462,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] @@ -1920,12 +4500,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] @@ -1933,12 +4513,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] @@ -1952,13 +4532,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] \ @@ -1966,10 +4547,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] @@ -1977,111 +4560,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 @@ -2089,11 +4700,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 @@ -2102,11 +4715,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 @@ -2115,11 +4730,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 @@ -2128,11 +4745,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 @@ -2141,11 +4760,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 @@ -2154,11 +4775,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 @@ -2167,11 +4790,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 @@ -2180,11 +4805,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 @@ -2193,11 +4820,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 @@ -2206,11 +4835,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 @@ -2220,52 +4851,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 @@ -2285,12 +4927,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 @@ -2310,12 +4952,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 @@ -2327,13 +4969,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 @@ -2347,13 +4989,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 @@ -2369,12 +5011,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 @@ -2390,12 +5032,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 @@ -2411,12 +5053,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 @@ -2432,12 +5074,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 @@ -2452,22 +5096,27 @@ 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 {} -} {} -test panedwindow-26.2 {UnmapNotify and MapNotify events are propagated to slaves} { +} -result {} +test panedwindow-25.2 {UnmapNotify and MapNotify events are propagated to slaves} -setup { + deleteWindows +} -body { panedwindow .pw .pw add [button .pw.b] pack .pw @@ -2483,301 +5132,371 @@ test panedwindow-26.2 {UnmapNotify and MapNotify events are propagated to slaves lappend result [winfo ismapped .pw.b] destroy .pw .pw.b set result -} {1 0 0 1 1} +} -cleanup { + deleteWindows +} -result {1 0 0 1 1} + -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] @@ -2788,11 +5507,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..e7ed6c7 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1,14 +1,15 @@ -# This file is a Tcl script to test the Safe Tk facility. It is organized -# in the standard fashion for Tk tests. +# This file is a Tcl script to test the Safe Tk facility. It is organized in +# the standard fashion for Tk tests. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. -package require tcltest 2.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: @@ -27,190 +28,221 @@ tcltest::loadTestedCommands # This probably means that tk wasn't installed properly. ## it indicates that something went wrong sourcing tk.tcl. -## Ensure that any changes that occured to tk.tcl will work or -## are properly prevented in a safe interpreter. -- hobbs +## Ensure that any changes that occured to tk.tcl will work or are properly +## prevented in a safe interpreter. -- hobbs # The set of hidden commands is platform dependent: -if {[string equal $tcl_platform(platform) "windows"]} { - set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection socket source tk_chooseColor tk_chooseDirectory tk_getOpenFile tk_getSaveFile tk_messageBox toplevel unload wm} -} else { - set hidden_cmds {bell cd clipboard encoding exec exit fconfigure file glob grab load menu open pwd selection send socket source toplevel unload wm} +set hidden_cmds {bell cd clipboard encoding exec exit fconfigure glob grab load menu open pwd selection socket source toplevel unload wm} +lappend hidden_cmds {*}[apply {{} { + foreach cmd { + atime attributes copy delete dirname executable exists extension + isdirectory isfile link lstat mkdir mtime nativename normalize owned + readable readlink rename rootname size stat tail tempfile type + volumes writable + } {lappend result tcl:file:$cmd}; return $result +}}] +if {[tk windowingsystem] ne "x11"} { + lappend hidden_cmds tk_chooseColor tk_chooseDirectory tk_getOpenFile \ + tk_getSaveFile tk_messageBox +} +if {[llength [info commands send]]} { + lappend hidden_cmds send } set saveAutoPath $::auto_path set auto_path [list [info library] $::tk_library] - -test safe-1.1 {Safe Tk loading into an interpreter} { +set hidden_cmds [lsort $hidden_cmds] + +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} { + 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 { +} -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*} +} -match glob -result {*encoding*exit*glob*load*source*} -test safe-2.1 {Unsafe commands not available} { +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} { +} -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} { +} -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} { +} -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} { +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} { +} -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} { - # no error shall occur, the user will - # eventually see a new toplevel +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]] interp eval $i {button .b -text "hello world!"; pack .b} - # lets don't update because it might imply that the user has - # to position the window (if the wm does not do it automatically) - # and thus make the test suite not runable non interactively + # lets don't update because it might imply that the user has 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 -} {} - -test safe-4.2 {testing loadTk -use} { +} -result {} +test safe-4.2 {testing loadTk -use} -setup { + destroy .safeTkFrame +} -body { set w .safeTkFrame - catch {destroy $w} frame $w -container 1; - pack .safeTkFrame + pack $w 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} - -test safe-5.2 {multi-level Tk loading with clearance} { - # No error shall occur in that test and no window - # shall remain at the end. - set i [safe::interpCreate] - set j [list $i x] - set j [safe::interpCreate $j] - safe::loadTk $j - interp eval $j { +} -returnCodes error -result {not allowed to start Tk by master's safe::TkInit} +test safe-5.2 {multi-level Tk loading with clearance} -setup { + set safeParent [safe::interpCreate] +} -body { + # No error shall occur in that test and no window shall remain at the end. + set i [safe::interpCreate [list $safeParent x]] + safe::loadTk $i + interp eval $i { button .b -text Ok -command {destroy .} pack .b # tkwait window . ; # for interactive testing/debugging } - safe::interpDelete $j - safe::interpDelete $i -} {} - -test safe-6.1 {loadTk -use windowPath} { +} -cleanup { + catch {safe::interpDelete $i} + safe::interpDelete $safeParent +} -result {} + +test safe-6.1 {loadTk -use windowPath} -setup { + destroy .safeTkFrame +} -body { set w .safeTkFrame - catch {destroy $w} frame $w -container 1; - pack .safeTkFrame + pack $w set i [safe::loadTk [safe::interpCreate] -use $w] interp eval $i {button .b -text "hello world!"; pack .b} safe::interpDelete $i destroy $w -} {} - -test safe-6.2 {loadTk -use windowPath, conflicting -display} { +} -result {} +test safe-6.2 {loadTk -use windowPath, conflicting -display} -setup { + destroy .safeTkFrame +} -body { set w .safeTkFrame - catch {destroy $w} frame $w -container 1; - pack .safeTkFrame + pack $w 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 + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/scale.test b/tests/scale.test index f8e58bb..a8d08a8 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,354 +539,480 @@ 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} -test scale-6.21 {ComputeFormat procedure} { +} -result {1001.235} +test scale-6.21 {ComputeFormat procedure} -body { .s configure -length 200 -from 1000 -to 1001.8 -resolution 0 -digits 200 .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 @@ -611,60 +1021,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 @@ -673,127 +1097,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 + 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 - 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} + 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 - 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} + 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 + 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 @@ -808,64 +1306,61 @@ 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 -} {} +} -result {} -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.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 {}} -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 {}} test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \ -setup { @@ -901,7 +1396,6 @@ test scale-19 {Bug [3529885fff] - Click in through goes in wrong direction} \ } \ -result {1.0 1.0 1.0 1.0} -catch {destroy .s} option clear # cleanup diff --git a/tests/scrollbar.test b/tests/scrollbar.test index 5d4334f..c6a5a90 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"}} @@ -405,7 +405,7 @@ test scrollbar-3.73 {ScrollbarWidgetCmd procedure} { } {1 {bad option "bogus": must be activate, cget, configure, delta, fraction, get, identify, or set}} test scrollbar-3.74 {ScrollbarWidgetCmd procedure} { list [catch {.s c} msg] $msg -} {1 {bad option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}} +} {1 {ambiguous option "c": must be activate, cget, configure, delta, fraction, get, identify, or set}} test scrollbar-4.1 {ScrollbarEventProc procedure} { catch {destroy .s1} diff --git a/tests/select.test b/tests/select.test index 8cbfd39..77bfb2e 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 -type ERROR .f1 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..945d4d0 100644 --- a/tests/send.test +++ b/tests/send.test @@ -227,13 +227,13 @@ test send-8.3 {Tk_SendCmd procedure, options} {secureserver} { } {1 {no application named "-async"}} test send-8.4 {Tk_SendCmd procedure, options} {secureserver} { list [catch {send -gorp foo bar baz} msg] $msg -} {1 {bad option "-gorp": must be -async, -displayof, or --}} +} {1 {no application named "-gorp"}} 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 68c6fae..594cc90 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.720430} -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] -} {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 + .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] +# 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,42 +3747,52 @@ 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 spinbox-23.1 {selection present while disabled, bug 637828} { +} -cleanup { destroy .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} - -destroy .e +} -cleanup { + destroy .e +} -result {1 1 345} -test spinbox-24.1 {error in trace proc attached to the textvariable} { +test spinbox-24.1 {error in trace proc attached to the textvariable} -setup { destroy .s +} -body { trace variable myvar w traceit proc traceit args {error "Intentional error here!"} spinbox .s -textvariable myvar -from 1 -to 10 @@ -1594,28 +3801,32 @@ test spinbox-24.1 {error in trace proc attached to the textvariable} { catch {.s delete 0} result3 catch {.s invoke buttonup} result4 list $result1 $result2 $result3 $result4 -} [list {can't set "myvar": Intentional error here!} \ +} -cleanup { + destroy .s +} -result [list {can't set "myvar": Intentional error here!} \ {can't set "myvar": Intentional error here!} \ {can't set "myvar": Intentional error here!} \ {can't set "myvar": Intentional error here!}] -test spinbox-25.1 {textvariable lives in a non-existing namespace} { +test spinbox-25.1 {textvariable lives in a non-existing namespace} -setup { destroy .s +} -body { catch {spinbox .s -textvariable thisnsdoesntexist::myvar} result1 set result1 -} {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} - -catch {unset ::e ::vVals} - -## -## End validation tests -## +} -cleanup { + destroy .s +} -result {can't trace "thisnsdoesntexist::myvar": parent namespace doesn't exist} +# 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 7c1731d..7ade29a 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 odeption 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} -entry .t.e -.t.e insert end abcdefg -.t.e select from 0 -.t insert 1.0 "Line 1 +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} + + +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,322 +1479,1145 @@ 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 -test text-9.2.44 {TextWidgetCmd procedure, "count" option} -setup { - .t delete 1.0 end +} -cleanup { + destroy .t +} -result {3 903 903 45} +test text-10.39 {TextWidgetCmd procedure, "count" option} -setup { + text .t + pack .t update set res {} } -body { @@ -698,9 +2630,12 @@ test text-9.2.44 {TextWidgetCmd procedure, "count" option} -setup { .t tag add hidden 2.9 3.17 .t tag configure hidden -elide true lappend res [.t count -displaylines 1.19 3.24] [.t count -displaylines 1.0 end] +} -cleanup { + destroy .t } -result {2 6 1 5} test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { - .t delete 1.0 end + text .t + pack .t update set res {} } -body { @@ -711,6 +2646,8 @@ test text-9.2.45 {TextWidgetCmd procedure, "count" option} -setup { .t tag add hidden 2.15 3.10 .t configure -wrap none set res [.t count -displaylines 2.0 3.0] +} -cleanup { + destroy .t } -result {0} test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { toplevel .mytop @@ -735,7 +2672,8 @@ test text-9.2.46 {TextWidgetCmd procedure, "count" option} -setup { destroy .mytop } -result {1 3} test text-9.2.47 {TextWidgetCmd procedure, "count" option} -setup { - .t delete 1.0 end + text .t + pack .t update set res {} } -body { @@ -755,17 +2693,17 @@ test text-9.2.47 {TextWidgetCmd procedure, "count" option} -setup { .t count -displaylines 5.0 12.0 set y3 [lindex [.t yview] 1] list [expr {$y1 == $y2}] [expr {$y1 == $y3}] +} -cleanup { + destroy .t } -result {1 1} -# 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] \ @@ -774,23 +2712,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] @@ -799,11 +2756,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] @@ -812,11 +2777,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 @@ -829,10 +2802,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 @@ -844,11 +2824,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] @@ -863,10 +2850,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 @@ -887,225 +2878,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 {} @@ -1113,266 +3289,364 @@ 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 4.0} {Line 1 +} -cleanup { + destroy .t +} -result {{1.0 4.0} {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 @@ -1380,15 +3654,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 @@ -1397,674 +3689,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 {ambiguous switch "-": must be --, -all, -backwards, -count, -elide, -exact, -forwards, -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 {ambiguous switch "-n": must be --, -all, -backwards, -count, -elide, -exact, -forwards, -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 @@ -2072,240 +4733,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. @@ -2319,715 +5015,968 @@ 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 {} +} -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+} 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\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 -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 "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 -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 -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 -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 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 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 -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 -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 "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 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 -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.217.1 {elide up to match, with UTF-8 chars before the 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.185.1 {TextSearchCmd, elide up to match, with UTF-8 chars before the match} { - deleteWindows - pack [text .t2] - .t2 tag configure e -elide 0 - .t2 insert end A {} xyz e bb\n - .t2 insert end \u00c4 {} xyz e bb +} -body { + .t tag configure e -elide 0 + .t insert end A {} xyz e bb\n + .t insert end \u00c4 {} xyz e bb set res {} - lappend res [.t2 search bb 1.0 "1.0 lineend"] - lappend res [.t2 search bb 2.0 "2.0 lineend"] - lappend res [.t2 search -regexp bb 1.0 "1.0 lineend"] - lappend res [.t2 search -regexp bb 2.0 "2.0 lineend"] - .t2 tag configure e -elide 1 - lappend res [.t2 search bb 1.0 "1.0 lineend"] - lappend res [.t2 search bb 2.0 "2.0 lineend"] - lappend res [.t2 search -regexp bb 1.0 "1.0 lineend"] - lappend res [.t2 search -regexp -elide bb 2.0 "2.0 lineend"] - lappend res [.t2 search -regexp bb 2.0 "2.0 lineend"] -} {1.4 2.4 1.4 2.4 1.4 2.4 1.4 2.4 2.4} -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} + lappend res [.t search bb 1.0 "1.0 lineend"] + lappend res [.t search bb 2.0 "2.0 lineend"] + lappend res [.t search -regexp bb 1.0 "1.0 lineend"] + lappend res [.t search -regexp bb 2.0 "2.0 lineend"] + .t tag configure e -elide 1 + lappend res [.t search bb 1.0 "1.0 lineend"] + lappend res [.t search bb 2.0 "2.0 lineend"] + lappend res [.t search -regexp bb 1.0 "1.0 lineend"] + lappend res [.t search -regexp -elide bb 2.0 "2.0 lineend"] + lappend res [.t search -regexp bb 2.0 "2.0 lineend"] +} -cleanup { + destroy .t +} -result {1.4 2.4 1.4 2.4 1.4 2.4 1.4 2.4 2.4} +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 @@ -3035,21 +5984,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" @@ -3057,16 +6003,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" @@ -3074,9 +6028,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" @@ -3085,9 +6040,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" @@ -3095,10 +6051,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" @@ -3106,9 +6063,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" @@ -3116,36 +6074,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 @@ -3153,50 +6116,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" @@ -3206,17 +6173,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 @@ -3242,8 +6212,8 @@ test text-25.19 {patch 1669632 (i) - undo after <Control-1>} -setup { } -cleanup { destroy .t } -result WORLD -test text-25.20 {patch 1669632 (iv) - undo after <Control-backslash>} -setup { - destroy .t +test text-25.20 {patch 1669632 (iv) - undo after <<SelectNone>>} -setup { + destroy .top .top.t } -body { toplevel .top pack [text .top.t -undo 1] @@ -3254,7 +6224,7 @@ test text-25.20 {patch 1669632 (iv) - undo after <Control-backslash>} -setup { .top.t tag add sel 1.10 1.12 update focus -force .top.t - event generate .top.t <Control-backslash> + event generate .top.t <<SelectNone>> .top.t insert insert " WORLD " .top.t edit undo .top.t get 1.5 1.10 @@ -3289,7 +6259,7 @@ test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup { update focus -force .top.t event generate .top.t <Delete> - event generate .top.t <Shift-Right> + event generate .top.t <<SelectNextChar>> event generate .top.t <<Clear>> event generate .top.t <Delete> event generate .top.t <<Undo>> @@ -3309,7 +6279,7 @@ test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup { update focus -force .top.t event generate .top.t <Delete> - event generate .top.t <Shift-Right> + event generate .top.t <<SelectNextChar>> event generate .top.t <<Cut>> event generate .top.t <Delete> event generate .top.t <<Undo>> @@ -3318,246 +6288,275 @@ test text-25.22 {patch 1669632 (v) - <<Clear>> is atomic} -setup { destroy .top.t .top } -result "This A an example text" -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 +} -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 + set result 1 +} -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 -} {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.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 +# 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-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] @@ -3567,17 +6566,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] \ @@ -3586,17 +6586,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] \ @@ -3605,16 +6606,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}] @@ -3623,58 +6625,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] @@ -3682,63 +6687,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}] @@ -3747,12 +6777,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}] @@ -3761,16 +6793,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] @@ -3784,8 +6819,10 @@ 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-32.2 {peer widget -start, -end and deletion (bug 1630262)} -setup { destroy .t .pt @@ -3878,45 +6915,52 @@ test text-32.4 {peer widget -start, -end and deletion (bug 1630262)} -setup { .t delete 3.0 18.0 lappend res [.t cget -start] [.t cget -end] [.pt cget -start] [.pt cget -end] } -cleanup { - destroy .pt + destroy .pt .t } -result {5 11 8 10 5 8 6 8 22 27 38 44 55 60 57 57} -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} @@ -3931,7 +6975,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 {} @@ -3945,7 +6988,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 {} @@ -3959,7 +7001,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 1eb7c75..ebd6c50 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,15 +862,20 @@ 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} -test btree-14.2 {TkTextIsElided} { +} -cleanup { + destroy .t +} -result {x y z} +test btree-14.2 {TkTextIsElided} -setup { + destroy .t + text .t +} -body { .t delete 1.0 end .t tag config hidden -elide 1 .t insert end "Line1\nLine2\nLine3\n" @@ -673,235 +884,363 @@ test btree-14.2 {TkTextIsElided} { # next line used to panic because of "Bad tag priority being toggled on" # (see bug [382da038c9]) .t index "2.0 - 1 display line linestart" -} {1.0} +} -cleanup { + destroy .t +} -result {1.0} -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 47ea298..4bb190c 100644 --- a/tests/textImage.test +++ b/tests/textImage.test @@ -7,351 +7,446 @@ # 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, see also bug 1591493} { - 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 "" - foreach {x1 y1 w1 h1} [.t bbox test] {} - lappend result [list $x1 $w1 $h1] - .t image configure test -image small -align top - update - foreach {x2 y2 w2 h2} [.t bbox test] {} - lappend result [list [expr {$x1==$x2}] [expr {$w2>0}] [expr {$h2>0}]] -} {{0 0 0} {1 1 1}} +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}} + +test textImage-3.2 {delayed image management, see also bug 1591493} -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 + foreach {x1 y1 w1 h1} [.t bbox test] {} + lappend result [list $x1 $w1 $h1] + .t image configure test -image small -align top + update + foreach {x2 y2 w2 h2} [.t bbox test] {} + lappend result [list [expr {$x1==$x2}] [expr {$w2>0}] [expr {$h2>0}]] +} -cleanup { + destroy .t + image delete small +} -result {{0 0 0} {1 1 1}} + # 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] @@ -360,13 +455,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 e78e54b..83a249e 100644 --- a/tests/textIndex.test +++ b/tests/textIndex.test @@ -804,7 +804,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 67b9ae5..edd0e92 100644 --- a/tests/textMark.test +++ b/tests/textMark.test @@ -6,30 +6,20 @@ # 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 . {} +entry .t.e .t peer create .pt -# 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 @@ -37,105 +27,120 @@ 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 + .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 - 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 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} test textMark-6.2 {TkTextMarkNameToIndex, with mark outside -startline/-endline range - bug 1630271} -body { .t mark set insert 1.0 .t configure -startline 2 @@ -178,45 +183,53 @@ test textMark-6.5 {insert and current marks in an empty peer - bug 3487407} -bod .t configure -startline {} -endline {} } -result {1.0} -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 -} {} +} -result {} test textMark-7.9 {MarkFindNext - mark set in a text widget and retrieved from a peer} -setup { .t mark unset {*}[.t mark names] } -body { @@ -224,20 +237,15 @@ test textMark-7.9 {MarkFindNext - mark set in a text widget and retrieved from a lsort [list [.pt mark next 1.0] [.pt mark next mymark] [.pt mark next insert]] } -result {current insert mymark} -test textMark-8.1 {MarkFindPrev - invalid mark name} -constraints haveCourier12 -setup { - .t mark unset {*}[.t mark names] -} -body { - catch {.t mark prev bogus} x - set x -} -result {bad text index "bogus"} -test textMark-8.2 {MarkFindPrev - marks at same location} -constraints haveCourier12 -setup { - .t mark unset {*}[.t mark names] -} -body { +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 } -result {current} -test textMark-8.3 {MarkFindPrev - numerical starting mark} -constraints haveCourier12 -setup { +test textMark-8.3 {MarkFindPrev - numerical starting mark} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 @@ -258,21 +266,21 @@ test textMark-8.5 {MarkFindPrev - mark on the previous line} -setup { .t mark set insert 2.0 .t mark prev insert } -result {current} -test textMark-8.6 {MarkFindPrev - mark far away} -constraints haveCourier12 -setup { +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 } -result {current} -test textMark-8.7 {MarkFindPrev - mark on top of end} -constraints haveCourier12 -setup { +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 } -result {insert} -test textMark-8.8 {MarkFindPrev - no previous mark} -constraints haveCourier12 -setup { +test textMark-8.8 {MarkFindPrev - no previous mark} -setup { .t mark unset {*}[.t mark names] } -body { .t mark set current 1.0 @@ -285,10 +293,14 @@ test textMark-8.9 {MarkFindPrev - mark set in a text widget and retrieved from a .t mark set mymark 1.0 lsort [list [.pt mark prev end] [.pt mark prev current] [.pt mark prev insert]] } -result {current insert mymark} - -catch {destroy .t} -catch {destroy .pt} + +destroy .pt +destroy .t # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/textTag.test b/tests/textTag.test index be31ebb..fed073a 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,112 +40,370 @@ 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} +} -cleanup { + .t tag remove sel 1.0 end +} -result {1.1 1.5 2.4 2.5} test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 { text .tt for {set i 1} {$i <10} {incr i} { @@ -161,433 +418,924 @@ test textTag-2.14 {tag add before -startline - Bug 1615425} haveCourier12 { set res 1 } {1} -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 { + +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 + .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 - 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 { + 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 +} -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 - 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 { +} -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 - 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 { +} -result {-justify {} {} {} left} +test textTag-5.9 {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 bogus +} -cleanup { + .t tag delete x +} -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 + .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 - 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 { +} -result {{-lmargin1 {} {} {} 2} {-lmargin2 {} {} {} 4} {-rmargin {} {} {} 5}} +test textTag-5.14 {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 -lmargin1 2.0x +} -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 "2.0x"} +test textTag-5.15 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .t tag configure x -lmargin2 gorp +} -cleanup { + .t tag delete x +} -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 - 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 { +} -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 lousy} msg] $msg -} {1 {bad screen distance "lousy"}} -test textTag-5.20 {TkTextTagCmd - "configure" option} haveCourier12 { + .t tag configure x -spacing1 lousy +} -cleanup { .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 { +} -returnCodes error -result {bad screen distance "lousy"} +test textTag-5.20 {TkTextTagCmd - "configure" option} -constraints { + haveCourier12 +} -body { + .t tag delete x + .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] @@ -598,8 +1346,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} @@ -615,13 +1365,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 { +} -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 - catch {.t tag delete x} - catch {.t tag delete y} +} -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} @@ -641,11 +1394,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} @@ -669,15 +1426,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 @@ -692,25 +1452,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 @@ -724,12 +1495,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 + } 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 @@ -742,59 +1523,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 { - event generate {} <Motion> -warp 1 -x -1 -y -1; update - 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 { - event generate {} <Motion> -warp 1 -x -1 -y -1; update - 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 { - event generate {} <Motion> -warp 1 -x -1 -y -1; update - 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 @@ -815,10 +1623,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 2e16f7b..27b7309 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,16 +1450,17 @@ 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}} -test textWind-18.1 {embedded window deletion triggered by a script bound to <Map>} { - catch {destroy .t .f} +test textWind-18.1 {embedded window deletion triggered by a script bound to <Map>} -setup { + catch {destroy .t .f .f2} +} -body { pack [text .t] for {set i 1} {$i < 100} {incr i} {.t insert end "Line $i\n"} .t window create end -window [frame .f -background red -width 80 -height 80] @@ -1035,9 +1471,10 @@ test textWind-18.1 {embedded window deletion triggered by a script bound to <Map after 100 {.t yview end} tkwait visibility .f2 update -} {} +} -cleanup { + destroy .t .f .f2 +} -result {} -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/ttk/treeview.test b/tests/ttk/treeview.test index d8bc65d..aa7e64a 100644 --- a/tests/ttk/treeview.test +++ b/tests/ttk/treeview.test @@ -405,7 +405,7 @@ test treeview-7.1 "move" -body { test treeview-7.2 "illegal move" -body { .tv move d d2 end -} -returnCodes 1 -result "Cannot insert d as a descendant of d2" +} -returnCodes 1 -result "Cannot insert d as descendant of d2" test treeview-7.3 "illegal move has no effect" -body { consistencyCheck .tv @@ -426,7 +426,7 @@ test treeview-7.5 "replace children - precondition" -body { test treeview-7.6 "Replace children - illegal move" -body { .tv children newnode.n1 [list newnode.n1 newnode.n2 newnode.n3] -} -returnCodes 1 -result "Cannot insert newnode.n1 as a descendant of newnode.n1" +} -returnCodes 1 -result "Cannot insert newnode.n1 as descendant of newnode.n1" consistencyCheck .tv diff --git a/tests/ttk/ttk.test b/tests/ttk/ttk.test index def709e..e58b021 100644 --- a/tests/ttk/ttk.test +++ b/tests/ttk/ttk.test @@ -48,7 +48,7 @@ test ttk-6.4 "Destroy widget in configure" -setup { pack [ttk::checkbutton .b] set rc [catch { .b configure -variable OUCH } msg] list $rc $msg [winfo exists .b] [info commands .b] -} -result [list 1 "Widget has been destroyed" 0 {}] +} -result [list 1 "widget has been destroyed" 0 {}] test ttk-6.5 "Clean up -textvariable traces" -body { foreach class {ttk::button ttk::checkbutton ttk::radiobutton} { @@ -121,7 +121,7 @@ test ttk-construction-failure-2 "Destroy widget in constructor" -setup { [winfo exists .b] \ [info commands .b] \ ; -} -result [list 1 "Widget has been destroyed" 0 {}] +} -result [list 1 "widget has been destroyed" 0 {}] test ttk-selfdestruct-ok-1 "Intentional self-destruction" -body { # see #2298720 @@ -222,15 +222,11 @@ test ttk-2.8 "bug 3223850: button state disabled during click" -setup { foreach wc $widgetClasses { test ttk-coreoptions-$wc "$wc has all core options" -body { ttk::$wc .w - foreach option { - -class - -style - -cursor - -takefocus - } { + foreach option {-class -style -cursor -takefocus} { .w cget $option } - destroy .w + } -cleanup { + catch {destroy .w} } } 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 bb515af..c8c36bf 100644..100755 --- 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]} { @@ -21,9 +22,26 @@ testConstraint english [expr { && (([testwinlocale] & 0xff) == 9) }] +proc vista? {{prevista 0} {postvista 1}} { + lassign [split $::tcl_platform(osVersion) .] major + return [expr {$major >= 6 ? $postvista : $prevista}] +} + +# What directory to use in initialdir tests. Old code used to use +# c:/. However, on Vista/later that is a protected directory if you +# are not running privileged. Moreover, not everyone has a drive c: +# but not having a TEMP would break a lot Windows programs +proc initialdir {} { + # file join to return in Tcl canonical format (/ separator, not \) + #return [file join $::env(TEMP)] + return [tcltest::temporaryDirectory] +} + + proc start {arg} { set ::tk_dialog 0 set ::iter_after 0 + set ::dialogclass "#32770" after 1 $arg } @@ -31,20 +49,37 @@ proc start {arg} { proc then {cmd} { set ::command $cmd set ::dialogresult {} + set ::testfont {} - afterbody + # Do not make the delay too short. The newer Vista dialogs take + # time to come up. Even if the testforwindow returns true, the + # controls are not ready to accept messages + after 500 afterbody vwait ::dialogresult return $::dialogresult } proc afterbody {} { - if {$::tk_dialog == 0} { - if {[incr ::iter_after] > 30} { - set ::dialogresult ">30 iterations waiting on tk_dialog" - return - } - after 150 {afterbody} - return + # On Vista and later, using the new file dialogs we have to find + # the window using its title as tk_dialog will not be set at the C level + if {[vista?]} { + if {[catch {testfindwindow "" $::dialogclass} ::tk_dialog]} { + if {[incr ::iter_after] > 30} { + set ::dialogresult ">30 iterations waiting on tk_dialog" + return + } + after 150 {afterbody} + return + } + } else { + if {$::tk_dialog == 0} { + 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,6 +105,12 @@ proc SetText {id text} { return [testwinevent $::tk_dialog $id WM_SETTEXT $text] } +proc ApplyFont {font} { + set ::testfont $font +} + +# ---------------------------------------------------------------------- + test winDialog-1.1 {Tk_ChooseColorObjCmd} -constraints { testwinevent } -body { @@ -156,13 +197,15 @@ test winDialog-1.7 {Tk_ChooseColorObjCmd: -parent} -constraints { } -returnCodes error -match glob -result {bad window path name*} +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 } return $x } -result {Cancel} @@ -173,8 +216,8 @@ test winDialog-4.1 {Tk_GetSaveFileObjCmd} -constraints { } -body { start {tk_getSaveFile} then { - set x [GetText cancel] - Click cancel + set x [GetText cancel] + Click cancel } return $x } -result {Cancel} @@ -184,7 +227,7 @@ test winDialog-5.1 {GetFileName: no arguments} -constraints { } -body { start {tk_getOpenFile -title Open} then { - Click cancel + Click cancel } } -result {0} test winDialog-5.2 {GetFileName: one argument} -constraints { @@ -195,9 +238,9 @@ test winDialog-5.2 {GetFileName: one argument} -constraints { test winDialog-5.3 {GetFileName: many arguments} -constraints { nt testwinevent } -body { - start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} + start {tk_getOpenFile -initialdir [initialdir] -parent . -title test -initialfile foo} then { - Click cancel + Click cancel } } -result {0} test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { @@ -208,158 +251,520 @@ test winDialog-5.4 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} -constraints { test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} -constraints { nt testwinevent } -body { - start {tk_getOpenFile -title bar} - then { - Click cancel - } + start {set x [tk_getOpenFile -title bar]} + set y [then { + Click cancel + }] + # Note this also tests fix for + # http://core.tcl.tk/tk/tktview/4a0451f5291b3c9168cc560747dae9264e1d2ef6 + # $x is expected to be empty + append x $y } -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++; -# } - start {set x [tk_getSaveFile -defaultextension .foo -title Save]} set msg {} then { - if {[catch {SetText 0x47C bar} msg]} { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.foo + +test winDialog-5.7.1 {GetFileName: extension {} } -constraints { + nt testwinevent +} -body { + start {set x [tk_getSaveFile -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar + +test winDialog-5.7.2 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { + nt testwinevent +} -body { + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar + +test winDialog-5.7.3 {GetFileName: extension {} Bug 47af31bd3ac6fbbb33cde1a5bab1e756ff2a6e00 } -constraints { + nt testwinevent +} -body { + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar.c} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.c + +test winDialog-5.7.4 {GetFileName: extension {} } -constraints { + nt testwinevent +} -body { + # Although the docs do not explicitly mention, -filetypes seems to + # override -defaultextension + start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {foo} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } - return [string totitle $x]$msg + set x "[file tail $x]$msg" } -cleanup { unset msg -} -result [string totitle [file join [pwd] bar.foo]] +} -result bar.c + +test winDialog-5.7.5 {GetFileName: extension {} } -constraints { + nt testwinevent +} -body { + # Although the docs do not explicitly mention, -filetypes seems to + # override -defaultextension + start {set x [tk_getSaveFile -filetypes {{C .c} {Tcl .tcl}} -defaultextension {} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.c + + +test winDialog-5.7.6 {GetFileName: All/extension } -constraints { + nt testwinevent +} -body { + # In 8.6.4 this combination resulted in bar.ext.ext which is bad + start {set x [tk_getSaveFile -filetypes {{All *}} -defaultextension {ext} -title Save]} + set msg {} + then { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { + Click cancel + } else { + Click ok + } + } + set x "[file tail $x]$msg" +} -cleanup { + unset msg +} -result bar.ext + +test winDialog-5.7.7 {tk_getOpenFile: -defaultextension} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + tcltest::makeFile "" "5 7 7.ext" [initialdir] + start {set x [tk_getOpenFile \ + -defaultextension ext \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 7 7" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 7 7.ext"] + +test winDialog-5.7.8 {tk_getOpenFile: -defaultextension} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + tcltest::makeFile "" "5 7 8.ext" [initialdir] + start {set x [tk_getOpenFile \ + -defaultextension ext \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 7 8.ext" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 7 8.ext"] + test winDialog-5.8 {GetFileName: extension doesn't begin with .} -constraints { nt testwinevent } -body { start {set x [tk_getSaveFile -defaultextension foo -title Save]} set msg {} then { - if {[catch {SetText 0x47C bar} msg]} { + if {[catch {SetText [vista? 0x47C 0x3e9] bar} msg]} { Click cancel } else { Click ok } } - return [string totitle $x]$msg + set x "[file tail $x]$msg" } -cleanup { unset msg -} -result [string totitle [file join [pwd] bar.foo]] +} -result bar.foo test winDialog-5.9 {GetFileName: file types} -constraints { nt testwinevent } -body { -# case FILE_TYPES: - + # case FILE_TYPES: + start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} - then { - set x [GetText 0x470] - Click cancel + # XXX - currently disabled for vista style dialogs because the file + # types control has no control ID and we don't have a mechanism to + # locate it. + if {[vista?]} { + then { + Click cancel + } + return 1 + } else { + then { + set x [GetText 0x470] + Click cancel + } + return [string equal $x {foo files (*.foo)}] } - return $x -} -result {foo files (*.foo)} +} -result 1 test winDialog-5.10 {GetFileName: file types: MakeFilter() fails} -constraints { nt } -body { -# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) +# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) tk_getSaveFile -filetypes {{"foo" .foo FOO}} } -returnCodes error -result {bad Macintosh file type "FOO"} -if {[info exists ::env(TEMP)]} { test winDialog-5.11 {GetFileName: initial directory} -constraints { nt testwinevent } -body { -# case FILE_INITDIR: - +# case FILE_INITDIR: + unset -nocomplain x start {set x [tk_getSaveFile \ - -initialdir [file normalize $::env(TEMP)] \ + -initialdir [initialdir] \ -initialfile "12x 455" -title Foo]} then { - Click ok + Click ok } return $x -} -result [file join [file normalize $::env(TEMP)] "12x 455"] -} +} -result [file join [initialdir] "12x 455"] + test winDialog-5.12 {GetFileName: initial directory: Tcl_TranslateFilename()} -constraints { nt } -body { -# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) +# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) tk_getOpenFile -initialdir ~12x/455 } -returnCodes error -result {user "12x" doesn't exist} + +test winDialog-5.12.1 {tk_getSaveFile: initial directory: ~} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir ~ \ + -initialfile "5 12 1" -title Foo]} + then { + Click ok + } + return $x +} -result [file normalize [file join ~ "5 12 1"]] + +test winDialog-5.12.2 {tk_getSaveFile: initial directory: ~user} -constraints { + nt testwinevent +} -body { + + # Note: this test will fail on Tcl versions 8.6.4 and earlier due + # to a bug in file normalize for names of the form ~xxx that + # returns the wrong dir on Windows. In particular (in Win8 at + # least) it returned /users/Default instead of /users/USERNAME... + + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir ~$::tcl_platform(user) \ + -initialfile "5 12 2" -title Foo]} + then { + Click ok + } + return $x +} -result [file normalize [file join ~$::tcl_platform(user) "5 12 2"]] + +test winDialog-5.12.3 {tk_getSaveFile: initial directory: .} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set newdir [tcltest::makeDirectory "5 12 3"] + set cur [pwd] + try { + cd $newdir + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir . \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x [file join $newdir testfile] +} -result 1 + +test winDialog-5.12.4 {tk_getSaveFile: initial directory: unicode} -constraints { + nt testwinevent +} -body { + set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir $dir \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + string equal $x [file join $dir testfile] +} -result 1 + +test winDialog-5.12.5 {tk_getSaveFile: initial directory: nativename} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 12 5" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 12 5"] + +test winDialog-5.12.6 {tk_getSaveFile: initial directory: relative} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set dir [tcltest::makeDirectory "5 12 6"] + set cur [pwd] + try { + cd [file dirname $dir] + unset -nocomplain x + start {set x [tk_getSaveFile \ + -initialdir "5 12 6" \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x [file join $dir testfile] +} -result 1 + +test winDialog-5.12.7 {tk_getOpenFile: initial directory: ~} -constraints { + nt testwinevent +} -body { + set fn [file tail [lindex [glob -types f ~/*] 0]] + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir ~ \ + -initialfile $fn -title Foo]} + then { + Click ok + } + string equal $x [file normalize [file join ~ $fn]] +} -result 1 + +test winDialog-5.12.8 {tk_getOpenFile: initial directory: .} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set newdir [tcltest::makeDirectory "5 12 8"] + set path [tcltest::makeFile "" "testfile" $newdir] + set cur [pwd] + try { + cd $newdir + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir . \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x $path +} -result 1 + +test winDialog-5.12.9 {tk_getOpenFile: initial directory: unicode} -constraints { + nt testwinevent +} -body { + set dir [tcltest::makeDirectory "\u0167\u00e9\u015d\u0167"] + set path [tcltest::makeFile "" testfile $dir] + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir $dir \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + string equal $x $path +} -result 1 + +test winDialog-5.12.10 {tk_getOpenFile: initial directory: nativename} -constraints { + nt testwinevent +} -body { + unset -nocomplain x + tcltest::makeFile "" "5 12 10" [initialdir] + start {set x [tk_getOpenFile \ + -initialdir [file nativename [initialdir]] \ + -initialfile "5 12 10" -title Foo]} + then { + Click ok + } + return $x +} -result [file join [initialdir] "5 12 10"] + +test winDialog-5.12.11 {tk_getOpenFile: initial directory: relative} -constraints { + nt testwinevent +} -body { + # Windows remembers dirs from previous selections so use + # a subdir for this test, not [initialdir] itself + set dir [tcltest::makeDirectory "5 12 11"] + set path [tcltest::makeFile "" testfile $dir] + set cur [pwd] + try { + cd [file dirname $dir] + unset -nocomplain x + start {set x [tk_getOpenFile \ + -initialdir [file tail $dir] \ + -initialfile "testfile" -title Foo]} + then { + Click ok + } + } finally { + cd $cur + } + string equal $x $path +} -result 1 + test winDialog-5.13 {GetFileName: initial file} -constraints { nt testwinevent } -body { -# case FILE_INITFILE: +# case FILE_INITFILE: start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} then { - Click ok + Click ok } - string totitle $x -} -result [string totitle [file join [pwd] "12x 456"]] + file tail $x +} -result "12x 456" test winDialog-5.14 {GetFileName: initial file: Tcl_TranslateFileName()} -constraints { nt } -body { -# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) +# 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 - } - list $dialogresult [string match "invalid filename *" $x] -} -result {1 1} +if {![vista?]} { + # XXX - disabled for Vista because the new dialogs allow long file + # names to be specified but force the user to change it. + 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 + } + list $dialogresult [string match "invalid filename *" $x] + } -result {1 1} +} test winDialog-5.16 {GetFileName: parent} -constraints { nt } -body { -# case FILE_PARENT: +# case FILE_PARENT: toplevel .t set x 0 start {tk_getOpenFile -parent .t -title Parent; set x 1} then { - destroy .t + destroy .t } return $x } -result {1} test winDialog-5.17 {GetFileName: title} -constraints { nt testwinevent } -body { -# case FILE_TITLE: - +# case FILE_TITLE: + start {tk_getOpenFile -title Narf} then { - Click cancel + Click cancel } } -result {0} -test winDialog-5.18 {GetFileName: no filter specified} -constraints { - nt testwinevent -} -body { -# if (ofn.lpstrFilter == NULL) +if {[vista?]} { + # In the newer file dialogs, the file type widget does not even exist + # if no file types specified + test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent + } -body { + # if (ofn.lpstrFilter == NULL) + start {tk_getOpenFile -title Filter} + then { + catch {set x [GetText 0x470]} y + Click cancel + } + return $y + } -result {Could not find control with id 1136} +} else { + test winDialog-5.18 {GetFileName: no filter specified} -constraints { + nt testwinevent + } -body { + # if (ofn.lpstrFilter == NULL) - start {tk_getOpenFile -title Filter} - then { - set x [GetText 0x470] - Click cancel - } - return $x -} -result {All Files (*.*)} + start {tk_getOpenFile -title Filter} + then { + set x [GetText 0x470] + Click cancel + } + return $x + } -result {All Files (*.*)} +} test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { nt } -setup { @@ -370,7 +775,7 @@ test winDialog-5.19 {GetFileName: parent HWND doesn't yet exist} -constraints { toplevel .t start {tk_getOpenFile -parent .t -title Open} then { - destroy .t + destroy .t } } -result {} test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints { @@ -382,42 +787,41 @@ test winDialog-5.20 {GetFileName: parent HWND already exists} -constraints { update start {tk_getOpenFile -parent .t -title Open} then { - destroy .t + destroy .t } } -result {} test winDialog-5.21 {GetFileName: call GetOpenFileName} -constraints { nt testwinevent english } -body { -# winCode = GetOpenFileName(&ofn); - +# winCode = GetOpenFileName(&ofn); + start {tk_getOpenFile -title Open} then { - set x [GetText ok] - Click cancel + set x [GetText ok] + Click cancel } return $x } -result {&Open} test winDialog-5.22 {GetFileName: call GetSaveFileName} -constraints { nt testwinevent english } -body { -# winCode = GetSaveFileName(&ofn); +# winCode = GetSaveFileName(&ofn); start {tk_getSaveFile -title Save} then { - set x [GetText ok] - Click cancel + set x [GetText ok] + Click cancel } return $x } -result {&Save} -if {[info exists ::env(TEMP)]} { test winDialog-5.23 {GetFileName: convert \ to /} -constraints { nt testwinevent } -body { set msg {} start {set x [tk_getSaveFile -title Back]} then { - if {[catch {SetText 0x47C [file nativename \ - [file join [file normalize $::env(TEMP)] "12x 457"]]} msg]} { + if {[catch {SetText [vista? 0x47C 0x3e9] [file nativename \ + [file join [initialdir] "12x 457"]]} msg]} { Click cancel } else { Click ok @@ -426,8 +830,7 @@ test winDialog-5.23 {GetFileName: convert \ to /} -constraints { return $x$msg } -cleanup { unset msg -} -result [file join [file normalize $::env(TEMP)] "12x 457"] -} +} -result [file join [initialdir] "12x 457"] test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraints { nt } -body { @@ -435,7 +838,7 @@ test winDialog-5.24 {GetFileName: file types: MakeFilter() succeeds} -constraint start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} then { - Click cancel + Click cancel } return $x } -result {0} @@ -446,11 +849,21 @@ test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraint start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} then { - Click cancel + Click cancel } 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-8.1 {OFNHookProc} -constraints {emptyTest nt} -body {} + + ## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows ## because somehow the GetOpenFileName ends up a noop in the static ## build. @@ -458,10 +871,12 @@ test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} -constraint test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} -constraints { nt testwinevent } -body { - start {tk_chooseDirectory} - then { - Click cancel - } + start {set x [tk_chooseDirectory]} + set y [then { + Click cancel + }] + # $x should be "" on a Cancel + append x $y } -result {0} test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} -constraints { nt @@ -472,10 +887,10 @@ 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 [initialdir] -mustexist 1 -parent . -title test } then { - Click cancel + Click cancel } } -result {0} test winDialog-9.4 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() != TCL_OK} -constraints { @@ -488,7 +903,7 @@ test winDialog-9.5 {Tk_ChooseDirectoryObjCmd: Tcl_GetIndexFromObj() == TCL_OK} - } -body { start {tk_chooseDirectory -title bar} then { - Click cancel + Click cancel } } -result {0} test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} -constraints { @@ -499,23 +914,135 @@ test winDialog-9.6 {Tk_ChooseDirectoryObjCmd: valid option, but missing value} - test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} -constraints { nt testwinevent } -body { -# case DIR_INITIAL: +# case DIR_INITIAL: - start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} + start {set x [tk_chooseDirectory -initialdir [initialdir] -title Foo]} then { - Click ok + Click ok } string tolower [set x] -} -result {c:/} +} -result [string tolower [initialdir]] test winDialog-9.8 {Tk_ChooseDirectoryObjCmd: initial directory: Tcl_TranslateFilename()} -constraints { nt } -body { -# if (Tcl_TranslateFileName(interp, string, -# &utfDirString) == NULL) - +# 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} } @@ -527,3 +1054,4 @@ 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 933d09e..ad4988d 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} { @@ -465,7 +539,7 @@ test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -setup frame .t.f -background blue -height 200 -width 200 frame .t.f.x -background red -height 100 -width 100 } -body { - pack .t.f.x + pack .t.f.x pack .t.f lappend aid [after 2000 {set ::winwm92 timeout}] [after 100 { wm manage .t.f @@ -488,7 +562,7 @@ test winWm-9.2 "check wm forget for unmapped parent (#3205464,#2967911)" -setup set winwm92 } -cleanup { destroy .t.f.x .t.f .t - unset -nocomplain winwm92 aid + unset -nocomplain winwm92 aid id } -result ok destroy .t @@ -500,3 +574,4 @@ return # Local variables: # mode: tcl # End: + diff --git a/tests/window.test b/tests/window.test index 2c8f19d..fea695a 100644 --- a/tests/window.test +++ b/tests/window.test @@ -5,42 +5,48 @@ # 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 +56,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 +69,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 +83,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 +96,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 +116,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 +136,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 +157,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 +181,17 @@ 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 +} -body { set code [loadTkCommand] append code { toplevel .t1 @@ -188,17 +203,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 +227,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 +255,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 +276,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 +294,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 +337,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: |